From 316c386bcdbb66accdd65a311ca978b6d4606695 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 17 Aug 2023 14:17:47 +0200 Subject: Make a minor modification --- compiler/Assumed.ml | 11 ----------- 1 file changed, 11 deletions(-) (limited to 'compiler') diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 11cd5666..25462504 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -86,7 +86,6 @@ module Sig = struct let output = tvar_0 (* T *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; @@ -98,7 +97,6 @@ module Sig = struct let box_new_sig : A.fun_sig = { region_params = []; - num_early_bound_regions = 0; regions_hierarchy = []; type_params = [ type_param_0 ] (* *); const_generic_params = empty_const_generic_params; @@ -110,7 +108,6 @@ module Sig = struct let box_free_sig : A.fun_sig = { region_params = []; - num_early_bound_regions = 0; regions_hierarchy = []; type_params = [ type_param_0 ] (* *); const_generic_params = empty_const_generic_params; @@ -128,7 +125,6 @@ module Sig = struct let regions_hierarchy = [ region_group_0 ] (* <'a> *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params = [ type_param_0 ] (* *); const_generic_params = empty_const_generic_params; @@ -152,7 +148,6 @@ module Sig = struct let output = mk_vec_ty tvar_0 (* Vec *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; @@ -175,7 +170,6 @@ module Sig = struct let output = mk_unit_ty (* () *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; @@ -199,7 +193,6 @@ module Sig = struct let output = mk_unit_ty (* () *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; @@ -219,7 +212,6 @@ module Sig = struct let output = mk_usize_ty (* usize *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; @@ -244,7 +236,6 @@ module Sig = struct let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; @@ -296,7 +287,6 @@ module Sig = struct in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = cgs; @@ -362,7 +352,6 @@ module Sig = struct let output = mk_usize_ty (* usize *) in { region_params; - num_early_bound_regions = 0; regions_hierarchy; type_params; const_generic_params = empty_const_generic_params; -- cgit v1.2.3 From 26c25bf375742cf4d5a0ab160b9646e90c067f18 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 18 Aug 2023 10:27:55 +0200 Subject: Update following the introduction of ConstantExpr --- compiler/Contexts.ml | 9 ++ compiler/Extract.ml | 3 + compiler/Interpreter.ml | 10 ++ compiler/InterpreterBorrows.ml | 3 +- compiler/InterpreterExpressions.ml | 41 ++++++-- compiler/InterpreterLoopsJoinCtxs.ml | 3 + compiler/InterpreterStatements.ml | 198 ++++++++++++++++++----------------- compiler/InterpreterUtils.ml | 3 +- compiler/PrintPure.ml | 5 +- compiler/Pure.ml | 2 + compiler/PureMicroPasses.ml | 7 +- compiler/PureTypeCheck.ml | 5 + compiler/PureUtils.ml | 3 +- compiler/SymbolicAst.ml | 20 ++-- compiler/SymbolicToPure.ml | 49 +++++---- compiler/Values.ml | 2 + 16 files changed, 220 insertions(+), 143 deletions(-) (limited to 'compiler') diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 2ca5653d..14b5d559 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -263,6 +263,10 @@ type eval_ctx = { region_groups : RegionGroupId.id list; type_vars : type_var list; const_generic_vars : const_generic_var list; + const_generic_vars_map : typed_value Types.ConstGenericVarId.Map.t; + (** The map from const generic vars to their values. Those values + can be symbolic values or concrete values (in the latter case: + if we run in interpreter mode) *) env : env; ended_regions : RegionId.Set.t; } @@ -312,6 +316,11 @@ let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = let ctx_lookup_var_value (ctx : eval_ctx) (vid : VarId.id) : typed_value = env_lookup_var_value ctx.env vid +(** Retrieve a const generic value in an evaluation context *) +let ctx_lookup_const_generic_value (ctx : eval_ctx) (vid : ConstGenericVarId.id) + : typed_value = + Types.ConstGenericVarId.Map.find vid ctx.const_generic_vars_map + (** Update a variable's value in the current frame. This is a helper function: it can break invariants and doesn't perform diff --git a/compiler/Extract.ml b/compiler/Extract.ml index c4238d83..7daec16f 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2249,6 +2249,9 @@ let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) | Var var_id -> let var_name = ctx_get_var var_id ctx in F.pp_print_string fmt var_name + | CVar var_id -> + let var_name = ctx_get_const_generic_var var_id ctx in + F.pp_print_string fmt var_name | Const cv -> ctx.fmt.extract_literal fmt inside cv | App _ -> let app, args = destruct_apps e in diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 154c5a21..37eeb333 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -34,6 +34,15 @@ let initialize_eval_context (type_context : C.type_context) (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) (const_generic_vars : T.const_generic_var list) : C.eval_ctx = C.reset_global_counters (); + let const_generic_vars_map = + T.ConstGenericVarId.Map.of_list + (List.map + (fun (cg : T.const_generic_var) -> + let ty = TypesUtils.ety_no_regions_to_rty (T.Literal cg.ty) in + let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in + (cg.index, cv)) + const_generic_vars) + in { C.type_context; C.fun_context; @@ -41,6 +50,7 @@ let initialize_eval_context (type_context : C.type_context) C.region_groups; C.type_vars; C.const_generic_vars; + C.const_generic_vars_map; C.env = [ C.Frame ]; C.ended_regions = T.RegionId.Set.empty; } diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 4d67a4e4..f908d060 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -452,7 +452,8 @@ let give_back_symbolic_value (_config : C.config) | V.SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> () - | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate -> + | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate + | ConstGeneric -> raise (Failure "Unreachable")); (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 8b2070c6..2f6a7b49 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -230,17 +230,16 @@ let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : let prepare : cm_fun = fun cf ctx -> match op with - | Expressions.Constant (ty, cv) -> + | E.Constant _ -> (* No need to reorganize the context *) - literal_to_typed_value (TypesUtils.ty_as_literal ty) cv |> ignore; cf ctx - | Expressions.Copy p -> + | E.Copy p -> (* Access the value *) let access = Read in (* Expand the symbolic values, if necessary *) let expand_prim_copy = true in access_rplace_reorganize config expand_prim_copy access p cf ctx - | Expressions.Move p -> + | E.Move p -> (* Access the value *) let access = Move in let expand_prim_copy = false in @@ -260,9 +259,35 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Evaluate *) match op with - | Expressions.Constant (ty, cv) -> - cf (literal_to_typed_value (TypesUtils.ty_as_literal ty) cv) ctx - | Expressions.Copy p -> + | E.Constant cv -> ( + match cv.value with + | E.CLiteral lit -> + cf (literal_to_typed_value (TypesUtils.ty_as_literal cv.ty) lit) ctx + | E.CVar vid -> ( + let ctx0 = ctx in + (* Lookup the const generic value *) + let cv = C.ctx_lookup_const_generic_value ctx vid in + (* Copy the value *) + let allow_adt_copy = false in + let ctx, v = copy_value allow_adt_copy config ctx cv in + (* Continue *) + let e = cf v ctx in + (* We have to wrap the expression to introduce *) + match e with + | None -> None + | Some e -> + (* If we are synthesizing a symbolic AST, it means that we are in symbolic + mode: the value of the const generic is necessarily symbolic. *) + assert (is_symbolic cv.V.value); + (* *) + Some + (SymbolicAst.IntroSymbolic + ( ctx0, + None, + value_as_symbolic v.value, + SymbolicAst.ConstGenericValue vid, + e )))) + | E.Copy p -> (* Access the value *) let access = Read in let cc = read_place access p in @@ -283,7 +308,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) in (* Compose and apply *) comp cc copy cf ctx - | Expressions.Move p -> + | E.Move p -> (* Access the value *) let access = Move in let cc = read_place access p in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index bf88e055..10205c27 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -557,6 +557,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) region_groups; type_vars; const_generic_vars; + const_generic_vars_map; env = _; ended_regions = ended_regions0; } = @@ -569,6 +570,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) region_groups = _; type_vars = _; const_generic_vars = _; + const_generic_vars_map = _; env = _; ended_regions = ended_regions1; } = @@ -583,6 +585,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) region_groups; type_vars; const_generic_vars; + const_generic_vars_map; env; ended_regions; } diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 045c4484..6d520059 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -421,16 +421,16 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = (** Auxiliary function - see {!eval_non_local_function_call} *) let eval_replace_concrete (_config : C.config) (_region_params : T.erased_region list) (_type_params : T.ety list) - (_cg_params : T.const_generic list) : cm_fun = + (_cg_args : T.const_generic list) : cm_fun = fun _cf _ctx -> raise Unimplemented (** Auxiliary function - see {!eval_non_local_function_call} *) let eval_box_new_concrete (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) : cm_fun = + (cg_args : T.const_generic list) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) - match (region_params, type_params, cg_params, ctx.env) with + match (region_params, type_params, cg_args, ctx.env) with | ( [], [ boxed_ty ], [], @@ -470,10 +470,10 @@ let eval_box_new_concrete (config : C.config) and [std::DerefMut::deref_mut] - see {!eval_non_local_function_call} *) let eval_box_deref_mut_or_shared_concrete (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) (is_mut : bool) : cm_fun = + (cg_args : T.const_generic list) (is_mut : bool) : cm_fun = fun cf ctx -> (* Check the arguments *) - match (region_params, type_params, cg_params, ctx.env) with + match (region_params, type_params, cg_args, ctx.env) with | ( [], [ boxed_ty ], [], @@ -517,18 +517,18 @@ let eval_box_deref_mut_or_shared_concrete (config : C.config) (** Auxiliary function - see {!eval_non_local_function_call} *) let eval_box_deref_concrete (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) : cm_fun = + (cg_args : T.const_generic list) : cm_fun = let is_mut = false in - eval_box_deref_mut_or_shared_concrete config region_params type_params - cg_params is_mut + eval_box_deref_mut_or_shared_concrete config region_params type_params cg_args + is_mut (** Auxiliary function - see {!eval_non_local_function_call} *) let eval_box_deref_mut_concrete (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (cg_params : T.const_generic list) : cm_fun = + (cg_args : T.const_generic list) : cm_fun = let is_mut = true in - eval_box_deref_mut_or_shared_concrete config region_params type_params - cg_params is_mut + eval_box_deref_mut_or_shared_concrete config region_params type_params cg_args + is_mut (** Auxiliary function - see {!eval_non_local_function_call}. @@ -550,10 +550,10 @@ let eval_box_deref_mut_concrete (config : C.config) the destination (by setting it to [()]). *) let eval_box_free (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (cg_params : T.const_generic list) + (type_params : T.ety list) (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : cm_fun = fun cf ctx -> - match (region_params, type_params, cg_params, args) with + match (region_params, type_params, cg_args, args) with | [], [ boxed_ty ], [], [ E.Move input_box_place ] -> (* Required type checking *) let input_box = InterpreterPaths.read_place Write input_box_place ctx in @@ -573,14 +573,17 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) (** Auxiliary function - see {!eval_non_local_function_call} *) let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) (_region_params : T.erased_region list) (_type_params : T.ety list) - (_cg_params : T.const_generic list) : cm_fun = + (_cg_args : T.const_generic list) : cm_fun = fun _cf _ctx -> raise Unimplemented (** Evaluate a non-local function call in concrete mode *) let eval_non_local_function_call_concrete (config : C.config) (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (cg_params : T.const_generic list) + (type_params : T.ety list) (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : cm_fun = + (* Sanity check: we don't fully handle the const generic vars environment + in concrete mode yet *) + assert (cg_args = []); (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -589,7 +592,7 @@ let eval_non_local_function_call_concrete (config : C.config) match fid with | A.BoxFree -> (* Degenerate case: box_free *) - eval_box_free config region_params type_params cg_params args dest + eval_box_free config region_params type_params cg_args args dest | _ -> (* "Normal" case: not box_free *) (* Evaluate the operands *) @@ -612,7 +615,7 @@ let eval_non_local_function_call_concrete (config : C.config) let ret_vid = E.VarId.zero in let ret_ty = get_non_local_function_return_type fid region_params type_params - cg_params + cg_args in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var ret_var) in @@ -631,19 +634,19 @@ let eval_non_local_function_call_concrete (config : C.config) let cf_eval_body : cm_fun = match fid with | A.Replace -> - eval_replace_concrete config region_params type_params cg_params + eval_replace_concrete config region_params type_params cg_args | BoxNew -> - eval_box_new_concrete config region_params type_params cg_params + eval_box_new_concrete config region_params type_params cg_args | BoxDeref -> - eval_box_deref_concrete config region_params type_params cg_params + eval_box_deref_concrete config region_params type_params cg_args | BoxDerefMut -> eval_box_deref_mut_concrete config region_params type_params - cg_params + cg_args | BoxFree -> (* Should have been treated above *) raise (Failure "Unreachable") | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> eval_vec_function_concrete config fid region_params type_params - cg_params + cg_args | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut | ArraySubsliceShared | ArraySubsliceMut | SliceIndexShared | SliceIndexMut | SliceSubsliceShared @@ -663,7 +666,7 @@ let eval_non_local_function_call_concrete (config : C.config) comp cf_eval_ops cf_eval_call let instantiate_fun_sig (type_params : T.ety list) - (cg_params : T.const_generic list) (sg : A.fun_sig) : A.inst_fun_sig = + (cg_args : T.const_generic list) (sg : A.fun_sig) : A.inst_fun_sig = (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = @@ -694,7 +697,7 @@ let instantiate_fun_sig (type_params : T.ety list) let rtype_params = List.map ety_no_regions_to_rty type_params in let tsubst = Subst.make_type_subst_from_vars sg.type_params rtype_params in let cgsubst = - Subst.make_const_generic_subst_from_vars sg.const_generic_params cg_params + Subst.make_const_generic_subst_from_vars sg.const_generic_params cg_args in (* Substitute the signature *) let inst_sig = Subst.substitute_signature asubst rsubst tsubst cgsubst sg in @@ -1054,81 +1057,86 @@ and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) (_region_args : T.erased_region list) (type_args : T.ety list) (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : st_cm_fun = - fun cf ctx -> - (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_decl ctx fid in - (* We can evaluate the function call only if it is not opaque *) - let body = - match def.body with - | None -> - raise - (Failure - ("Can't evaluate a call to an opaque function: " - ^ Print.name_to_string def.name)) - | Some body -> body - in - let tsubst = - Subst.make_type_subst_from_vars def.A.signature.type_params type_args - in - let cgsubst = - Subst.make_const_generic_subst_from_vars - def.A.signature.const_generic_params cg_args - in - let locals, body_st = Subst.fun_body_substitute_in_body tsubst cgsubst body in - - (* Evaluate the input operands *) - assert (List.length args = body.A.arg_count); - let cc = eval_operands config args in - - (* Push a frame delimiter - we use {!comp_transmit} to transmit the result - * of the operands evaluation from above to the functions afterwards, while - * ignoring it in this function *) - let cc = comp_transmit cc push_frame in - - (* Compute the initial values for the local variables *) - (* 1. Push the return value *) - let ret_var, locals = - match locals with - | ret_ty :: locals -> (ret_ty, locals) - | _ -> raise (Failure "Unreachable") - in - let input_locals, locals = - Collections.List.split_at locals body.A.arg_count - in - - let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in - - (* 2. Push the input values *) - let cf_push_inputs cf args = - let inputs = List.combine input_locals args in - (* Note that this function checks that the variables and their values - * have the same type (this is important) *) - push_vars inputs cf - in - let cc = comp cc cf_push_inputs in + (* Sanity check: we don't fully handle the const generic vars environment + in concrete mode yet *) + assert (cg_args = []); + fun cf ctx -> + (* Retrieve the (correctly instantiated) body *) + let def = C.ctx_lookup_fun_decl ctx fid in + (* We can evaluate the function call only if it is not opaque *) + let body = + match def.body with + | None -> + raise + (Failure + ("Can't evaluate a call to an opaque function: " + ^ Print.name_to_string def.name)) + | Some body -> body + in + let tsubst = + Subst.make_type_subst_from_vars def.A.signature.type_params type_args + in + let cgsubst = + Subst.make_const_generic_subst_from_vars + def.A.signature.const_generic_params cg_args + in + let locals, body_st = + Subst.fun_body_substitute_in_body tsubst cgsubst body + in - (* 3. Push the remaining local variables (initialized as {!Bottom}) *) - let cc = comp cc (push_uninitialized_vars locals) in + (* Evaluate the input operands *) + assert (List.length args = body.A.arg_count); + let cc = eval_operands config args in + + (* Push a frame delimiter - we use {!comp_transmit} to transmit the result + * of the operands evaluation from above to the functions afterwards, while + * ignoring it in this function *) + let cc = comp_transmit cc push_frame in + + (* Compute the initial values for the local variables *) + (* 1. Push the return value *) + let ret_var, locals = + match locals with + | ret_ty :: locals -> (ret_ty, locals) + | _ -> raise (Failure "Unreachable") + in + let input_locals, locals = + Collections.List.split_at locals body.A.arg_count + in - (* Execute the function body *) - let cc = comp cc (eval_function_body config body_st) in + let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in - (* Pop the stack frame and move the return value to its destination *) - let cf_finish cf res = - match res with - | Panic -> cf Panic - | Return -> - (* Pop the stack frame, retrieve the return value, move it to - * its destination and continue *) - pop_frame_assign config dest (cf Unit) - | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ - | EndContinue _ -> - raise (Failure "Unreachable") - in - let cc = comp cc cf_finish in + (* 2. Push the input values *) + let cf_push_inputs cf args = + let inputs = List.combine input_locals args in + (* Note that this function checks that the variables and their values + * have the same type (this is important) *) + push_vars inputs cf + in + let cc = comp cc cf_push_inputs in + + (* 3. Push the remaining local variables (initialized as {!Bottom}) *) + let cc = comp cc (push_uninitialized_vars locals) in + + (* Execute the function body *) + let cc = comp cc (eval_function_body config body_st) in + + (* Pop the stack frame and move the return value to its destination *) + let cf_finish cf res = + match res with + | Panic -> cf Panic + | Return -> + (* Pop the stack frame, retrieve the return value, move it to + * its destination and continue *) + pop_frame_assign config dest (cf Unit) + | Break _ | Continue _ | Unit | LoopReturn _ | EndEnterLoop _ + | EndContinue _ -> + raise (Failure "Unreachable") + in + let cc = comp cc cf_finish in - (* Continue *) - cc cf ctx + (* Continue *) + cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 7bd37550..637f1b1e 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -255,7 +255,8 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) raise Found else () | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack | V.Global | V.LoopGivenBack | V.Aggregate -> + | V.SynthRetGivenBack | V.Global | V.LoopGivenBack | V.Aggregate + | V.ConstGeneric -> () end in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index cfb63ec2..dfb2c9fd 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -559,9 +559,8 @@ let fun_or_op_id_to_string (fmt : ast_formatter) (fun_id : fun_or_op_id) : let rec texpression_to_string (fmt : ast_formatter) (inside : bool) (indent : string) (indent_incr : string) (e : texpression) : string = match e.e with - | Var var_id -> - let s = fmt.var_id_to_string var_id in - if inside then "(" ^ s ^ ")" else s + | Var var_id -> fmt.var_id_to_string var_id + | CVar cg_id -> fmt.const_generic_var_id_to_string cg_id | Const cv -> literal_to_string cv | App _ -> (* Recursively destruct the app, to have a pair (app, arguments list) *) diff --git a/compiler/Pure.ml b/compiler/Pure.ml index ac4ca081..55513cc2 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -37,6 +37,7 @@ module ConstGenericVarId = T.ConstGenericVarId type integer_type = T.integer_type [@@deriving show, ord] type const_generic_var = T.const_generic_var [@@deriving show, ord] type const_generic = T.const_generic [@@deriving show, ord] +type const_generic_var_id = T.const_generic_var_id [@@deriving show, ord] (** The assumed types for the pure AST. @@ -536,6 +537,7 @@ class virtual ['self] mapreduce_expression_base = *) type expression = | Var of var_id (** a variable *) + | CVar of const_generic_var_id (** a const generic var *) | Const of literal | App of texpression * texpression (** Application of a function to an argument. diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index b6025df4..65dc7ff2 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -376,8 +376,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = let ty = e.ty in let ctx, e = match e.e with - | Var _ -> (* Nothing to do *) (ctx, e.e) - | Const _ -> (* Nothing to do *) (ctx, e.e) + | Var _ | CVar _ | Const _ -> (* Nothing to do *) (ctx, e.e) | App (app, arg) -> let ctx, app = update_texpression app ctx in let ctx, arg = update_texpression arg ctx in @@ -834,7 +833,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) method! visit_texpression env e = match e.e with - | Var _ | Const _ -> fun _ -> false + | Var _ | CVar _ | Const _ -> fun _ -> false | StructUpdate _ -> (* There shouldn't be monadic calls in structure updates - also note that by returning [false] we are conservative: we might @@ -930,7 +929,7 @@ let filter_useless (filter_monadic_calls : bool) (ctx : trans_ctx) method! visit_expression env e = match e with - | Var _ | Const _ | App _ | Qualif _ + | Var _ | CVar _ | Const _ | App _ | Qualif _ | Switch (_, _) | Meta (_, _) | StructUpdate _ | Abs _ -> diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 8d28bb8a..d145ce93 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -65,6 +65,8 @@ type tc_ctx = { global_decls : A.global_decl A.GlobalDeclId.Map.t; (** The global declarations *) env : ty VarId.Map.t; (** Environment from variables to types *) + const_generics : ty T.ConstGenericVarId.Map.t; + (** The types of the const generics *) } let check_literal (v : literal) (ty : literal_type) : unit = @@ -115,6 +117,9 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = match VarId.Map.find_opt var_id ctx.env with | None -> () | Some ty -> assert (ty = e.ty)) + | CVar cg_id -> + let ty = T.ConstGenericVarId.Map.find cg_id ctx.const_generics in + assert (ty = e.ty) | Const cv -> check_literal cv (ty_as_literal e.ty) | App (app, arg) -> let input_ty, output_ty = destruct_arrow app.ty in diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 1c8d8921..461098f2 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -164,7 +164,8 @@ let fun_sig_substitute (tsubst : TypeVarId.id -> ty) *) let rec let_group_requires_parentheses (e : texpression) : bool = match e.e with - | Var _ | Const _ | App _ | Abs _ | Qualif _ | StructUpdate _ -> false + | Var _ | CVar _ | Const _ | App _ | Abs _ | Qualif _ | StructUpdate _ -> + false | Let (monadic, _, _, next_e) -> if monadic then true else let_group_requires_parentheses next_e | Switch (_, _) -> false diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 7dc94dcd..17cdcabc 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -79,6 +79,9 @@ class ['self] iter_expression_base = method visit_loop_id : 'env -> V.loop_id -> unit = fun _ _ -> () method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () + method visit_const_generic_var_id : 'env -> T.const_generic_var_id -> unit = + fun _ _ -> () + method visit_symbolic_value_id : 'env -> V.symbolic_value_id -> unit = fun _ _ -> () @@ -171,14 +174,14 @@ type expression = * expression (** We introduce a new symbolic value, equal to some other value. - This is used for instance when reorganizing the environment to compute - fixed points: we duplicate some shared symbolic values to destructure - the shared values, in order to make the environment a bit more general - (while losing precision of course). + This is used for instance when reorganizing the environment to compute + fixed points: we duplicate some shared symbolic values to destructure + the shared values, in order to make the environment a bit more general + (while losing precision of course). - The context is the evaluation context from before introducing the new - value. It has the same purpose as for the {!Return} case. - *) + The context is the evaluation context from before introducing the new + value. It has the same purpose as for the {!Return} case. + *) | ForwardEnd of Contexts.eval_ctx * V.typed_value symbolic_value_id_map option @@ -253,6 +256,9 @@ and value_aggregate = | SingleValue of V.typed_value (** Regular case *) | Array of V.typed_value list (** This is used when introducing array aggregates *) + | ConstGenericValue of T.const_generic_var_id + (** This is used when evaluating a const generic value: in the interpreter, + we introduce a fresh symbolic value. *) [@@deriving show, visitors diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3512270a..7dda1f22 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -201,29 +201,6 @@ type bs_ctx = { } [@@deriving show] -let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - let _ = PureTypeCheck.check_typed_pattern ctx v in - () - -let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = - let env = VarId.Map.empty in - let ctx = - { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env; - } - in - PureTypeCheck.check_texpression ctx e - (* TODO: move *) let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = Print.Ast.decls_and_fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls @@ -589,6 +566,31 @@ let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) let type_infos = ctx.type_context.type_infos in translate_back_ty type_infos keep_region inside_mut ty +let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = + let const_generics = + T.ConstGenericVarId.Map.of_list + (List.map + (fun (cg : T.const_generic_var) -> + (cg.index, ctx_translate_fwd_ty ctx (T.Literal cg.ty))) + ctx.sg.const_generic_params) + in + let env = VarId.Map.empty in + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + const_generics; + } + +let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = + let ctx = mk_type_check_ctx ctx in + let _ = PureTypeCheck.check_typed_pattern ctx v in + () + +let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = + let ctx = mk_type_check_ctx ctx in + PureTypeCheck.check_texpression ctx e + (** 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 = @@ -2298,6 +2300,7 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) { struct_id = Assumed Array; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } + | ConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } in (* Make the let-binding *) diff --git a/compiler/Values.ml b/compiler/Values.ml index d884c319..58737557 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -52,6 +52,8 @@ type sv_kind = (** The result of a loop join (when computing loop fixed points) *) | Aggregate (** A symbolic value we introduce in place of an aggregate value *) + | ConstGeneric + (** A symbolic value we introduce when using a const generic as a value *) [@@deriving show, ord] (** Ancestor for {!symbolic_value} iter visitor *) -- cgit v1.2.3 From a9c256fe95523842a1ff025e73f6e9ce7c2db38a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 18 Aug 2023 10:44:01 +0200 Subject: Add tests which use const generics as values --- compiler/PureMicroPasses.ml | 4 ++-- compiler/PureUtils.ml | 3 +++ 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'compiler') diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 65dc7ff2..b2f3bb9f 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -681,8 +681,8 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) | _ -> false in (* And either: - * 2.1 the right-expression is a variable or a global *) - let var_or_global = is_var re || is_global re in + * 2.1 the right-expression is a variable, a global or a const generic var *) + let var_or_global = is_var re || is_cvar re || is_global re in (* Or: * 2.2 the right-expression is a constant value, an ADT value, * a projection or a primitive function call *and* the flag diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 461098f2..f099ef9c 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -185,6 +185,9 @@ let is_var (e : texpression) : bool = let as_var (e : texpression) : VarId.id = match e.e with Var v -> v | _ -> raise (Failure "Unreachable") +let is_cvar (e : texpression) : bool = + match e.e with CVar _ -> true | _ -> false + let is_global (e : texpression) : bool = match e.e with Qualif { id = Global _; _ } -> true | _ -> false -- cgit v1.2.3 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/AssociatedTypes.ml | 91 +++++++ compiler/Assumed.ml | 188 ++++++--------- compiler/Contexts.ml | 24 ++ compiler/FunsAnalysis.ml | 15 +- compiler/Interpreter.ml | 96 +++----- compiler/InterpreterBorrowsCore.ml | 16 +- compiler/InterpreterExpansion.ml | 45 ++-- compiler/InterpreterExpressions.ml | 44 ++-- compiler/InterpreterLoopsJoinCtxs.ml | 9 + compiler/InterpreterLoopsMatchCtxs.ml | 19 +- compiler/InterpreterPaths.ml | 55 +++-- compiler/InterpreterPaths.mli | 7 +- compiler/InterpreterProjectors.ml | 15 +- compiler/InterpreterStatements.ml | 305 +++++++++++------------ compiler/InterpreterStatements.mli | 6 +- compiler/InterpreterUtils.ml | 2 +- compiler/Invariants.ml | 67 +++-- compiler/Logging.ml | 3 + compiler/PrePasses.ml | 4 +- compiler/Print.ml | 57 ++++- compiler/PrintPure.ml | 155 ++++++++++-- compiler/Pure.ml | 100 +++++++- compiler/PureTypeCheck.ml | 46 ++-- compiler/PureUtils.ml | 132 ++++++---- compiler/Substitute.ml | 443 ++++++++++++++++++++-------------- compiler/SymbolicAst.ml | 5 +- compiler/SymbolicToPure.ml | 23 +- compiler/SynthesizeSymbolic.ml | 34 +-- compiler/Translate.ml | 4 +- compiler/TypesAnalysis.ml | 23 +- compiler/dune | 1 + 31 files changed, 1258 insertions(+), 776 deletions(-) create mode 100644 compiler/AssociatedTypes.ml (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml new file mode 100644 index 00000000..4e5625cb --- /dev/null +++ b/compiler/AssociatedTypes.ml @@ -0,0 +1,91 @@ +(** This file implements utilities to handle trait associated types, in + particular with normalization helpers. + + When normalizing a type, we simplify the references to the trait associated + types, and choose a representative when there are equalities between types + enforced by local clauses (i.e., clauses of the shape [where Trait1::T = Trait2::U]). + *) + +module T = Types +module TU = TypesUtils +module V = Values +module E = Expressions +module A = LlbcAst +module C = Contexts +module Subst = Substitute +module L = Logging + +(** The local logger *) +let log = L.associated_types_log + +(** Normalize a type by simplyfying the references to trait associated types + and choosing a representative when there are equalities between types + enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. *) +let ctx_normalize_type (_ctx : C.eval_ctx) (_ty : 'r T.ty) : 'r T.ty = + raise (Failure "Unimplemented") + +(** Same as [type_decl_get_instantiated_variants_fields_rtypes] but normalizes the types *) +let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) + (def : T.type_decl) (generics : T.rgeneric_args) : + (T.VariantId.id option * T.rty list) list = + let res = + Subst.type_decl_get_instantiated_variants_fields_rtypes def generics + in + List.map + (fun (variant_id, types) -> + (variant_id, List.map (ctx_normalize_type ctx) types)) + res + +(** Same as [type_decl_get_instantiated_field_rtypes] but normalizes the types *) +let type_decl_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : + T.rty list = + let types = + Subst.type_decl_get_instantiated_field_rtypes def opt_variant_id generics + in + List.map (ctx_normalize_type ctx) types + +(** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) +let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) + (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : + T.rty list = + let types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id generics + in + List.map (ctx_normalize_type ctx) types + +(** Same as [ctx_adt_value_get_instantiated_field_etypes] but normalizes the types *) +let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : + T.ety list = + let types = + Subst.type_decl_get_instantiated_field_etypes def opt_variant_id generics + in + List.map (ctx_normalize_type ctx) types + +(** Same as [ctx_adt_get_instantiated_field_etypes] but normalizes the types *) +let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) + (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) + (generics : T.egeneric_args) : T.ety list = + let types = + Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + generics + in + List.map (ctx_normalize_type ctx) types + +(** Same as [substitute_signature] but normalizes the types *) +let ctx_subst_norm_signature (ctx : C.eval_ctx) + (asubst : T.RegionGroupId.id -> V.AbstractionId.id) + (r_subst : T.RegionVarId.id -> T.RegionId.id) + (ty_subst : T.TypeVarId.id -> T.rty) + (cg_subst : T.ConstGenericVarId.id -> T.const_generic) + (tr_subst : T.TraitClauseId.id -> T.rtrait_instance_id) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + let sg = + Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self + sg + in + let { A.regions_hierarchy; inputs; output } = sg in + let inputs = List.map (ctx_normalize_type ctx) inputs in + let output = ctx_normalize_type ctx output in + { regions_hierarchy; inputs; output } diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 25462504..e156c335 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -63,75 +63,81 @@ module Sig = struct let empty_const_generic_params : T.const_generic_var list = [] + let mk_generic_args regions types const_generics : T.sgeneric_args = + { regions; types; const_generics; trait_refs = [] } + + let mk_generic_params regions types const_generics : T.generic_params = + { regions; types; const_generics; trait_clauses = [] } + let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : T.sty = let ref_kind = if is_mut then T.Mut else T.Shared in mk_ref_ty r ty ref_kind let mk_array_ty (ty : T.sty) (cg : T.const_generic) : T.sty = - Adt (Assumed Array, [], [ ty ], [ cg ]) + Adt (Assumed Array, mk_generic_args [] [ ty ] [ cg ]) + + let mk_slice_ty (ty : T.sty) : T.sty = + Adt (Assumed Slice, mk_generic_args [] [ ty ] []) - let mk_slice_ty (ty : T.sty) : T.sty = Adt (Assumed Slice, [], [ ty ], []) - let range_ty : T.sty = Adt (Assumed Range, [], [ usize_ty ], []) + let range_ty : T.sty = Adt (Assumed Range, mk_generic_args [] [ usize_ty ] []) + + let mk_sig generics regions_hierarchy inputs output : A.fun_sig = + let preds : T.predicates = + { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } + in + { + generics; + preds; + parent_params_info = None; + regions_hierarchy; + inputs; + output; + } (** [fn(&'a mut T, T) -> T] *) let mem_replace_sig : A.fun_sig = (* The signature fields *) - let region_params = [ region_param_0 ] (* <'a> *) in + let regions = [ region_param_0 ] (* <'a> *) in let regions_hierarchy = [ region_group_0 ] (* [{<'a>}] *) in - let type_params = [ type_param_0 ] (* *) in + let types = [ type_param_0 ] (* *) in + let generics = mk_generic_params regions types [] in let inputs = [ mk_ref_ty rvar_0 tvar_0 true (* &'a mut T *); tvar_0 (* T *) ] in let output = tvar_0 (* T *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output (** [fn(T) -> Box] *) let box_new_sig : A.fun_sig = - { - region_params = []; - regions_hierarchy = []; - type_params = [ type_param_0 ] (* *); - const_generic_params = empty_const_generic_params; - inputs = [ tvar_0 (* T *) ]; - output = mk_box_ty tvar_0 (* Box *); - } + let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in + let regions_hierarchy = [] in + let inputs = [ tvar_0 (* T *) ] in + let output = mk_box_ty tvar_0 (* Box *) in + mk_sig generics regions_hierarchy inputs output (** [fn(Box) -> ()] *) let box_free_sig : A.fun_sig = - { - region_params = []; - regions_hierarchy = []; - type_params = [ type_param_0 ] (* *); - const_generic_params = empty_const_generic_params; - inputs = [ mk_box_ty tvar_0 (* Box *) ]; - output = mk_unit_ty (* () *); - } + let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in + let regions_hierarchy = [] in + let inputs = [ mk_box_ty tvar_0 (* Box *) ] in + let output = mk_unit_ty (* () *) in + mk_sig generics regions_hierarchy inputs output (** Helper for [Box::deref_shared] and [Box::deref_mut]. Returns: [fn<'a, T>(&'a (mut) Box) -> &'a (mut) T] *) let box_deref_gen_sig (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - { - region_params; - regions_hierarchy; - type_params = [ type_param_0 ] (* *); - const_generic_params = empty_const_generic_params; - inputs = - [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box *) ]; - output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *); - } + let inputs = + [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box *) ] + in + let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in + mk_sig generics regions_hierarchy inputs output (** [fn<'a, T>(&'a Box) -> &'a T] *) let box_deref_shared_sig = box_deref_gen_sig false @@ -141,26 +147,18 @@ module Sig = struct (** [fn() -> Vec] *) let vec_new_sig : A.fun_sig = - let region_params = [] in + let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in let regions_hierarchy = [] in - let type_params = [ type_param_0 ] (* *) in let inputs = [] in let output = mk_vec_ty tvar_0 (* Vec *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output (** [fn(&'a mut Vec, T)] *) let vec_push_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in let inputs = [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); @@ -168,21 +166,14 @@ module Sig = struct ] in let output = mk_unit_ty (* () *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output (** [fn(&'a mut Vec, usize, T)] *) let vec_insert_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in let inputs = [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); @@ -191,42 +182,28 @@ module Sig = struct ] in let output = mk_unit_ty (* () *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output (** [fn(&'a Vec) -> usize] *) let vec_len_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in let inputs = [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec *) ] in let output = mk_usize_ty (* usize *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output (** Helper: [fn(&'a (mut) Vec, usize) -> &'a (mut) T] *) let vec_index_gen_sig (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in let inputs = [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec *); @@ -234,14 +211,7 @@ module Sig = struct ] in let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output (** [fn(&'a Vec, usize) -> &'a T] *) let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false @@ -266,10 +236,10 @@ module Sig = struct let mk_array_slice_borrow_sig (cgs : T.const_generic_var list) (input_ty : T.TypeVarId.id -> T.sty) (index_ty : T.sty option) (output_ty : T.TypeVarId.id -> T.sty) (is_mut : bool) : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in let inputs = [ mk_ref_ty rvar_0 @@ -285,14 +255,7 @@ module Sig = struct (output_ty type_param_0.index) is_mut (* &'a (mut) output_ty *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = cgs; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : A.fun_sig = (* Array *) @@ -342,22 +305,15 @@ module Sig = struct [fn(&'a [T]) -> usize] *) let slice_len_sig : A.fun_sig = - (* The signature fields *) - let region_params = [ region_param_0 ] in + let generics = + mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) + in let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let type_params = [ type_param_0 ] (* *) in let inputs = [ mk_ref_ty rvar_0 (mk_slice_ty tvar_0) false (* &'a [T] *) ] in let output = mk_usize_ty (* usize *) in - { - region_params; - regions_hierarchy; - type_params; - const_generic_params = empty_const_generic_params; - inputs; - output; - } + mk_sig generics regions_hierarchy inputs output end type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 14b5d559..2d396924 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -255,11 +255,28 @@ type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] type global_context = { global_decls : global_decl GlobalDeclId.Map.t } [@@deriving show] +type trait_decls_context = { trait_decls : trait_decl TraitDeclId.Map.t } +[@@deriving show] + +type trait_impls_context = { trait_impls : trait_impl TraitImplId.Map.t } +[@@deriving show] + +type decls_ctx = { + type_ctx : type_context; + fun_ctx : fun_context; + global_ctx : global_context; + trait_decls_ctx : trait_decls_context; + trait_impls_ctx : trait_impls_context; +} +[@@deriving show] + (** Evaluation context *) type eval_ctx = { type_context : type_context; fun_context : fun_context; global_context : global_context; + trait_decls_context : trait_decls_context; + trait_impls_context : trait_impls_context; region_groups : RegionGroupId.id list; type_vars : type_var list; const_generic_vars : const_generic_var list; @@ -267,6 +284,7 @@ type eval_ctx = { (** The map from const generic vars to their values. Those values can be symbolic values or concrete values (in the latter case: if we run in interpreter mode) *) + trait_clauses : etrait_ref list; env : env; ended_regions : RegionId.Set.t; } @@ -308,6 +326,12 @@ let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : global_decl = GlobalDeclId.Map.find gid ctx.global_context.global_decls +let ctx_lookup_trait_decl (ctx : eval_ctx) (id : TraitDeclId.id) : trait_decl = + TraitDeclId.Map.find id ctx.trait_decls_context.trait_decls + +let ctx_lookup_trait_impl (ctx : eval_ctx) (id : TraitImplId.id) : trait_impl = + TraitImplId.Map.find id ctx.trait_impls_context.trait_impls + (** Retrieve a variable's value in the current frame *) let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = snd (env_lookup_var env vid) diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index b72fa078..f4406653 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -70,14 +70,14 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_rvalue _env rv = match rv with - | Use _ | Ref _ | Global _ | Discriminant _ | Aggregate _ -> () + | Use _ | RvRef _ | Global _ | Discriminant _ | Aggregate _ -> () | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail | BinaryOp (bop, _, _) -> can_fail := EU.binop_can_fail bop || !can_fail method! visit_Call env call = (match call.func with - | Regular id -> + | FunId (Regular id) -> if FunDeclId.Set.mem id fun_ids then ( can_diverge := true; is_rec := true) @@ -86,9 +86,13 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) self#may_fail info.can_fail; stateful := !stateful || info.stateful; can_diverge := !can_diverge || info.can_diverge - | Assumed id -> + | FunId (Assumed id) -> (* None of the assumed functions can diverge nor are considered stateful *) - can_fail := !can_fail || Assumed.assumed_can_fail id); + can_fail := !can_fail || Assumed.assumed_can_fail id + | TraitMethod _ -> + (* We consider trait functions can fail, diverge, and are not stateful *) + can_fail := true; + can_diverge := true); super#visit_Call env call method! visit_Panic env = @@ -141,7 +145,8 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let rec analyze_decl_groups (decls : declaration_group list) : unit = match decls with | [] -> () - | Type _ :: decls' -> analyze_decl_groups decls' + | (Type _ | TraitDecl _ | TraitImpl _) :: decls' -> + analyze_decl_groups decls' | Fun decl :: decls' -> analyze_fun_decl_group decl; analyze_decl_groups decls' diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 37eeb333..eb66013d 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -12,27 +12,30 @@ module SA = SymbolicAst (** The local logger *) let log = L.interpreter_log -let compute_type_fun_global_contexts (m : A.crate) : - C.type_context * C.fun_context * C.global_context = - let type_decls_list, _, _ = split_declarations m.declarations in +let compute_contexts (m : A.crate) : C.decls_ctx = + let type_decls_list, _, _, _, _ = split_declarations m.declarations in let type_decls = m.types in let fun_decls = m.functions in let global_decls = m.globals in - let type_decls_groups, _funs_defs_groups, _globals_defs_groups = + let trait_decls = m.trait_decls in + let trait_impls = m.trait_impls in + let type_decls_groups, _, _, _, _ = split_declarations_to_group_maps m.declarations in let type_infos = TypesAnalysis.analyze_type_declarations type_decls type_decls_list in - let type_context = { C.type_decls_groups; type_decls; type_infos } in - let fun_context = { C.fun_decls } in - let global_context = { C.global_decls } in - (type_context, fun_context, global_context) - -let initialize_eval_context (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) + let type_ctx = { C.type_decls_groups; type_decls; type_infos } in + let fun_ctx = { C.fun_decls } in + let global_ctx = { C.global_decls } in + let trait_decls_ctx = { C.trait_decls } in + let trait_impls_ctx = { C.trait_impls } in + { C.type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } + +let initialize_eval_context (ctx : C.decls_ctx) (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) - (const_generic_vars : T.const_generic_var list) : C.eval_ctx = + (const_generic_vars : T.const_generic_var list) + (trait_clauses : T.etrait_ref list) : C.eval_ctx = C.reset_global_counters (); let const_generic_vars_map = T.ConstGenericVarId.Map.of_list @@ -44,33 +47,35 @@ let initialize_eval_context (type_context : C.type_context) const_generic_vars) in { - C.type_context; - C.fun_context; - C.global_context; + C.type_context = ctx.type_ctx; + C.fun_context = ctx.fun_ctx; + C.global_context = ctx.global_ctx; + C.trait_decls_context = ctx.trait_decls_ctx; + C.trait_impls_context = ctx.trait_impls_ctx; C.region_groups; C.type_vars; C.const_generic_vars; C.const_generic_vars_map; + C.trait_clauses; C.env = [ C.Frame ]; C.ended_regions = T.RegionId.Set.empty; } (** Initialize an evaluation context to execute a function. - Introduces local variables initialized in the following manner: - - input arguments are initialized as symbolic values - - the remaining locals are initialized as [⊥] - Abstractions are introduced for the regions present in the function - signature. - - We return: - - the initialized evaluation context - - the list of symbolic values introduced for the input values - - the instantiated function signature + Introduces local variables initialized in the following manner: + - input arguments are initialized as symbolic values + - the remaining locals are initialized as [⊥] + Abstractions are introduced for the regions present in the function + signature. + + We return: + - the initialized evaluation context + - the list of symbolic values introduced for the input values + - the instantiated function signature *) -let initialize_symbolic_context_for_fun (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = +let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) + : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us * with the input values (which behave as if they had been returned @@ -88,8 +93,8 @@ let initialize_symbolic_context_for_fun (type_context : C.type_context) List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy in let ctx = - initialize_eval_context type_context fun_context global_context - region_groups sg.type_params sg.const_generic_params + initialize_eval_context ctx region_groups sg.generics.types + sg.generics.const_generics sg.generics.trait_clauses in (* Instantiate the signature *) let type_params = @@ -508,17 +513,12 @@ module Test = struct (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); (* Sanity check - *) - assert (List.length fdef.A.signature.region_params = 0); - assert (List.length fdef.A.signature.type_params = 0); + assert (fdef.A.signature.generics = TypesUtils.mk_empty_generic_params); assert (body.A.arg_count = 0); (* Create the evaluation context *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in - let ctx = - initialize_eval_context type_context fun_context global_context [] [] [] - in + let decls_ctx = compute_contexts crate in + let ctx = initialize_eval_context decls_ctx [] [] [] [] in (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in @@ -546,9 +546,7 @@ module Test = struct (no parameters, no arguments) - TODO: move *) let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = Option.is_some def.body - && def.A.signature.region_params = [] - && def.A.signature.type_params = [] - && def.A.signature.const_generic_params = [] + && def.A.signature.generics = TypesUtils.mk_empty_generic_params && def.A.signature.inputs = [] (** Test all the unit functions in a list of function definitions *) @@ -562,20 +560,4 @@ module Test = struct test_unit_function crate def.A.def_id in A.FunDeclId.Map.iter test_unit_fun unit_funs - - (** Execute the symbolic interpreter on a function. *) - let test_function_symbolic (synthesize : bool) (type_context : C.type_context) - (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : unit = - (* Debug *) - log#ldebug - (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); - - (* Evaluate *) - let _ = - evaluate_function_symbolic synthesize type_context fun_context - global_context fdef - in - - () end diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index bf083aa4..e7da045c 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -100,15 +100,18 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) (ty1 : T.rty) (ty2 : T.rty) : bool = let compare = compare_rtys default combine compare_regions in + (* Normalize the associated types *) match (ty1, ty2) with | T.Literal lit1, T.Literal lit2 -> assert (lit1 = lit2); default - | T.Adt (id1, regions1, tys1, cgs1), T.Adt (id2, regions2, tys2, cgs2) -> + | T.Adt (id1, generics1), T.Adt (id2, generics2) -> assert (id1 = id2); (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) - assert (cgs1 = cgs2); + assert (generics1.const_generics = generics2.const_generics); + + (* We also ignore the trait refs *) (* The check for the ADTs is very crude: we simply compare the arguments * two by two. @@ -123,14 +126,14 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) * this check would still be a reasonable conservative approximation. *) (* Check the region parameters *) - let regions = List.combine regions1 regions2 in + let regions = List.combine generics1.regions generics2.regions in let params_b = List.fold_left (fun b (r1, r2) -> combine b (compare_regions r1 r2)) default regions in (* Check the type parameters *) - let tys = List.combine tys1 tys2 in + let tys = List.combine generics1.types generics2.types in let tys_b = List.fold_left (fun b (ty1, ty2) -> combine b (compare ty1 ty2)) @@ -150,6 +153,11 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) | T.TypeVar id1, T.TypeVar id2 -> assert (id1 = id2); default + | T.TraitType _, T.TraitType _ -> + (* The types should have been normalized. If after normalization we + get trait types, we can consider them as variables *) + assert (ty1 = ty2); + default | _ -> log#lerror (lazy diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 81e73e3e..ea692386 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -9,6 +9,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open TypesUtils module Inv = Invariants @@ -204,7 +205,7 @@ let apply_symbolic_expansion_non_borrow (config : C.config) apply_symbolic_expansion_to_avalues config allow_reborrows original_sv expansion ctx -(** Compute the expansion of a non-assumed (i.e.: not [Option], [Box], etc.) +(** Compute the expansion of a non-assumed (i.e.: not [Box], etc.) adt value. The function might return a list of values if the symbolic value to expand @@ -214,18 +215,15 @@ let apply_symbolic_expansion_non_borrow (config : C.config) doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) (ctx : C.eval_ctx) : V.symbolic_expansion list - = + (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.rgeneric_args) + (ctx : C.eval_ctx) : V.symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = C.ctx_lookup_type_decl ctx def_id in - assert (List.length regions = List.length def.T.region_params); + assert (List.length generics.regions = List.length def.T.generics.regions); (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = - Subst.type_decl_get_instantiated_variants_fields_rtypes def regions types - cgs + Assoc.type_decl_get_inst_norm_variants_fields_rtypes ctx def generics in (* Check if there is strictly more than one variant *) if List.length variants_fields_types > 1 && not expand_enumerations then @@ -280,15 +278,14 @@ let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (adt_id : T.type_id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) (ctx : C.eval_ctx) : V.symbolic_expansion list - = - match (adt_id, regions, types) with + (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.rgeneric_args) + (ctx : C.eval_ctx) : V.symbolic_expansion list = + match (adt_id, generics.regions, generics.types) with | T.AdtId def_id, _, _ -> compute_expanded_symbolic_non_assumed_adt_value expand_enumerations kind - def_id regions types cgs ctx - | T.Tuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind types ] + def_id generics ctx + | T.Tuple, [], _ -> + [ compute_expanded_symbolic_tuple_value kind generics.types ] | T.Assumed T.Option, [], [ ty ] -> compute_expanded_symbolic_option_value expand_enumerations kind ty | T.Assumed T.Box, [], [ boxed_ty ] -> @@ -543,12 +540,12 @@ let expand_symbolic_value_no_branching (config : C.config) fun cf ctx -> match rty with (* ADTs *) - | T.Adt (adt_id, regions, types, cgs) -> + | T.Adt (adt_id, generics) -> (* Compute the expanded value *) let allow_branching = false in let seel = compute_expanded_symbolic_adt_value allow_branching sv.sv_kind adt_id - regions types cgs ctx + generics ctx in (* There should be exacly one branch *) let see = Collections.List.to_cons_nil seel in @@ -600,12 +597,12 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) (* Execute *) match rty with (* ADTs *) - | T.Adt (adt_id, regions, types, cgs) -> + | T.Adt (adt_id, generics) -> let allow_branching = true in (* Compute the expanded value *) let seel = compute_expanded_symbolic_adt_value allow_branching sv.sv_kind adt_id - regions types cgs ctx + generics ctx in (* Apply *) let seel = List.map (fun see -> (Some see, cf_branches)) seel in @@ -679,7 +676,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ^ symbolic_value_to_string ctx sv)); let cc : cm_fun = match sv.V.sv_ty with - | T.Adt (AdtId def_id, _, _, _) -> + | T.Adt (AdtId def_id, _) -> (* {!expand_symbolic_value_no_branching} checks if there are branchings, * but we prefer to also check it here - this leads to cleaner messages * and debugging *) @@ -704,16 +701,16 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = [config]): " ^ Print.name_to_string def.name)) else expand_symbolic_value_no_branching config sv None - | T.Adt ((Tuple | Assumed Box), _, _, _) | T.Ref (_, _, _) -> + | T.Adt ((Tuple | Assumed Box), _) | T.Ref (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Vec | Option | Array | Slice | Str | Range), _, _, _) - -> + | T.Adt (Assumed (Vec | Option | Array | Slice | Str | Range), _) -> (* We can't expand those *) raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TypeVar _ | T.Literal _ | Never -> raise (Failure "Unreachable") + | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ -> + raise (Failure "Unreachable") in (* Compose and continue *) comp cc expand cf ctx diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 2f6a7b49..51f6ff05 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -7,6 +7,7 @@ module E = Expressions open Utils module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open TypesUtils open ValuesUtils @@ -141,11 +142,18 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) | V.Adt av -> (* Sanity check *) (match v.V.ty with - | T.Adt (T.Assumed (T.Box | Vec), _, _, _) -> + | T.Adt (T.Assumed (T.Box | Vec), _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.Adt (T.AdtId _, _, _, _) -> assert allow_adt_copy - | T.Adt ((T.Assumed Option | T.Tuple), _, _, _) -> () (* Ok *) - | T.Adt (T.Assumed (Slice | T.Array), [], [ ty ], []) -> + | T.Adt (T.AdtId _, _) -> assert allow_adt_copy + | T.Adt ((T.Assumed Option | T.Tuple), _) -> () (* Ok *) + | T.Adt + ( T.Assumed (Slice | T.Array), + { + regions = []; + types = [ ty ]; + const_generics = []; + trait_refs = []; + } ) -> assert (ty_is_primitively_copyable ty) | _ -> raise (Failure "Unreachable")); let ctx, fields = @@ -263,6 +271,9 @@ 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) -> + (* TODO *) + raise (Failure "Unimplemented") | E.CVar vid -> ( let ctx0 = ctx in (* Lookup the const generic value *) @@ -681,7 +692,8 @@ let eval_rvalue_aggregate (config : C.config) | E.AggregatedTuple -> let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in let v = V.Adt { variant_id = None; field_values = values } in - let ty = T.Adt (T.Tuple, [], tys, []) in + let generics = TypesUtils.mk_generic_args [] tys [] [] in + let ty = T.Adt (T.Tuple, generics) in let aggregated : V.typed_value = { V.value = v; ty } in (* Call the continuation *) cf aggregated ctx @@ -692,20 +704,22 @@ let eval_rvalue_aggregate (config : C.config) assert (List.length values = 1) else raise (Failure "Unreachable"); (* Construt the value *) - let aty = T.Adt (T.Assumed T.Option, [], [ ty ], []) in + let generics = TypesUtils.mk_generic_args [] [ ty ] [] [] in + let aty = T.Adt (T.Assumed T.Option, generics) in let av : V.adt_value = { V.variant_id = Some variant_id; V.field_values = values } in let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in (* Call the continuation *) cf aggregated ctx - | E.AggregatedAdt (def_id, opt_variant_id, regions, types, cgs) -> + | E.AggregatedAdt (def_id, opt_variant_id, generics) -> (* Sanity checks *) let type_decl = C.ctx_lookup_type_decl ctx def_id in - assert (List.length type_decl.region_params = List.length regions); + assert ( + List.length type_decl.generics.regions = List.length generics.regions); let expected_field_types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id - types cgs + Assoc.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id + generics in assert ( expected_field_types @@ -714,7 +728,7 @@ let eval_rvalue_aggregate (config : C.config) let av : V.adt_value = { V.variant_id = opt_variant_id; V.field_values = values } in - let aty = T.Adt (T.AdtId def_id, regions, types, cgs) in + let aty = T.Adt (T.AdtId def_id, generics) in let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in (* Call the continuation *) cf aggregated ctx @@ -734,7 +748,8 @@ let eval_rvalue_aggregate (config : C.config) let av : V.adt_value = { V.variant_id = None; V.field_values = values } in - let aty = T.Adt (T.Assumed T.Range, [], [ ety ], []) in + let generics = TypesUtils.mk_generic_args_from_types [ ety ] in + let aty = T.Adt (T.Assumed T.Range, generics) in let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in (* Call the continuation *) cf aggregated ctx @@ -744,7 +759,8 @@ let eval_rvalue_aggregate (config : C.config) (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in assert (len = Z.of_int (List.length values)); - let ty = T.Adt (T.Assumed T.Array, [], [ ety ], [ cg ]) in + let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in + let ty = T.Adt (T.Assumed T.Array, generics) in (* In order to generate a better AST, we introduce a symbolic value equal to the array. The reason is that otherwise, the array we introduce here might be duplicated in the generated @@ -777,7 +793,7 @@ let eval_rvalue_not_global (config : C.config) (rvalue : E.rvalue) (* Delegate to the proper auxiliary function *) match rvalue with | E.Use op -> comp_wrap (eval_operand config op) ctx - | E.Ref (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx + | E.RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx | E.Aggregate (aggregate_kind, ops) -> diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 10205c27..a34a7d06 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -554,10 +554,13 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) C.type_context; fun_context; global_context; + trait_decls_context; + trait_impls_context; region_groups; type_vars; const_generic_vars; const_generic_vars_map; + trait_clauses; env = _; ended_regions = ended_regions0; } = @@ -567,10 +570,13 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) C.type_context = _; fun_context = _; global_context = _; + trait_decls_context = _; + trait_impls_context = _; region_groups = _; type_vars = _; const_generic_vars = _; const_generic_vars_map = _; + trait_clauses = _; env = _; ended_regions = ended_regions1; } = @@ -582,10 +588,13 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) C.type_context; fun_context; global_context; + trait_decls_context; + trait_impls_context; region_groups; type_vars; const_generic_vars; const_generic_vars_map; + trait_clauses; env; ended_regions; } diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 9248e513..8cab546e 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -149,20 +149,25 @@ let rec match_types (match_distinct_types : 'r T.ty -> 'r T.ty -> 'r T.ty) (match_regions : 'r -> 'r -> 'r) (ty0 : 'r T.ty) (ty1 : 'r T.ty) : 'r T.ty = let match_rec = match_types match_distinct_types match_regions in match (ty0, ty1) with - | Adt (id0, regions0, tys0, cgs0), Adt (id1, regions1, tys1, cgs1) -> + | Adt (id0, generics0), Adt (id1, generics1) -> assert (id0 = id1); - assert (cgs0 = cgs1); + assert (generics0.const_generics = generics1.const_generics); + assert (generics0.trait_refs = generics1.trait_refs); let id = id0 in - let cgs = cgs1 in + let const_generics = generics1.const_generics in + let trait_refs = generics1.trait_refs in let regions = List.map (fun (id0, id1) -> match_regions id0 id1) - (List.combine regions0 regions1) + (List.combine generics0.regions generics1.regions) in - let tys = - List.map (fun (ty0, ty1) -> match_rec ty0 ty1) (List.combine tys0 tys1) + let types = + List.map + (fun (ty0, ty1) -> match_rec ty0 ty1) + (List.combine generics0.types generics1.types) in - Adt (id, regions, tys, cgs) + let generics = { T.regions; types; const_generics; trait_refs } in + Adt (id, generics) | TypeVar vid0, TypeVar vid1 -> assert (vid0 = vid1); let vid = vid0 in diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 04dc8892..465d0028 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -3,6 +3,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open Cps open ValuesUtils @@ -97,7 +98,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) match (pe, v.V.value, v.V.ty) with | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), V.Adt adt, - T.Adt (type_id, _, _, _) ) -> ( + T.Adt (type_id, _) ) -> ( (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> @@ -119,8 +120,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _, _) - -> ( + | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _) -> ( assert (arity = List.length adt.field_values); let fv = T.FieldId.nth adt.field_values field_id in (* Project *) @@ -145,9 +145,9 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) (* Box dereferencement *) | ( DerefBox, Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _, _, _) ) -> ( - (* We allow moving inside of boxes. In practice, this kind of - * manipulations should happen only inside unsage code, so + T.Adt (T.Assumed T.Box, _) ) -> ( + (* We allow moving outside of boxes. In practice, this kind of + * manipulations should happen only inside unsafe code, so * it shouldn't happen due to user code, and we leverage it * when implementing box dereferencement for the concrete * interpreter *) @@ -357,24 +357,23 @@ let write_place (access : access_kind) (p : E.place) (nv : V.typed_value) | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (tyctx : T.type_decl T.TypeDeclId.Map.t) +let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.erased_region list) (types : T.ety list) - (cgs : T.const_generic list) : V.typed_value = + (generics : T.egeneric_args) : V.typed_value = (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) - let def = T.TypeDeclId.Map.find def_id tyctx in - assert (List.length regions = List.length def.T.region_params); + let def = C.ctx_lookup_type_decl ctx def_id in + assert (List.length generics.regions = List.length def.T.generics.regions); (* Compute the field types *) let field_types = - Subst.type_decl_get_instantiated_field_etypes def opt_variant_id types cgs + Assoc.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id generics in (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, regions, types, cgs) in + let ty = T.Adt (T.AdtId def_id, generics) in { V.value = av; V.ty } let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) @@ -387,7 +386,8 @@ let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) else raise (Failure "Unreachable") in let av = V.Adt { variant_id = Some variant_id; field_values } in - let ty = T.Adt (T.Assumed T.Option, [], [ param_ty ], []) in + let generics = TypesUtils.mk_generic_args [] [ param_ty ] [] [] in + let ty = T.Adt (T.Assumed T.Option, generics) in { V.value = av; ty } let compute_expanded_bottom_tuple_value (field_types : T.ety list) : @@ -395,7 +395,8 @@ let compute_expanded_bottom_tuple_value (field_types : T.ety list) : (* Generate the field values *) let fields = List.map mk_bottom field_types in let v = V.Adt { variant_id = None; field_values = fields } in - let ty = T.Adt (T.Tuple, [], field_types, []) in + let generics = TypesUtils.mk_generic_args [] field_types [] [] in + let ty = T.Adt (T.Tuple, generics) in { V.value = v; V.ty } (** Auxiliary helper to expand {!V.Bottom} values. @@ -447,19 +448,29 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) match (pe, ty) with (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', regions, types, cgs) ) -> + T.Adt (T.AdtId def_id', generics) ) -> assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx.type_context.type_decls def_id - opt_variant_id regions types cgs + compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics (* Option *) | ( Field (ProjOption variant_id, _), - T.Adt (T.Assumed T.Option, [], [ ty ], []) ) -> + T.Adt + ( T.Assumed T.Option, + { + T.regions = []; + types = [ ty ]; + const_generics = []; + trait_refs = []; + } ) ) -> compute_expanded_bottom_option_value variant_id ty (* Tuples *) - | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys, []) -> - assert (arity = List.length tys); + | ( Field (ProjTuple arity, _), + T.Adt + ( T.Tuple, + { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) + -> + assert (arity = List.length types); (* Generate the field values *) - compute_expanded_bottom_tuple_value tys + compute_expanded_bottom_tuple_value types | _ -> raise (Failure diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index 4a9f3b41..041b0a97 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -3,6 +3,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open Cps open InterpreterExpansion @@ -56,12 +57,10 @@ val compute_expanded_bottom_tuple_value : T.ety list -> V.typed_value (** Compute an expanded ADT ⊥ value *) val compute_expanded_bottom_adt_value : - T.type_decl T.TypeDeclId.Map.t -> + C.eval_ctx -> T.TypeDeclId.id -> T.VariantId.id option -> - T.erased_region list -> - T.ety list -> - T.const_generic list -> + T.egeneric_args -> V.typed_value (** Compute an expanded [Option] ⊥ value *) diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index faed066b..9e0c2b75 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -3,6 +3,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module L = Logging open TypesUtils open InterpreterUtils @@ -24,12 +25,12 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) else match (v.V.value, ty) with | V.Literal _, T.Literal _ -> [] - | V.Adt adt, T.Adt (id, region_params, tys, cgs) -> + | V.Adt adt, T.Adt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys cgs + Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics in + (* Project over the field values *) let fields_types = List.combine adt.V.field_values field_types in let proj_fields = @@ -103,11 +104,10 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) let value : V.avalue = match (v.V.value, ty) with | V.Literal _, T.Literal _ -> V.AIgnored - | V.Adt adt, T.Adt (id, region_params, tys, cgs) -> + | V.Adt adt, T.Adt (id, generics) -> (* Retrieve the types of the fields *) let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys cgs + Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics in (* Project over the field values *) let fields_types = List.combine adt.V.field_values field_types in @@ -268,8 +268,7 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) let (value, ty) : V.avalue * T.rty = match (see, original_sv_ty) with | SeLiteral _, T.Literal _ -> (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys, _cgs) - -> + | SeAdt (variant_id, field_values), T.Adt (_id, _generics) -> (* Project over the field values *) let field_values = List.map diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 6d520059..d38f8b95 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -17,6 +17,7 @@ open InterpreterProjectors open InterpreterExpansion open InterpreterPaths open InterpreterExpressions +module PCtx = Print.EvalCtxLlbcAst (** The local logger *) let log = L.statements_log @@ -232,9 +233,8 @@ let set_discriminant (config : C.config) (p : E.place) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> match (v.V.ty, v.V.value) with - | ( T.Adt - (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types, cgs), - V.Adt av ) -> ( + | T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), generics), V.Adt av + -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -251,28 +251,26 @@ let set_discriminant (config : C.config) (p : E.place) let bottom_v = match type_id with | T.AdtId def_id -> - compute_expanded_bottom_adt_value - ctx.type_context.type_decls def_id (Some variant_id) - regions types cgs + compute_expanded_bottom_adt_value ctx def_id + (Some variant_id) generics | T.Assumed T.Option -> - assert (regions = []); + assert (generics.regions = []); compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) + (Collections.List.to_cons_nil generics.types) | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | ( T.Adt - (((T.AdtId _ | T.Assumed T.Option) as type_id), regions, types, cgs), - V.Bottom ) -> + | T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), generics), V.Bottom + -> let bottom_v = match type_id with | T.AdtId def_id -> - compute_expanded_bottom_adt_value ctx.type_context.type_decls - def_id (Some variant_id) regions types cgs + compute_expanded_bottom_adt_value ctx def_id (Some variant_id) + generics | T.Assumed T.Option -> - assert (regions = []); + assert (generics.regions = []); compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil types) + (Collections.List.to_cons_nil generics.types) | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx @@ -301,24 +299,34 @@ let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) (** Small helper: compute the type of the return value for a specific - instantiation of a non-local function. + instantiation of an assumed function. *) -let get_non_local_function_return_type (fid : A.assumed_fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) - (const_generic_params : T.const_generic list) : T.ety = +let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) + (generics : T.egeneric_args) : T.ety = + assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) - match (fid, region_params, type_params, const_generic_params) with - | A.BoxFree, [], [ _ ], [] -> mk_unit_ty + match fid with + | A.BoxFree -> + assert (generics.regions = []); + assert (List.length generics.types = 1); + assert (generics.const_generics = []); + mk_unit_ty | _ -> (* Retrieve the function's signature *) let sg = Assumed.get_assumed_sig fid in (* Instantiate the return type *) - let tsubst = Subst.make_type_subst_from_vars sg.type_params type_params in - let cgsubst = - Subst.make_const_generic_subst_from_vars sg.const_generic_params - const_generic_params + (* There shouldn't be any reference to Self *) + let tr_self : T.erased_region T.trait_instance_id = + T.UnknownTrait __FUNCTION__ + in + let { Subst.r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = + Subst.make_esubst_from_generics sg.generics generics tr_self in - Subst.erase_regions_substitute_types tsubst cgsubst sg.output + let ty = + Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self + sg.output + in + Assoc.ctx_normalize_type ctx ty let move_return_value (config : C.config) (pop_return_value : bool) (cf : V.typed_value option -> m_fun) : m_fun = @@ -418,19 +426,19 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = in comp cf_pop cf_assign -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_replace_concrete (_config : C.config) - (_region_params : T.erased_region list) (_type_params : T.ety list) - (_cg_args : T.const_generic list) : cm_fun = +(** Auxiliary function - see {!eval_assumed_function_call} *) +let eval_replace_concrete (_config : C.config) (_generics : T.egeneric_args) : + cm_fun = fun _cf _ctx -> raise Unimplemented -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_box_new_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_args : T.const_generic list) : cm_fun = +(** Auxiliary function - see {!eval_assumed_function_call} *) +let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : + cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) - match (region_params, type_params, cg_args, ctx.env) with + match + (generics.regions, generics.types, generics.const_generics, ctx.env) + with | ( [], [ boxed_ty ], [], @@ -448,7 +456,8 @@ let eval_box_new_concrete (config : C.config) (* Create the new box *) let cf_create cf (moved_input_value : V.typed_value) : m_fun = (* Create the box value *) - let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ], []) in + let generics = TypesUtils.mk_generic_args_from_types [ boxed_ty ] in + let box_ty = T.Adt (T.Assumed T.Box, generics) in let box_v = V.Adt { variant_id = None; field_values = [ moved_input_value ] } in @@ -467,13 +476,14 @@ let eval_box_new_concrete (config : C.config) | _ -> raise (Failure "Inconsistent state") (** Auxiliary function which factorizes code to evaluate [std::Deref::deref] - and [std::DerefMut::deref_mut] - see {!eval_non_local_function_call} *) + and [std::DerefMut::deref_mut] - see {!eval_assumed_function_call} *) let eval_box_deref_mut_or_shared_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_args : T.const_generic list) (is_mut : bool) : cm_fun = + (generics : T.egeneric_args) (is_mut : bool) : cm_fun = fun cf ctx -> (* Check the arguments *) - match (region_params, type_params, cg_args, ctx.env) with + match + (generics.regions, generics.types, generics.const_generics, ctx.env) + with | ( [], [ boxed_ty ], [], @@ -495,7 +505,7 @@ let eval_box_deref_mut_or_shared_concrete (config : C.config) { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } in let borrow_kind = if is_mut then E.Mut else E.Shared in - let rv = E.Ref (p, borrow_kind) in + let rv = E.RvRef (p, borrow_kind) in let cf_borrow = eval_rvalue_not_global config rv in (* Move the borrow to its destination *) @@ -514,23 +524,19 @@ let eval_box_deref_mut_or_shared_concrete (config : C.config) comp cf_borrow cf_move cf ctx | _ -> raise (Failure "Inconsistent state") -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_box_deref_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_args : T.const_generic list) : cm_fun = +(** Auxiliary function - see {!eval_assumed_function_call} *) +let eval_box_deref_concrete (config : C.config) (generics : T.egeneric_args) : + cm_fun = let is_mut = false in - eval_box_deref_mut_or_shared_concrete config region_params type_params cg_args - is_mut + eval_box_deref_mut_or_shared_concrete config generics is_mut -(** Auxiliary function - see {!eval_non_local_function_call} *) -let eval_box_deref_mut_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (cg_args : T.const_generic list) : cm_fun = +(** Auxiliary function - see {!eval_assumed_function_call} *) +let eval_box_deref_mut_concrete (config : C.config) (generics : T.egeneric_args) + : cm_fun = let is_mut = true in - eval_box_deref_mut_or_shared_concrete config region_params type_params cg_args - is_mut + eval_box_deref_mut_or_shared_concrete config generics is_mut -(** Auxiliary function - see {!eval_non_local_function_call}. +(** Auxiliary function - see {!eval_assumed_function_call}. [Box::free] is not handled the same way as the other assumed functions: - in the regular case, whenever we need to evaluate an assumed function, @@ -549,11 +555,10 @@ let eval_box_deref_mut_concrete (config : C.config) It thus updates the box value (by calling {!drop_value}) and updates the destination (by setting it to [()]). *) -let eval_box_free (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (cg_args : T.const_generic list) +let eval_box_free (config : C.config) (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : cm_fun = fun cf ctx -> - match (region_params, type_params, cg_args, args) with + match (generics.regions, generics.types, generics.const_generics, args) with | [], [ boxed_ty ], [], [ E.Move input_box_place ] -> (* Required type checking *) let input_box = InterpreterPaths.read_place Write input_box_place ctx in @@ -570,20 +575,18 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) cc cf ctx | _ -> raise (Failure "Inconsistent state") -(** Auxiliary function - see {!eval_non_local_function_call} *) +(** Auxiliary function - see {!eval_assumed_function_call} *) let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) - (_region_params : T.erased_region list) (_type_params : T.ety list) - (_cg_args : T.const_generic list) : cm_fun = + (_generics : T.egeneric_args) : cm_fun = fun _cf _ctx -> raise Unimplemented (** Evaluate a non-local function call in concrete mode *) -let eval_non_local_function_call_concrete (config : C.config) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (cg_args : T.const_generic list) +let eval_assumed_function_call_concrete (config : C.config) + (fid : A.assumed_fun_id) (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : cm_fun = (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - assert (cg_args = []); + assert (generics.const_generics = []); (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -592,7 +595,7 @@ let eval_non_local_function_call_concrete (config : C.config) match fid with | A.BoxFree -> (* Degenerate case: box_free *) - eval_box_free config region_params type_params cg_args args dest + eval_box_free config generics args dest | _ -> (* "Normal" case: not box_free *) (* Evaluate the operands *) @@ -607,16 +610,14 @@ let eval_non_local_function_call_concrete (config : C.config) * but it made it less clear where the computed values came from, * so we reversed the modifications. *) let cf_eval_call cf (args_vl : V.typed_value list) : m_fun = + fun ctx -> (* Push the stack frame: we initialize the frame with the return variable, and one variable per input argument *) let cc = push_frame in (* Create and push the return variable *) let ret_vid = E.VarId.zero in - let ret_ty = - get_non_local_function_return_type fid region_params type_params - cg_args - in + let ret_ty = get_assumed_function_return_type ctx fid generics in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var ret_var) in @@ -633,20 +634,14 @@ let eval_non_local_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 region_params type_params cg_args - | BoxNew -> - eval_box_new_concrete config region_params type_params cg_args - | BoxDeref -> - eval_box_deref_concrete config region_params type_params cg_args - | BoxDerefMut -> - eval_box_deref_mut_concrete config region_params type_params - cg_args + | A.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 | BoxFree -> (* Should have been treated above *) raise (Failure "Unreachable") | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> - eval_vec_function_concrete config fid region_params type_params - cg_args + eval_vec_function_concrete config fid generics | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut | ArraySubsliceShared | ArraySubsliceMut | SliceIndexShared | SliceIndexMut | SliceSubsliceShared @@ -660,13 +655,13 @@ let eval_non_local_function_call_concrete (config : C.config) let cc = comp cc (pop_frame_assign config dest) in (* Continue *) - cc cf + cc cf ctx in (* Compose and apply *) comp cf_eval_ops cf_eval_call -let instantiate_fun_sig (type_params : T.ety list) - (cg_args : T.const_generic list) (sg : A.fun_sig) : A.inst_fun_sig = +let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = @@ -685,7 +680,7 @@ let instantiate_fun_sig (type_params : T.ety list) T.RegionGroupId.Map.find rg_id asubst_map in (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params in + let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in (* Generate the type substitution * Note that we need the substitution to map the type variables to * {!rty} types (not {!ety}). In order to do that, we convert the @@ -694,13 +689,28 @@ let instantiate_fun_sig (type_params : T.ety list) * This is a current limitation of the analysis: there is still some * work to do to properly handle full type parametrization. * *) - let rtype_params = List.map ety_no_regions_to_rty type_params in - let tsubst = Subst.make_type_subst_from_vars sg.type_params rtype_params in + let rtype_params = List.map ety_no_regions_to_rty generics.types in + let tsubst = Subst.make_type_subst_from_vars sg.generics.types rtype_params in let cgsubst = - Subst.make_const_generic_subst_from_vars sg.const_generic_params cg_args + Subst.make_const_generic_subst_from_vars sg.generics.const_generics + generics.const_generics + in + (* TODO: something annoying with the trait ref subst: we need to use region + types, but the arguments use erased regions. For now we use the fact + that no regions should appear inside. In the future: we should merge + ety and rty. *) + let trait_refs = + List.map TypesUtils.etrait_ref_no_regions_to_gr_trait_ref + generics.trait_refs + in + let tr_subst = + Subst.make_trait_subst_from_clauses sg.generics.trait_clauses trait_refs in (* Substitute the signature *) - let inst_sig = Subst.substitute_signature asubst rsubst tsubst cgsubst sg in + let inst_sig = + Assoc.ctx_subst_norm_signature ctx asubst rsubst tsubst cgsubst tr_subst + tr_self sg + in (* Return *) inst_sig @@ -839,7 +849,7 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = match rvalue with | E.Global _ -> raise (Failure "Unreachable") | E.Use _ - | E.Ref (_, (E.Shared | E.Mut | E.TwoPhaseMut | E.Shallow)) + | E.RvRef (_, (E.Shared | E.Mut | E.TwoPhaseMut | E.Shallow)) | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ | E.Aggregate _ -> let rp = rvalue_get_place rvalue in @@ -896,7 +906,9 @@ 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) *) - (eval_local_function_call_concrete config global.body_id [] [] [] [] dest) + let generics = TypesUtils.mk_empty_generic_args in + (eval_transparent_function_call_concrete config global.body_id generics [] + dest) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be @@ -1040,26 +1052,26 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = (** Evaluate a function call (auxiliary helper for [eval_statement]) *) and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = - (* There are two cases: + (* There are several cases: - this is a local function, in which case we execute its body - - this is a non-local function, in which case there is a special treatment + - this is an assumed function, in which case there is a special treatment + - this is a trait method *) match call.func with - | A.Regular fid -> - eval_local_function_call config fid call.region_args call.type_args - call.const_generic_args call.args call.dest - | A.Assumed fid -> - eval_non_local_function_call config fid call.region_args call.type_args - call.const_generic_args call.args call.dest + | A.FunId (A.Regular fid) -> + eval_transparent_function_call config fid call.generics call.args + call.dest + | A.FunId (A.Assumed fid) -> + eval_assumed_function_call config fid call.generics call.args call.dest + | A.TraitMethod _ -> raise (Failure "Unimplemented") (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) - (_region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = +and eval_transparent_function_call_concrete (config : C.config) + (fid : A.FunDeclId.id) (generics : T.egeneric_args) (args : E.operand list) + (dest : E.place) : st_cm_fun = (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) - assert (cg_args = []); + assert (generics.const_generics = []); fun cf ctx -> (* Retrieve the (correctly instantiated) body *) let def = C.ctx_lookup_fun_decl ctx fid in @@ -1073,16 +1085,14 @@ and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) ^ Print.name_to_string def.name)) | Some body -> body in - let tsubst = - Subst.make_type_subst_from_vars def.A.signature.type_params type_args - in - let cgsubst = - Subst.make_const_generic_subst_from_vars - def.A.signature.const_generic_params cg_args - in - let locals, body_st = - Subst.fun_body_substitute_in_body tsubst cgsubst body + (* TODO: we need to normalize the types if we want to correctly support traits *) + assert (ctx.trait_clauses = [] && generics.trait_refs = []); + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = + Subst.make_esubst_from_generics def.A.signature.generics generics tr_self in + let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) assert (List.length args = body.A.arg_count); @@ -1139,22 +1149,23 @@ and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = +and eval_transparent_function_call_symbolic (config : C.config) + (fid : A.FunDeclId.id) (generics : T.egeneric_args) (args : E.operand list) + (dest : E.place) : st_cm_fun = fun cf ctx -> (* Retrieve the (correctly instantiated) signature *) let def = C.ctx_lookup_fun_decl ctx fid in let sg = def.A.signature in (* Instantiate the signature and introduce fresh abstraction and region ids * while doing so *) - let inst_sg = instantiate_fun_sig type_args cg_args sg in + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let inst_sg = instantiate_fun_sig ctx generics tr_self sg in (* Sanity check *) assert (List.length args = List.length def.A.signature.inputs); (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config (A.Regular fid) inst_sg - region_args type_args cg_args args dest cf ctx + generics args dest cf ctx (** Evaluate a function call in symbolic mode by using the function signature. @@ -1162,10 +1173,8 @@ and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) calls in symbolic mode: only their signatures matter. *) and eval_function_call_symbolic_from_inst_sig (config : C.config) - (fid : A.fun_id) (inst_sg : A.inst_fun_sig) - (_region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : - st_cm_fun = + (fid : A.fun_id) (inst_sg : A.inst_fun_sig) (generics : T.egeneric_args) + (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in @@ -1232,8 +1241,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) let expr = cf ctx in (* Synthesize the symbolic AST *) - S.synthesize_regular_function_call fid call_id ctx abs_ids type_args cg_args - args args_places ret_spc dest_place expr + S.synthesize_regular_function_call fid call_id ctx abs_ids generics args + args_places ret_spc dest_place expr in let cc = comp cc cf_call in @@ -1294,9 +1303,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_non_local_function_call_symbolic (config : C.config) - (fid : A.assumed_fun_id) (region_args : T.erased_region list) - (type_args : T.ety list) (cg_args : T.const_generic list) +and eval_assumed_function_call_symbolic (config : C.config) + (fid : A.assumed_fun_id) (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> (* Sanity check: make sure the type parameters don't contain regions - @@ -1304,7 +1312,7 @@ and eval_non_local_function_call_symbolic (config : C.config) assert ( List.for_all (fun ty -> not (ty_has_borrows ctx.type_context.type_infos ty)) - type_args); + generics.types); (* There are two cases (and this is extremely annoying): - the function is not box_free @@ -1315,7 +1323,7 @@ and eval_non_local_function_call_symbolic (config : C.config) | A.BoxFree -> (* Degenerate case: box_free - note that this is not really a function * call: no need to call a "synthesize_..." function *) - eval_box_free config region_args type_args cg_args args dest (cf Unit) ctx + eval_box_free config generics args dest (cf Unit) ctx | _ -> (* "Normal" case: not box_free *) (* In symbolic mode, the behaviour of a function call is completely defined @@ -1327,55 +1335,50 @@ and eval_non_local_function_call_symbolic (config : C.config) (* should have been treated above *) raise (Failure "Unreachable") | _ -> - instantiate_fun_sig type_args cg_args (Assumed.get_assumed_sig fid) + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + instantiate_fun_sig ctx generics tr_self + (Assumed.get_assumed_sig fid) in (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config (A.Assumed fid) inst_sig - region_args type_args cg_args args dest cf ctx + generics args dest cf ctx (** Evaluate a non-local (i.e, assumed) function call such as [Box::deref] (auxiliary helper for [eval_statement]) *) -and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) - (region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : +and eval_assumed_function_call (config : C.config) (fid : A.assumed_fun_id) + (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> (* Debug *) log#ldebug (lazy - (let type_args = - "[" ^ String.concat ", " (List.map (ety_to_string ctx) type_args) ^ "]" - in + (let generics = PCtx.egeneric_args_to_string ctx generics in let args = "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" in let dest = place_to_string ctx dest in - "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- type_args: " ^ type_args ^ "\n- args: " ^ args ^ "\n- dest: " - ^ dest)); + "eval_assumed_function_call:\n- fid:" ^ A.show_assumed_fun_id fid + ^ "\n- generics: " ^ generics ^ "\n- args: " ^ args ^ "\n- dest: " ^ dest)); match config.mode with | C.ConcreteMode -> - eval_non_local_function_call_concrete config fid region_args type_args - cg_args args dest (cf Unit) ctx + eval_assumed_function_call_concrete config fid generics args dest + (cf Unit) ctx | C.SymbolicMode -> - eval_non_local_function_call_symbolic config fid region_args type_args - cg_args args dest cf ctx + eval_assumed_function_call_symbolic config fid generics args dest cf ctx (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) -and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) - (region_args : T.erased_region list) (type_args : T.ety list) - (cg_args : T.const_generic list) (args : E.operand list) (dest : E.place) : +and eval_transparent_function_call (config : C.config) (fid : A.FunDeclId.id) + (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : st_cm_fun = match config.mode with | ConcreteMode -> - eval_local_function_call_concrete config fid region_args type_args cg_args - args dest + eval_transparent_function_call_concrete config fid generics args dest | SymbolicMode -> - eval_local_function_call_symbolic config fid region_args type_args cg_args - args dest + eval_transparent_function_call_symbolic config fid generics args dest (** 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/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 814bc964..0a086fb2 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -32,7 +32,11 @@ val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun Note: there are no region parameters, because they should be erased. *) val instantiate_fun_sig : - T.ety list -> T.const_generic list -> LA.fun_sig -> LA.inst_fun_sig + C.eval_ctx -> + T.egeneric_args -> + T.rtrait_instance_id -> + LA.fun_sig -> + LA.inst_fun_sig (** Helper. diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 637f1b1e..1513465c 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -273,7 +273,7 @@ let rvalue_get_place (rv : E.rvalue) : E.place option = match rv with | Use (Copy p | Move p) -> Some p | Use (Constant _) -> None - | Ref (p, _) -> Some p + | RvRef (p, _) -> Some p | UnaryOp _ | BinaryOp _ | Global _ | Discriminant _ | Aggregate _ -> None (** See {!ValuesUtils.symbolic_value_has_borrows} *) diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index f29c7f88..9ac5ce13 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -7,6 +7,7 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute +module Assoc = AssociatedTypes module A = LlbcAst module L = Logging open Cps @@ -406,13 +407,14 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (match (tv.V.value, tv.V.ty) with | V.Literal cv, T.Literal ty -> check_literal_type cv ty (* ADT case *) - | V.Adt av, T.Adt (T.AdtId def_id, regions, tys, cgs) -> + | V.Adt av, T.Adt (T.AdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); + assert ( + List.length generics.regions = List.length def.generics.regions); + assert (List.length generics.types = List.length def.generics.types); (* Check that the variant id is consistent *) (match (av.V.variant_id, def.T.kind) with | Some variant_id, T.Enum variants -> @@ -421,8 +423,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Subst.type_decl_get_instantiated_field_etypes def av.V.variant_id - tys cgs + Assoc.type_decl_get_inst_norm_field_etypes ctx def av.V.variant_id + generics in let fields_with_types = List.combine av.V.field_values field_types @@ -431,20 +433,28 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.Adt av, T.Adt (T.Tuple, regions, tys, cgs) -> - assert (regions = []); - assert (cgs = []); + | V.Adt av, T.Adt (T.Tuple, generics) -> + assert (generics.regions = []); + assert (generics.const_generics = []); assert (av.V.variant_id = None); (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in + let fields_with_types = + List.combine av.V.field_values generics.types + in List.iter (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys, cgs) -> ( + | V.Adt av, T.Adt (T.Assumed aty_id, generics) -> ( assert (av.V.variant_id = None || aty_id = T.Option); - match (aty_id, av.V.field_values, regions, tys, cgs) with + match + ( aty_id, + av.V.field_values, + generics.regions, + generics.types, + generics.const_generics ) + with (* Box *) | T.Box, [ inner_value ], [], [ inner_ty ], [] | T.Option, [ inner_value ], [], [ inner_ty ], [] -> @@ -520,14 +530,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check the current pair (value, type) *) (match (atv.V.value, atv.V.ty) with (* ADT case *) - | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys, cgs) -> + | V.AAdt av, T.Adt (T.AdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) - assert (List.length regions = List.length def.region_params); - assert (List.length tys = List.length def.type_params); - assert (List.length cgs = List.length def.const_generic_params); + assert ( + List.length generics.regions = List.length def.generics.regions); + assert (List.length generics.types = List.length def.generics.types); + assert ( + List.length generics.const_generics + = List.length def.generics.const_generics); (* Check that the variant id is consistent *) (match (av.V.variant_id, def.T.kind) with | Some variant_id, T.Enum variants -> @@ -536,8 +549,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Subst.type_decl_get_instantiated_field_rtypes def av.V.variant_id - regions tys cgs + Assoc.type_decl_get_inst_norm_field_rtypes ctx def av.V.variant_id + generics in let fields_with_types = List.combine av.V.field_values field_types @@ -546,20 +559,28 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.AAdt av, T.Adt (T.Tuple, regions, tys, cgs) -> - assert (regions = []); - assert (cgs = []); + | V.AAdt av, T.Adt (T.Tuple, generics) -> + assert (generics.regions = []); + assert (generics.const_generics = []); assert (av.V.variant_id = None); (* Check that the fields have the proper values - and check that there * are as many fields as field types at the same time *) - let fields_with_types = List.combine av.V.field_values tys in + let fields_with_types = + List.combine av.V.field_values generics.types + in List.iter (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys, cgs) -> ( + | V.AAdt av, T.Adt (T.Assumed aty_id, generics) -> ( assert (av.V.variant_id = None); - match (aty_id, av.V.field_values, regions, tys, cgs) with + match + ( aty_id, + av.V.field_values, + generics.regions, + generics.types, + generics.const_generics ) + with (* Box *) | T.Box, [ boxed_value ], [], [ boxed_ty ], [] -> assert (boxed_value.V.ty = boxed_ty) diff --git a/compiler/Logging.ml b/compiler/Logging.ml index 9dc1f5e3..d0f5b0c5 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -57,6 +57,9 @@ let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows" (** Logger for Invariants *) let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants" +(** Logger for AssociatedTypes *) +let associated_types_log = L.get_logger "MainLogger.AssociatedTypes" + (** Logger for SCC *) let scc_log = L.get_logger "MainLogger.Graph.SCC" diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index b348ba1d..1058fab0 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -107,7 +107,7 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = false | Assign (_, rv) -> ( match rv with - | Use _ | Ref _ -> not must_end_with_exit + | Use _ | RvRef _ -> not must_end_with_exit | Aggregate (AggregatedTuple, []) -> not must_end_with_exit | _ -> false) | FakeRead _ | Drop _ | Nop -> not must_end_with_exit @@ -376,7 +376,7 @@ let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = method! visit_Assign env p rv = match (p.projection, rv) with - | [], E.Ref (_, E.Shallow) -> + | [], E.RvRef (_, E.Shallow) -> (* Filter *) filtered := E.VarId.Set.add p.var_id !filtered; Nop diff --git a/compiler/Print.ml b/compiler/Print.ml index 9aa73d7c..aebfd09c 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -21,6 +21,9 @@ module Values = struct type_decl_id_to_string : T.TypeDeclId.id -> string; const_generic_var_id_to_string : T.ConstGenericVarId.id -> string; global_decl_id_to_string : T.GlobalDeclId.id -> string; + trait_decl_id_to_string : T.TraitDeclId.id -> string; + trait_impl_id_to_string : T.TraitImplId.id -> string; + trait_clause_id_to_string : T.TraitClauseId.id -> string; adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; var_id_to_string : E.VarId.id -> string; adt_field_names : @@ -34,6 +37,9 @@ module Values = struct PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; PT.global_decl_id_to_string = fmt.global_decl_id_to_string; + PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = @@ -43,6 +49,9 @@ module Values = struct PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; PT.global_decl_id_to_string = fmt.global_decl_id_to_string; + PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = @@ -52,6 +61,9 @@ module Values = struct PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; PT.global_decl_id_to_string = fmt.global_decl_id_to_string; + PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let var_id_to_string (id : E.VarId.id) : string = @@ -86,10 +98,10 @@ module Values = struct List.map (typed_value_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _, _, _) -> + | T.Adt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _, _) -> + | T.Adt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -111,7 +123,7 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _, _, _) -> ( + | T.Adt (T.Assumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | Box, [ bv ] -> "@Box(" ^ bv ^ ")" @@ -201,10 +213,10 @@ module Values = struct List.map (typed_avalue_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _, _, _) -> + | T.Adt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _, _, _) -> + | T.Adt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -226,7 +238,7 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _, _, _) -> ( + | T.Adt (T.Assumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | Box, [ bv ] -> "@Box(" ^ bv ^ ")" @@ -452,6 +464,9 @@ module Contexts = struct PV.adt_variant_to_string = fmt.adt_variant_to_string; PV.var_id_to_string = fmt.var_id_to_string; PV.adt_field_names = fmt.adt_field_names; + PV.trait_decl_id_to_string = fmt.trait_decl_id_to_string; + PV.trait_impl_id_to_string = fmt.trait_impl_id_to_string; + PV.trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let ast_to_value_formatter (fmt : PA.ast_formatter) : PV.value_formatter = @@ -486,6 +501,15 @@ module Contexts = struct let def = C.ctx_lookup_global_decl ctx def_id in name_to_string def.name in + let trait_decl_id_to_string def_id = + let def = C.ctx_lookup_trait_decl ctx def_id in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = C.ctx_lookup_trait_impl ctx def_id in + name_to_string def.name + in + let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in let adt_variant_to_string = PT.type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls in @@ -506,6 +530,9 @@ module Contexts = struct adt_variant_to_string; var_id_to_string; adt_field_names; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : PA.ast_formatter = @@ -521,6 +548,15 @@ module Contexts = struct let def = C.ctx_lookup_global_decl ctx def_id in global_name_to_string def.name in + let trait_decl_id_to_string def_id = + let def = C.ctx_lookup_trait_decl ctx def_id in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = C.ctx_lookup_trait_impl ctx def_id in + name_to_string def.name + in + let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in { rvar_to_string = ctx_fmt.PV.rvar_to_string; r_to_string = ctx_fmt.PV.r_to_string; @@ -533,6 +569,9 @@ module Contexts = struct adt_field_to_string; fun_decl_id_to_string; global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } (** Split an [env] at every occurrence of [Frame], eliminating those elements. @@ -608,6 +647,12 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_rtype_formatter fmt in PT.rty_to_string fmt t + 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 dfb2c9fd..724f1e0a 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -8,6 +8,9 @@ type type_formatter = { type_decl_id_to_string : TypeDeclId.id -> string; const_generic_var_id_to_string : ConstGenericVarId.id -> string; global_decl_id_to_string : GlobalDeclId.id -> string; + trait_decl_id_to_string : TraitDeclId.id -> string; + trait_impl_id_to_string : TraitImplId.id -> string; + trait_clause_id_to_string : TraitClauseId.id -> string; } type value_formatter = { @@ -18,6 +21,9 @@ type value_formatter = { adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; var_id_to_string : VarId.id -> string; adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; + trait_decl_id_to_string : TraitDeclId.id -> string; + trait_impl_id_to_string : TraitImplId.id -> string; + trait_clause_id_to_string : TraitClauseId.id -> string; } let value_to_type_formatter (fmt : value_formatter) : type_formatter = @@ -26,6 +32,9 @@ let value_to_type_formatter (fmt : value_formatter) : type_formatter = type_decl_id_to_string = fmt.type_decl_id_to_string; const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; global_decl_id_to_string = fmt.global_decl_id_to_string; + trait_decl_id_to_string = fmt.trait_decl_id_to_string; + trait_impl_id_to_string = fmt.trait_impl_id_to_string; + trait_clause_id_to_string = fmt.trait_clause_id_to_string; } (* TODO: we need to store which variables we have encountered so far, and @@ -42,6 +51,9 @@ type ast_formatter = { adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; fun_decl_id_to_string : FunDeclId.id -> string; global_decl_id_to_string : GlobalDeclId.id -> string; + trait_decl_id_to_string : TraitDeclId.id -> string; + trait_impl_id_to_string : TraitImplId.id -> string; + trait_clause_id_to_string : TraitClauseId.id -> string; } let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = @@ -53,6 +65,9 @@ let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = adt_variant_to_string = fmt.adt_variant_to_string; var_id_to_string = fmt.var_id_to_string; adt_field_names = fmt.adt_field_names; + trait_decl_id_to_string = fmt.trait_decl_id_to_string; + trait_impl_id_to_string = fmt.trait_impl_id_to_string; + trait_clause_id_to_string = fmt.trait_clause_id_to_string; } let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = @@ -70,31 +85,51 @@ let literal_type_to_string = Print.PrimitiveValues.literal_type_to_string let scalar_value_to_string = Print.PrimitiveValues.scalar_value_to_string let literal_to_string = Print.PrimitiveValues.literal_to_string +(* Remark: not using generic_params on purpose, because we may use parameters + which either come from LLBC or from pure, and the [generic_params] type + for those ASTs is not the same. Note that it works because we actually don't + need to know the trait clauses to print the AST: we can thus ignore them. +*) let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) (global_decls : A.global_decl GlobalDeclId.Map.t) - (type_params : type_var list) + (trait_decls : A.trait_decl TraitDeclId.Map.t) + (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) (const_generic_params : const_generic_var list) : type_formatter = let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in + let var = TypeVarId.nth type_params vid in type_var_to_string var in let const_generic_var_id_to_string vid = - let var = T.ConstGenericVarId.nth const_generic_params vid in + let var = ConstGenericVarId.nth const_generic_params vid in const_generic_var_to_string var in let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in + let def = TypeDeclId.Map.find def_id type_decls in name_to_string def.name in let global_decl_id_to_string def_id = - let def = T.GlobalDeclId.Map.find def_id global_decls in + let def = GlobalDeclId.Map.find def_id global_decls in + name_to_string def.name + in + let trait_decl_id_to_string def_id = + let def = TraitDeclId.Map.find def_id trait_decls in name_to_string def.name in + let trait_impl_id_to_string def_id = + let def = TraitImplId.Map.find def_id trait_impls in + name_to_string def.name + in + let trait_clause_id_to_string id = + Print.PT.trait_clause_id_to_pretty_string id + in { type_var_id_to_string; type_decl_id_to_string; const_generic_var_id_to_string; global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } (* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. @@ -106,7 +141,8 @@ let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) (fun_decls : A.fun_decl FunDeclId.Map.t) (global_decls : A.global_decl GlobalDeclId.Map.t) - (type_params : type_var list) + (trait_decls : A.trait_decl TraitDeclId.Map.t) + (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) (const_generic_params : const_generic_var list) : ast_formatter = let type_var_id_to_string vid = let var = T.TypeVarId.nth type_params vid in @@ -141,6 +177,17 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let def = GlobalDeclId.Map.find def_id global_decls in global_name_to_string def.name in + let trait_decl_id_to_string def_id = + let def = TraitDeclId.Map.find def_id trait_decls in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = TraitImplId.Map.find def_id trait_impls in + name_to_string def.name + in + let trait_clause_id_to_string id = + Print.PT.trait_clause_id_to_pretty_string id + in { type_var_id_to_string; const_generic_var_id_to_string; @@ -151,6 +198,9 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) adt_field_to_string; fun_decl_id_to_string; global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; } let assumed_ty_to_string (aty : assumed_ty) : string = @@ -182,20 +232,18 @@ let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = match ty with - | Adt (id, tys, cgs) -> ( - let tys = List.map (ty_to_string fmt false) tys in - let cgs = List.map (const_generic_to_string fmt) cgs in - let params = List.append tys cgs in + | Adt (id, generics) -> ( match id with | Tuple -> - assert (cgs = []); - "(" ^ String.concat " * " tys ^ ")" + let generics = generic_args_to_strings fmt false generics in + "(" ^ String.concat " * " generics ^ ")" | AdtId _ | Assumed _ -> - let params_s = - if params = [] then "" else " " ^ String.concat " " params + let generics = generic_args_to_strings fmt true generics in + let generics_s = + if generics = [] then "" else " " ^ String.concat " " generics in - let ty_s = type_id_to_string fmt id ^ params_s in - if params <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) + let ty_s = type_id_to_string fmt id ^ generics_s in + if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) | TypeVar tv -> fmt.type_var_id_to_string tv | Literal lty -> literal_type_to_string lty | Arrow (arg_ty, ret_ty) -> @@ -204,6 +252,62 @@ let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = in if inside then "(" ^ ty ^ ")" else ty +and generic_args_to_strings (fmt : type_formatter) (inside : bool) + (generics : generic_args) : string list = + let tys = List.map (ty_to_string fmt inside) generics.types in + let cgs = List.map (const_generic_to_string fmt) generics.const_generics in + let trait_refs = + List.map (trait_ref_to_string fmt inside) generics.trait_refs + in + List.concat [ tys; cgs; trait_refs ] + +and generic_args_to_string (fmt : type_formatter) (generics : generic_args) : + string = + String.concat " " (generic_args_to_strings fmt true generics) + +and trait_ref_to_string (fmt : type_formatter) (inside : bool) (tr : trait_ref) + : string = + let trait_id = trait_instance_id_to_string fmt false tr.trait_id in + let generics = generic_args_to_string fmt tr.generics in + let s = trait_id ^ generics in + if tr.generics = empty_generic_args || not inside then s else "(" ^ s ^ ")" + +and trait_instance_id_to_string (fmt : type_formatter) (inside : bool) + (id : trait_instance_id) : string = + match id with + | Self -> "Self" + | TraitImpl id -> fmt.trait_impl_id_to_string id + | Clause id -> fmt.trait_clause_id_to_string id + | ParentClause (inst_id, clause_id) -> + let inst_id = trait_instance_id_to_string fmt false inst_id in + let clause_id = fmt.trait_clause_id_to_string clause_id in + "parent(" ^ inst_id ^ ")::" ^ clause_id + | ItemClause (inst_id, item_name, clause_id) -> + let inst_id = trait_instance_id_to_string fmt false inst_id in + let clause_id = fmt.trait_clause_id_to_string clause_id in + "(" ^ inst_id ^ ")::" ^ item_name ^ "::[" ^ clause_id ^ "]" + | TraitRef tr -> trait_ref_to_string fmt inside tr + | UnknownTrait msg -> "UNKNOWN(" ^ msg ^ ")" + +let trait_clause_to_string (fmt : type_formatter) (clause : trait_clause) : + string = + let clause_id = fmt.trait_clause_id_to_string clause.clause_id in + let trait_id = fmt.trait_decl_id_to_string clause.trait_id in + let generics = generic_args_to_strings fmt true clause.generics in + let generics = + if generics = [] then "" else " " ^ String.concat " " generics + in + "[" ^ clause_id ^ "]: " ^ trait_id ^ generics + +let generic_params_to_strings (fmt : type_formatter) (generics : generic_params) + : string list = + let tys = List.map type_var_to_string generics.types in + let cgs = List.map const_generic_var_to_string generics.const_generics in + let trait_clauses = + List.map (trait_clause_to_string fmt) generics.trait_clauses + in + List.concat [ tys; cgs; trait_clauses ] + let field_to_string fmt inside (f : field) : string = match f.field_name with | None -> ty_to_string fmt inside f.field_ty @@ -217,11 +321,10 @@ let variant_to_string fmt (v : variant) : string = ^ ")" let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = - let types = def.type_params in let name = name_to_string def.name in let params = - if types = [] then "" - else " " ^ String.concat " " (List.map type_var_to_string types) + if def.generics = empty_generic_params then "" + else " " ^ String.concat " " (generic_params_to_strings fmt def.generics) in match def.kind with | Struct fields -> @@ -353,10 +456,10 @@ let adt_g_value_to_string (fmt : value_formatter) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with - | Adt (Tuple, _, _) -> + | Adt (Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | Adt (AdtId def_id, _, _) -> + | Adt (AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match variant_id with @@ -378,7 +481,7 @@ let adt_g_value_to_string (fmt : value_formatter) let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | Adt (Assumed aty, _, _) -> ( + | Adt (Assumed aty, _) -> ( (* Assumed type *) match aty with | State -> @@ -631,7 +734,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) (* There are two possibilities: either the [app] is an instantiated, * top-level qualifier (function, ADT constructore...), or it is a "regular" * expression *) - let app, tys = + let app, generics = match app.e with | Qualif qualif -> (* Qualifier case *) @@ -656,9 +759,9 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) in (* Convert the type instantiation *) let ty_fmt = ast_to_type_formatter fmt in - let tys = List.map (ty_to_string ty_fmt true) qualif.type_args in + let generics = generic_args_to_strings ty_fmt true qualif.generics in (* *) - (qualif_s, tys) + (qualif_s, generics) | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in @@ -673,7 +776,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) texpression_to_string fmt inside indent1 indent_incr in let args = List.map arg_to_string args in - let all_args = List.append tys args in + let all_args = List.append generics args in (* Put together *) let e = if all_args = [] then app else app ^ " " ^ String.concat " " all_args diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 55513cc2..147c14b9 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -13,6 +13,9 @@ module FieldId = T.FieldId module SymbolicValueId = V.SymbolicValueId module FunDeclId = A.FunDeclId module GlobalDeclId = A.GlobalDeclId +module TraitDeclId = T.TraitDeclId +module TraitImplId = T.TraitImplId +module TraitClauseId = T.TraitClauseId (** We redefine identifiers for loop: in {!Values}, the identifiers are global (they monotonically increase across functions) while in {!module:Pure} we want @@ -38,6 +41,10 @@ type integer_type = T.integer_type [@@deriving show, ord] type const_generic_var = T.const_generic_var [@@deriving show, ord] type const_generic = T.const_generic [@@deriving show, ord] type const_generic_var_id = T.const_generic_var_id [@@deriving show, ord] +type trait_decl_id = T.trait_decl_id [@@deriving show, ord] +type trait_impl_id = T.trait_impl_id [@@deriving show, ord] +type trait_clause_id = T.trait_clause_id [@@deriving show, ord] +type trait_item_name = T.trait_item_name [@@deriving show, ord] (** The assumed types for the pure AST. @@ -177,6 +184,14 @@ class ['self] iter_ty_base = inherit! [_] T.iter_const_generic inherit! [_] PV.iter_literal_type method visit_type_var_id : 'env -> type_var_id -> unit = fun _ _ -> () + method visit_trait_decl_id : 'env -> trait_decl_id -> unit = fun _ _ -> () + method visit_trait_impl_id : 'env -> trait_impl_id -> unit = fun _ _ -> () + + method visit_trait_clause_id : 'env -> trait_clause_id -> unit = + fun _ _ -> () + + method visit_trait_item_name : 'env -> trait_item_name -> unit = + fun _ _ -> () end (** Ancestor for map visitor for [ty] *) @@ -186,6 +201,18 @@ class ['self] map_ty_base = inherit! [_] T.map_const_generic inherit! [_] PV.map_literal_type method visit_type_var_id : 'env -> type_var_id -> type_var_id = fun _ x -> x + + method visit_trait_decl_id : 'env -> trait_decl_id -> trait_decl_id = + fun _ x -> x + + method visit_trait_impl_id : 'env -> trait_impl_id -> trait_impl_id = + fun _ x -> x + + method visit_trait_clause_id : 'env -> trait_clause_id -> trait_clause_id = + fun _ x -> x + + method visit_trait_item_name : 'env -> trait_item_name -> trait_item_name = + fun _ x -> x end (** Ancestor for reduce visitor for [ty] *) @@ -195,6 +222,18 @@ class virtual ['self] reduce_ty_base = inherit! [_] T.reduce_const_generic inherit! [_] PV.reduce_literal_type method visit_type_var_id : 'env -> type_var_id -> 'a = fun _ _ -> self#zero + + method visit_trait_decl_id : 'env -> trait_decl_id -> 'a = + fun _ _ -> self#zero + + method visit_trait_impl_id : 'env -> trait_impl_id -> 'a = + fun _ _ -> self#zero + + method visit_trait_clause_id : 'env -> trait_clause_id -> 'a = + fun _ _ -> self#zero + + method visit_trait_item_name : 'env -> trait_item_name -> 'a = + fun _ _ -> self#zero end (** Ancestor for mapreduce visitor for [ty] *) @@ -206,10 +245,24 @@ class virtual ['self] mapreduce_ty_base = method visit_type_var_id : 'env -> type_var_id -> type_var_id * 'a = fun _ x -> (x, self#zero) + + method visit_trait_decl_id : 'env -> trait_decl_id -> trait_decl_id * 'a = + fun _ x -> (x, self#zero) + + method visit_trait_impl_id : 'env -> trait_impl_id -> trait_impl_id * 'a = + fun _ x -> (x, self#zero) + + method visit_trait_clause_id + : 'env -> trait_clause_id -> trait_clause_id * 'a = + fun _ x -> (x, self#zero) + + method visit_trait_item_name + : 'env -> trait_item_name -> trait_item_name * 'a = + fun _ x -> (x, self#zero) end type ty = - | Adt of type_id * ty list * const_generic list + | Adt of type_id * generic_args (** {!Adt} encodes ADTs and tuples and assumed types. TODO: what about the ended regions? (ADTs may be parameterized @@ -220,6 +273,23 @@ type ty = | TypeVar of type_var_id | Literal of literal_type | Arrow of ty * ty + +and trait_ref = { trait_id : trait_instance_id; generics : generic_args } + +and generic_args = { + types : ty list; + const_generics : const_generic list; + trait_refs : trait_ref list; +} + +and trait_instance_id = + | Self + | TraitImpl of trait_impl_id + | Clause of trait_clause_id + | ParentClause of trait_instance_id * trait_clause_id + | ItemClause of trait_instance_id * trait_item_name * trait_clause_id + | TraitRef of trait_ref + | UnknownTrait of string [@@deriving show, visitors @@ -265,11 +335,24 @@ type type_decl_kind = Struct of field list | Enum of variant list | Opaque type type_var = T.type_var [@@deriving show] +type trait_clause = { + clause_id : trait_clause_id; + trait_id : trait_decl_id; + generics : generic_args; +} +[@@deriving show] + +type generic_params = { + types : type_var list; + const_generics : const_generic_var list; + trait_clauses : trait_clause list; +} +[@@deriving show] + type type_decl = { def_id : TypeDeclId.id; name : name; - type_params : type_var list; - const_generic_params : const_generic_var list; + generics : generic_params; kind : type_decl_kind; } [@@deriving show] @@ -463,18 +546,13 @@ type qualif_id = | Proj of projection (** Field projector *) [@@deriving show] -(** An instantiated qualified. +(** An instantiated qualifier. Note that for now we have a clear separation between types and expressions, - which explains why we have the [type_params] field: a function or ADT + which explains why we have the [generics] field: a function or ADT constructor is always fully instantiated. *) -type qualif = { - id : qualif_id; - type_args : ty list; - const_generic_args : const_generic list; -} -[@@deriving show] +type qualif = { id : qualif_id; generics : generic_args } [@@deriving show] type field_id = FieldId.id [@@deriving show, ord] type var_id = VarId.id [@@deriving show, ord] diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index d145ce93..77b12811 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -9,17 +9,19 @@ open PureUtils of fields is fixed: it shouldn't be used for arrays, slices, etc. *) let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) - (type_id : type_id) (variant_id : VariantId.id option) (tys : ty list) - (cgs : const_generic list) : ty list = + (type_id : type_id) (variant_id : VariantId.id option) + (generics : generic_args) : ty list = match type_id with | Tuple -> (* Tuple *) + assert (generics.const_generics = []); + assert (generics.trait_refs = []); assert (variant_id = None); - tys + generics.types | AdtId def_id -> (* "Regular" ADT *) let def = TypeDeclId.Map.find def_id type_decls in - type_decl_get_instantiated_fields_types def variant_id tys cgs + type_decl_get_instantiated_fields_types def variant_id generics | Assumed aty -> ( (* Assumed type *) match aty with @@ -27,14 +29,14 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) (* This type is opaque *) raise (Failure "Unreachable: opaque type") | Result -> - let ty = Collections.List.to_cons_nil tys in + let ty = Collections.List.to_cons_nil generics.types in let variant_id = Option.get variant_id in if variant_id = result_return_id then [ ty ] else if variant_id = result_fail_id then [ mk_error_ty ] else raise (Failure "Unreachable: improper variant id for result type") | Error -> - assert (tys = []); + assert (generics = empty_generic_args); let variant_id = Option.get variant_id in assert ( variant_id = error_failure_id || variant_id = error_out_of_fuel_id); @@ -45,14 +47,14 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) else if variant_id = fuel_succ_id then [ mk_fuel_ty ] else raise (Failure "Unreachable: improper variant id for fuel type") | Option -> - let ty = Collections.List.to_cons_nil tys in + let ty = Collections.List.to_cons_nil generics.types in let variant_id = Option.get variant_id in if variant_id = option_some_id then [ ty ] else if variant_id = option_none_id then [] else raise (Failure "Unreachable: improper variant id for option type") | Range -> - let ty = Collections.List.to_cons_nil tys in + let ty = Collections.List.to_cons_nil generics.types in assert (variant_id = None); [ ty; ty ] | Vec | Array | Slice | Str -> @@ -88,12 +90,13 @@ let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = { ctx with env } | PatAdt av -> (* Compute the field types *) - let type_id, tys, cgs = ty_as_adt v.ty in + let type_id, generics = ty_as_adt v.ty in let field_tys = - get_adt_field_types ctx.type_decls type_id av.variant_id tys cgs + get_adt_field_types ctx.type_decls type_id av.variant_id generics in let check_value (ctx : tc_ctx) (ty : ty) (v : typed_pattern) : tc_ctx = if ty <> v.ty then ( + (* TODO: we need to normalize the types *) log#serror ("check_typed_pattern: not the same types:" ^ "\n- ty: " ^ show_ty ty ^ "\n- v.ty: " ^ show_ty v.ty); @@ -142,31 +145,29 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) let adt_ty, field_ty = destruct_arrow e.ty in - let adt_id, adt_type_args, adt_cg_args = ty_as_adt adt_ty in + let adt_id, adt_generics = ty_as_adt adt_ty in (* Check the ADT type *) assert (adt_id = proj_adt_id); - assert (adt_type_args = qualif.type_args); - assert (adt_cg_args = qualif.const_generic_args); + assert (adt_generics = qualif.generics); (* Retrieve and check the expected field type *) let variant_id = None in let expected_field_tys = get_adt_field_types ctx.type_decls proj_adt_id variant_id - qualif.type_args qualif.const_generic_args + qualif.generics in let expected_field_ty = FieldId.nth expected_field_tys field_id in assert (expected_field_ty = field_ty) | AdtCons id -> ( let expected_field_tys = get_adt_field_types ctx.type_decls id.adt_id id.variant_id - qualif.type_args qualif.const_generic_args + qualif.generics in let field_tys, adt_ty = destruct_arrows e.ty in assert (expected_field_tys = field_tys); match adt_ty with - | Adt (type_id, tys, cgs) -> + | Adt (type_id, generics) -> assert (type_id = id.adt_id); - assert (tys = qualif.type_args); - assert (cgs = qualif.const_generic_args) + assert (generics = qualif.generics) | _ -> raise (Failure "Unreachable"))) | Let (monadic, pat, re, e_next) -> let expected_pat_ty = if monadic then destruct_result re.ty else re.ty in @@ -212,15 +213,14 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = | Some ty -> assert (ty = e.ty)); (* Check the fields *) (* Retrieve and check the expected field type *) - let adt_id, adt_type_args, adt_cg_args = ty_as_adt e.ty in + let adt_id, adt_generics = ty_as_adt e.ty in assert (adt_id = supd.struct_id); (* The id can only be: a custom type decl or an array *) match adt_id with | AdtId _ -> let variant_id = None in let expected_field_tys = - get_adt_field_types ctx.type_decls adt_id variant_id adt_type_args - adt_cg_args + get_adt_field_types ctx.type_decls adt_id variant_id adt_generics in List.iter (fun (fid, fe) -> @@ -229,7 +229,9 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx fe) supd.updates | Assumed Array -> - let expected_field_ty = Collections.List.to_cons_nil adt_type_args in + let expected_field_ty = + Collections.List.to_cons_nil adt_generics.types + in List.iter (fun (_, fe) -> assert (expected_field_ty = fe.ty); diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index f099ef9c..1357793b 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -89,14 +89,31 @@ let mk_mplace (var_id : E.VarId.id) (name : string option) (projection : mprojection) : mplace = { var_id; name; projection } +let empty_generic_params : generic_params = + { types = []; const_generics = []; trait_clauses = [] } + +let empty_generic_args : generic_args = + { types = []; const_generics = []; trait_refs = [] } + +let mk_generic_args_from_types (types : ty list) : generic_args = + { types; const_generics = []; trait_refs = [] } + +type subst = { + ty_subst : TypeVarId.id -> ty; + cg_subst : ConstGenericVarId.id -> const_generic; + tr_subst : TraitClauseId.id -> trait_instance_id; + tr_self : trait_instance_id; +} + (** Type substitution *) -let ty_substitute (tsubst : TypeVarId.id -> ty) - (cgsubst : ConstGenericVarId.id -> const_generic) (ty : ty) : ty = +let ty_substitute (subst : subst) (ty : ty) : ty = let obj = object inherit [_] map_ty - method! visit_TypeVar _ var_id = tsubst var_id - method! visit_ConstGenericVar _ var_id = cgsubst var_id + method! visit_TypeVar _ var_id = subst.ty_subst var_id + method! visit_ConstGenericVar _ var_id = subst.cg_subst var_id + method! visit_Clause _ id = subst.tr_subst id + method! visit_Self _ = subst.tr_self end in obj#visit_ty () ty @@ -115,6 +132,18 @@ let make_const_generic_subst (vars : const_generic_var list) (cgs : const_generic list) : ConstGenericVarId.id -> const_generic = Substitute.make_const_generic_subst_from_vars vars cgs +let make_trait_subst (clauses : trait_clause list) (refs : trait_ref list) : + TraitClauseId.id -> trait_instance_id = + let clauses = List.map (fun x -> x.clause_id) clauses in + let refs = List.map (fun x -> TraitRef x) refs in + let ls = List.combine clauses refs in + let mp = + List.fold_left + (fun mp (k, v) -> TraitClauseId.Map.add k v mp) + TraitClauseId.Map.empty ls + in + fun id -> TraitClauseId.Map.find id mp + (** Retrieve the list of fields for the given variant of a {!type:Aeneas.Pure.type_decl}. Raises [Invalid_argument] if the arguments are incorrect. @@ -135,20 +164,27 @@ let type_decl_get_fields (def : type_decl) - def: " ^ show_type_decl def ^ "\n- opt_variant_id: " ^ opt_variant_id)) +let make_subst_from_generics (params : generic_params) (args : generic_args) + (tr_self : trait_instance_id) : subst = + let ty_subst = make_type_subst params.types args.types in + let cg_subst = + make_const_generic_subst params.const_generics args.const_generics + in + let tr_subst = make_trait_subst params.trait_clauses args.trait_refs in + { ty_subst; cg_subst; tr_subst; tr_self } + (** Instantiate the type variables for the chosen variant in an ADT definition, and return the list of the types of its fields *) let type_decl_get_instantiated_fields_types (def : type_decl) - (opt_variant_id : VariantId.id option) (types : ty list) - (cgs : const_generic list) : ty list = - let ty_subst = make_type_subst def.type_params types in - let cg_subst = make_const_generic_subst def.const_generic_params cgs in + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = + (* There shouldn't be any reference to Self *) + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.generics generics tr_self in let fields = type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute ty_subst cg_subst f.field_ty) fields + List.map (fun f -> ty_substitute subst f.field_ty) fields -let fun_sig_substitute (tsubst : TypeVarId.id -> ty) - (cgsubst : ConstGenericVarId.id -> const_generic) (sg : fun_sig) : - inst_fun_sig = - let subst = ty_substitute tsubst cgsubst in +let fun_sig_substitute (subst : subst) (sg : fun_sig) : inst_fun_sig = + let subst = ty_substitute subst in let inputs = List.map subst sg.inputs in let output = subst sg.output in let doutputs = List.map subst sg.doutputs in @@ -194,9 +230,9 @@ let is_global (e : texpression) : bool = let is_const (e : texpression) : bool = match e.e with Const _ -> true | _ -> false -let ty_as_adt (ty : ty) : type_id * ty list * const_generic list = +let ty_as_adt (ty : ty) : type_id * generic_args = match ty with - | Adt (id, tys, cgs) -> (id, tys, cgs) + | Adt (id, generics) -> (id, generics) | _ -> raise (Failure "Unreachable") (** Remove the external occurrences of {!Meta} *) @@ -294,28 +330,30 @@ let destruct_qualif_app (e : texpression) : qualif * texpression list = (** Destruct an expression into a function call, if possible *) let opt_destruct_function_call (e : texpression) : - (fun_or_op_id * ty list * texpression list) option = + (fun_or_op_id * generic_args * texpression list) option = match opt_destruct_qualif_app e with | None -> None | Some (qualif, args) -> ( match qualif.id with - | FunOrOp fun_id -> Some (fun_id, qualif.type_args, args) + | FunOrOp fun_id -> Some (fun_id, qualif.generics, args) | _ -> None) let opt_destruct_result (ty : ty) : ty option = match ty with - | Adt (Assumed Result, tys, cgs) -> - assert (cgs = []); - Some (Collections.List.to_cons_nil tys) + | Adt (Assumed Result, generics) -> + assert (generics.const_generics = []); + assert (generics.trait_refs = []); + Some (Collections.List.to_cons_nil generics.types) | _ -> None let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) let opt_destruct_tuple (ty : ty) : ty list option = match ty with - | Adt (Tuple, tys, cgs) -> - assert (cgs = []); - Some tys + | Adt (Tuple, generics) -> + assert (generics.const_generics = []); + assert (generics.trait_refs = []); + Some generics.types | _ -> None let mk_abs (x : typed_pattern) (e : texpression) : texpression = @@ -387,14 +425,16 @@ let mk_switch (scrut : texpression) (sb : switch_body) : texpression = - if there is > one type: wrap them in a tuple *) let mk_simpl_tuple_ty (tys : ty list) : ty = - match tys with [ ty ] -> ty | _ -> Adt (Tuple, tys, []) + match tys with + | [ ty ] -> ty + | _ -> Adt (Tuple, mk_generic_args_from_types tys) let mk_bool_ty : ty = Literal Bool -let mk_unit_ty : ty = Adt (Tuple, [], []) +let mk_unit_ty : ty = Adt (Tuple, empty_generic_args) let mk_unit_rvalue : texpression = let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = []; const_generic_args = [] } in + let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in let ty = mk_unit_ty in { e; ty } @@ -434,7 +474,7 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = | [ v ] -> v | _ -> let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = Adt (Tuple, tys, []) in + let ty = Adt (Tuple, mk_generic_args_from_types tys) in let value = PatAdt { variant_id = None; field_values = vl } in { value; ty } @@ -445,11 +485,11 @@ let mk_simpl_tuple_texpression (vl : texpression list) : texpression = | _ -> (* Compute the types of the fields, and the type of the tuple constructor *) let tys = List.map (fun (v : texpression) -> v.ty) vl in - let ty = Adt (Tuple, tys, []) in + let ty = Adt (Tuple, mk_generic_args_from_types tys) in let ty = mk_arrows tys ty in (* Construct the tuple constructor qualifier *) let id = AdtCons { adt_id = Tuple; variant_id = None } in - let qualif = { id; type_args = tys; const_generic_args = [] } in + let qualif = { id; generics = mk_generic_args_from_types tys } in (* Put everything together *) let cons = { e = Qualif qualif; ty } in mk_apps cons vl @@ -467,32 +507,36 @@ let ty_as_integer (t : ty) : T.integer_type = let ty_as_literal (t : ty) : T.literal_type = match t with Literal ty -> ty | _ -> raise (Failure "Unreachable") -let mk_state_ty : ty = Adt (Assumed State, [], []) -let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ], []) -let mk_error_ty : ty = Adt (Assumed Error, [], []) -let mk_fuel_ty : ty = Adt (Assumed Fuel, [], []) +let mk_state_ty : ty = Adt (Assumed State, empty_generic_args) + +let mk_result_ty (ty : ty) : ty = + Adt (Assumed Result, mk_generic_args_from_types [ ty ]) + +let mk_error_ty : ty = Adt (Assumed Error, empty_generic_args) +let mk_fuel_ty : ty = Adt (Assumed Fuel, empty_generic_args) let mk_error (error : VariantId.id) : texpression = let ty = mk_error_ty in let id = AdtCons { adt_id = Assumed Error; variant_id = Some error } in - let qualif = { id; type_args = []; const_generic_args = [] } in + let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in { e; ty } let unwrap_result_ty (ty : ty) : ty = match ty with - | Adt (Assumed Result, [ ty ], cgs) -> - assert (cgs = []); + | Adt + (Assumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) + -> ty | _ -> raise (Failure "not a result type") let mk_result_fail_texpression (error : texpression) (ty : ty) : texpression = let type_args = [ ty ] in - let ty = Adt (Assumed Result, type_args, []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in let id = AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } in - let qualif = { id; type_args; const_generic_args = [] } in + let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in let cons_ty = mk_arrow error.ty ty in let cons = { e = cons_e; ty = cons_ty } in @@ -505,11 +549,11 @@ let mk_result_fail_texpression_with_error_id (error : VariantId.id) (ty : ty) : let mk_result_return_texpression (v : texpression) : texpression = let type_args = [ v.ty ] in - let ty = Adt (Assumed Result, type_args, []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in let id = AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } in - let qualif = { id; type_args; const_generic_args = [] } in + let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in let cons_ty = mk_arrow v.ty ty in let cons = { e = cons_e; ty = cons_ty } in @@ -518,7 +562,7 @@ let mk_result_return_texpression (v : texpression) : texpression = (** Create a [Fail err] pattern which captures the error *) let mk_result_fail_pattern (error_pat : pattern) (ty : ty) : typed_pattern = let error_pat : typed_pattern = { value = error_pat; ty = mk_error_ty } in - let ty = Adt (Assumed Result, [ ty ], []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types [ ty ]) in let value = PatAdt { variant_id = Some result_fail_id; field_values = [ error_pat ] } in @@ -530,7 +574,7 @@ let mk_result_fail_pattern_ignore_error (ty : ty) : typed_pattern = mk_result_fail_pattern error_pat ty let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = Adt (Assumed Result, [ v.ty ], []) in + let ty = Adt (Assumed Result, mk_generic_args_from_types [ v.ty ]) in let value = PatAdt { variant_id = Some result_return_id; field_values = [ v ] } in @@ -565,11 +609,11 @@ let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option let fields_values = List.map (fun e -> Option.get e) fields in (* Retrieve the type id and the type args from the pat type (simpler this way *) - let adt_id, type_args, const_generic_args = ty_as_adt pat.ty in + let adt_id, generics = ty_as_adt pat.ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in - let qualif = { id = qualif_id; type_args; const_generic_args } in + let qualif = { id = qualif_id; generics } in let cons_e = Qualif qualif in let field_tys = List.map (fun (v : texpression) -> v.ty) fields_values diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 38850243..64e7716a 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -9,51 +9,53 @@ module E = Expressions module A = LlbcAst module C = Contexts -(** Substitute types variables and regions in a type. *) -let ty_substitute (rsubst : 'r1 -> 'r2) (tsubst : T.TypeVarId.id -> 'r2 T.ty) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (ty : 'r1 T.ty) : - 'r2 T.ty = - let open T in - let visitor = - object - inherit [_] map_ty - method visit_'r _ r = rsubst r - method! visit_TypeVar _ id = tsubst id - - method! visit_type_var_id _ _ = - (* We should never get here because we reimplemented [visit_TypeVar] *) - raise (Failure "Unexpected") +type ('r1, 'r2) subst = { + r_subst : 'r1 -> 'r2; + ty_subst : T.TypeVarId.id -> 'r2 T.ty; + cg_subst : T.ConstGenericVarId.id -> T.const_generic; + (** Substitution from *local* trait clause to trait instance *) + tr_subst : T.TraitClauseId.id -> 'r2 T.trait_instance_id; + (** Substitution for the [Self] trait instance *) + tr_self : 'r2 T.trait_instance_id; +} + +let ty_substitute_visitor (subst : ('r1, 'r2) subst) = + object + inherit [_] T.map_ty + method visit_'r _ r = subst.r_subst r + method! visit_TypeVar _ id = subst.ty_subst id - method! visit_ConstGenericVar _ id = cgsubst id + method! visit_type_var_id _ _ = + (* We should never get here because we reimplemented [visit_TypeVar] *) + raise (Failure "Unexpected") - method! visit_const_generic_var_id _ _ = - (* We should never get here because we reimplemented [visit_Var] *) - raise (Failure "Unexpected") - end - in + method! visit_ConstGenericVar _ id = subst.cg_subst id - visitor#visit_ty () ty + method! visit_const_generic_var_id _ _ = + (* We should never get here because we reimplemented [visit_Var] *) + raise (Failure "Unexpected") -let rty_substitute (rsubst : T.RegionId.id -> T.RegionId.id) - (tsubst : T.TypeVarId.id -> T.rty) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (ty : T.rty) : T.rty = - let rsubst r = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) - in - ty_substitute rsubst tsubst cgsubst ty + method! visit_Clause _ id = subst.tr_subst id + method! visit_Self _ = subst.tr_self + end -let ety_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (ty : T.ety) : T.ety = - let rsubst r = r in - ty_substitute rsubst tsubst cgsubst ty +(** Substitute types variables and regions in a type. *) +let ty_substitute (subst : ('r1, 'r2) subst) (ty : 'r1 T.ty) : 'r2 T.ty = + let visitor = ty_substitute_visitor subst in + visitor#visit_ty () ty (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) let erase_regions (ty : T.rty) : T.ety = - ty_substitute - (fun _ -> T.Erased) - (fun vid -> T.TypeVar vid) - (fun id -> T.ConstGenericVar id) - ty + let subst = + { + r_subst = (fun _ -> T.Erased); + ty_subst = (fun vid -> T.TypeVar vid); + cg_subst = (fun id -> T.ConstGenericVar id); + tr_subst = (fun id -> T.Clause id); + tr_self = T.Self; + } + in + ty_substitute subst ty (** Generate fresh regions for region variables. @@ -78,18 +80,20 @@ let fresh_regions_with_substs (region_vars : T.region_var list) : (* Generate the substitution from region var id to region *) let rid_subst id = T.RegionVarId.Map.find id rid_map in (* Generate the substitution from region to region *) - let rsubst r = + let r_subst r = match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) in (* Return *) - (fresh_region_ids, rid_subst, rsubst) + (fresh_region_ids, rid_subst, r_subst) -(** Erase the regions in a type and substitute the type variables *) -let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) - (ty : 'r T.region T.ty) : T.ety = - let rsubst (_ : 'r T.region) : T.erased_region = T.Erased in - ty_substitute rsubst tsubst cgsubst ty +(** Erase the regions in a type and perform a substitution *) +let erase_regions_substitute_types (ty_subst : T.TypeVarId.id -> T.ety) + (cg_subst : T.ConstGenericVarId.id -> T.const_generic) + (tr_subst : T.TraitClauseId.id -> T.etrait_instance_id) + (tr_self : T.etrait_instance_id) (ty : 'r T.ty) : T.ety = + let r_subst (_ : 'r) : T.erased_region = T.Erased in + let subst = { r_subst; ty_subst; cg_subst; tr_subst; tr_self } in + ty_substitute subst ty (** Create a region substitution from a list of region variable ids and a list of regions (with which to substitute the region variable ids *) @@ -146,16 +150,62 @@ let make_const_generic_subst_from_vars (vars : T.const_generic_var list) (List.map (fun (x : T.const_generic_var) -> x.T.index) vars) cgs -(** Instantiate the type variables in an ADT definition, and return, for - every variant, the list of the types of its fields *) -let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) : (T.VariantId.id option * T.rty list) list = - let r_subst = make_region_subst_from_vars def.T.region_params regions in - let ty_subst = make_type_subst_from_vars def.T.type_params types in +(** Create a trait substitution from a list of trait clause ids and a list of + trait refs *) +let make_trait_subst (clause_ids : T.TraitClauseId.id list) + (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + let ls = List.combine clause_ids trs in + let mp = + List.fold_left + (fun mp (k, v) -> T.TraitClauseId.Map.add k (T.TraitRef v) mp) + T.TraitClauseId.Map.empty ls + in + fun id -> T.TraitClauseId.Map.find id mp + +let make_trait_subst_from_clauses (clauses : T.trait_clause list) + (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + make_trait_subst + (List.map (fun (x : T.trait_clause) -> x.T.clause_id) clauses) + trs + +let make_subst_from_generics (params : T.generic_params) + (args : 'r T.generic_args) (tr_self : 'r T.trait_instance_id) : + (T.region_var_id T.region, 'r) subst = + let r_subst = make_region_subst_from_vars params.T.regions args.T.regions in + let ty_subst = make_type_subst_from_vars params.T.types args.T.types in + let cg_subst = + make_const_generic_subst_from_vars params.T.const_generics + args.T.const_generics + in + let tr_subst = + make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs + in + { r_subst; ty_subst; cg_subst; tr_subst; tr_self } + +let make_esubst_from_generics (params : T.generic_params) + (generics : T.egeneric_args) (tr_self : T.etrait_instance_id) = + let r_subst _ = T.Erased in + let ty_subst = make_type_subst_from_vars params.types generics.T.types in let cg_subst = - make_const_generic_subst_from_vars def.T.const_generic_params cgs + make_const_generic_subst_from_vars params.const_generics + generics.T.const_generics in + let tr_subst = + make_trait_subst_from_clauses params.trait_clauses generics.T.trait_refs + in + { r_subst; ty_subst; cg_subst; tr_subst; tr_self } + +(** Instantiate the type variables in an ADT definition, and return, for + every variant, the list of the types of its fields. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) +let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) + (generics : T.rgeneric_args) : (T.VariantId.id option * T.rty list) list = + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.T.generics generics tr_self in let (variants_fields : (T.VariantId.id option * T.field list) list) = match def.T.kind with | T.Enum variants -> @@ -171,191 +221,218 @@ let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) in List.map (fun (id, fields) -> - ( id, - List.map - (fun f -> ty_substitute r_subst ty_subst cg_subst f.T.field_ty) - fields )) + (id, List.map (fun f -> ty_substitute subst f.T.field_ty) fields)) variants_fields (** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) + of types of the fields for the chosen variant. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) let type_decl_get_instantiated_field_rtypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) : T.rty list = - let r_subst = make_region_subst_from_vars def.T.region_params regions in - let ty_subst = make_type_subst_from_vars def.T.type_params types in - let cg_subst = - make_const_generic_subst_from_vars def.T.const_generic_params cgs - in + (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : + T.rty list = + (* For now, check that there are no clauses - otherwise we might need + to normalize the types *) + assert (def.generics.trait_clauses = []); + (* There shouldn't be any reference to Self *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.T.generics generics tr_self in let fields = TU.type_decl_get_fields def opt_variant_id in - List.map - (fun f -> ty_substitute r_subst ty_subst cg_subst f.T.field_ty) - fields + List.map (fun f -> ty_substitute subst f.T.field_ty) fields (** Return the types of the properly instantiated ADT's variant, provided a - context *) + context. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (cgs : T.const_generic list) : T.rty list = + (generics : T.rgeneric_args) : T.rty list = let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_rtypes def opt_variant_id regions types cgs + type_decl_get_instantiated_field_rtypes def opt_variant_id generics (** Return the types of the properly instantiated ADT value (note that - here, ADT is understood in its broad meaning: ADT, assumed value or tuple) *) + here, ADT is understood in its broad meaning: ADT, assumed value or tuple). + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. + *) let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) - (region_params : T.RegionId.id T.region list) (type_params : T.rty list) - (cg_params : T.const_generic list) : T.rty list = + (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : + T.rty list = match id with | T.AdtId id -> (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id - region_params type_params cg_params + ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id generics | T.Tuple -> - assert (List.length region_params = 0); - type_params + assert (generics.regions = []); + generics.types | T.Assumed aty -> ( match aty with | T.Box | T.Vec -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - assert (List.length cg_params = 0); - type_params + assert (generics.regions = []); + assert (List.length generics.types = 1); + assert (generics.const_generics = []); + generics.types | T.Option -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - assert (List.length cg_params = 0); - if adt.V.variant_id = Some T.option_some_id then type_params + assert (generics.regions = []); + assert (List.length generics.types = 1); + assert (generics.const_generics = []); + if adt.V.variant_id = Some T.option_some_id then generics.types else if adt.V.variant_id = Some T.option_none_id then [] else raise (Failure "Unreachable") | T.Range -> - assert (List.length region_params = 0); - assert (List.length type_params = 1); - assert (List.length cg_params = 0); - type_params + assert (generics.regions = []); + assert (List.length generics.types = 1); + assert (generics.const_generics = []); + generics.types | T.Array | T.Slice | T.Str -> (* Those types don't have fields *) raise (Failure "Unreachable")) (** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant *) + of types of the fields for the chosen variant. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. +*) let type_decl_get_instantiated_field_etypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (types : T.ety list) - (cgs : T.const_generic list) : T.ety list = - let ty_subst = make_type_subst_from_vars def.T.type_params types in - let cg_subst = - make_const_generic_subst_from_vars def.T.const_generic_params cgs + (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : + T.ety list = + (* For now, check that there are no clauses - otherwise we might need + to normalize the types *) + assert (def.generics.trait_clauses = []); + (* There shouldn't be any reference to Self *) + let tr_self : T.erased_region T.trait_instance_id = + T.UnknownTrait __FUNCTION__ + in + let { r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = + make_esubst_from_generics def.T.generics generics tr_self in let fields = TU.type_decl_get_fields def opt_variant_id in List.map - (fun f -> erase_regions_substitute_types ty_subst cg_subst f.T.field_ty) + (fun (f : T.field) -> + erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self + f.T.field_ty) fields (** Return the types of the properly instantiated ADT's variant, provided a - context *) + context. + + **IMPORTANT**: this function doesn't normalize the types, you may want to + use the [AssociatedTypes] equivalent instead. + *) let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (types : T.ety list) (cgs : T.const_generic list) : T.ety list = + (generics : T.egeneric_args) : T.ety list = let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_etypes def opt_variant_id types cgs + type_decl_get_instantiated_field_etypes def opt_variant_id generics -let statement_substitute_visitor (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) = +let statement_substitute_visitor + (subst : (T.erased_region, T.erased_region) subst) = + (* Keep in synch with [ty_substitute_visitor] *) object inherit [_] A.map_statement - method! visit_ety _ ty = ety_substitute tsubst cgsubst ty - method! visit_ConstGenericVar _ id = cgsubst id + method! visit_'r _ r = subst.r_subst r + method! visit_TypeVar _ id = subst.ty_subst id + + method! visit_type_var_id _ _ = + (* We should never get here because we reimplemented [visit_TypeVar] *) + raise (Failure "Unexpected") + + method! visit_ConstGenericVar _ id = subst.cg_subst id method! visit_const_generic_var_id _ _ = (* We should never get here because we reimplemented [visit_Var] *) raise (Failure "Unexpected") + + method! visit_Clause _ id = subst.tr_subst id + method! visit_Self _ = subst.tr_self end (** Apply a type substitution to a place *) -let place_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (p : E.place) : - E.place = +let place_substitute (subst : (T.erased_region, T.erased_region) subst) + (p : E.place) : E.place = (* There is in fact nothing to do *) - (statement_substitute_visitor tsubst cgsubst)#visit_place () p + (statement_substitute_visitor subst)#visit_place () p (** Apply a type substitution to an operand *) -let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (op : E.operand) : - E.operand = - (statement_substitute_visitor tsubst cgsubst)#visit_operand () op +let operand_substitute (subst : (T.erased_region, T.erased_region) subst) + (op : E.operand) : E.operand = + (statement_substitute_visitor subst)#visit_operand () op (** Apply a type substitution to an rvalue *) -let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (rv : E.rvalue) : - E.rvalue = - (statement_substitute_visitor tsubst cgsubst)#visit_rvalue () rv +let rvalue_substitute (subst : (T.erased_region, T.erased_region) subst) + (rv : E.rvalue) : E.rvalue = + (statement_substitute_visitor subst)#visit_rvalue () rv (** Apply a type substitution to an assertion *) -let assertion_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (a : A.assertion) : - A.assertion = - (statement_substitute_visitor tsubst cgsubst)#visit_assertion () a +let assertion_substitute (subst : (T.erased_region, T.erased_region) subst) + (a : A.assertion) : A.assertion = + (statement_substitute_visitor subst)#visit_assertion () a (** Apply a type substitution to a call *) -let call_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (call : A.call) : - A.call = - (statement_substitute_visitor tsubst cgsubst)#visit_call () call +let call_substitute (subst : (T.erased_region, T.erased_region) subst) + (call : A.call) : A.call = + (statement_substitute_visitor subst)#visit_call () call (** Apply a type substitution to a statement *) -let statement_substitute (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (st : A.statement) : - A.statement = - (statement_substitute_visitor tsubst cgsubst)#visit_statement () st +let statement_substitute (subst : (T.erased_region, T.erased_region) subst) + (st : A.statement) : A.statement = + (statement_substitute_visitor subst)#visit_statement () st (** Apply a type substitution to a function body. Return the local variables and the body. *) -let fun_body_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (body : A.fun_body) : +let fun_body_substitute_in_body + (subst : (T.erased_region, T.erased_region) subst) (body : A.fun_body) : A.var list * A.statement = - let rsubst r = r in let locals = List.map - (fun (v : A.var) -> - { v with A.var_ty = ty_substitute rsubst tsubst cgsubst v.A.var_ty }) + (fun (v : A.var) -> { v with A.var_ty = ty_substitute subst v.A.var_ty }) body.A.locals in - let body = statement_substitute tsubst cgsubst body.body in + let body = statement_substitute subst body.body in (locals, body) -(** Substitute a function signature *) +(** Substitute a function signature. + + **IMPORTANT:** this function doesn't normalize the types. + *) let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (rsubst : T.RegionVarId.id -> T.RegionId.id) - (tsubst : T.TypeVarId.id -> T.rty) - (cgsubst : T.ConstGenericVarId.id -> T.const_generic) (sg : A.fun_sig) : - A.inst_fun_sig = - let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + (r_subst : T.RegionVarId.id -> T.RegionId.id) + (ty_subst : T.TypeVarId.id -> T.rty) + (cg_subst : T.ConstGenericVarId.id -> T.const_generic) + (tr_subst : T.TraitClauseId.id -> T.rtrait_instance_id) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + let r_subst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = + match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) in - let inputs = List.map (ty_substitute rsubst' tsubst cgsubst) sg.A.inputs in - let output = ty_substitute rsubst' tsubst cgsubst sg.A.output in + let subst = { r_subst = r_subst'; ty_subst; cg_subst; tr_subst; tr_self } in + let inputs = List.map (ty_substitute subst) sg.A.inputs in + let output = ty_substitute subst sg.A.output in let subst_region_group (rg : T.region_var_group) : A.abs_region_group = let id = asubst rg.id in - let regions = List.map rsubst rg.regions in + let regions = List.map r_subst rg.regions in let parents = List.map asubst rg.parents in { id; regions; parents } in let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in { A.regions_hierarchy; inputs; output } -(** Substitute type variable identifiers in a type *) -let ty_substitute_ids (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : 'r T.ty) +(** Substitute variable identifiers in a type *) +let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : 'r T.ty) : 'r T.ty = let open T in let visitor = object inherit [_] map_ty method visit_'r _ r = r - method! visit_type_var_id _ id = tsubst id - method! visit_const_generic_var_id _ id = cgsubst id + method! visit_type_var_id _ id = ty_subst id + method! visit_const_generic_var_id _ id = cg_subst id end in @@ -371,10 +448,10 @@ let ty_substitute_ids (tsubst : T.TypeVarId.id -> T.TypeVarId.id) [visit_'r] if we define a class which visits objects of types [ety] and [rty] while inheriting a class which visit [ty]... *) -let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) +let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) = @@ -383,10 +460,10 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) inherit [_] T.map_ty method visit_'r _ r = - match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) - method! visit_type_var_id _ id = tsubst id - method! visit_const_generic_var_id _ id = cgsubst id + method! visit_type_var_id _ id = ty_subst id + method! visit_const_generic_var_id _ id = cg_subst id end in @@ -395,7 +472,7 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) inherit [_] C.map_env method! visit_borrow_id _ bid = bsubst bid method! visit_loan_id _ bid = bsubst bid - method! visit_ety _ ty = ty_substitute_ids tsubst cgsubst ty + method! visit_ety _ ty = ty_substitute_ids ty_subst cg_subst ty method! visit_rty env ty = subst_rty#visit_ty env ty method! visit_symbolic_value_id _ id = ssubst id @@ -405,7 +482,7 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) (** We *do* visit meta-values *) method! visit_mvalue env v = self#visit_typed_value env v - method! visit_region_id _ id = rsubst id + method! visit_region_id _ id = r_subst id method! visit_region_var_id _ id = rvsubst id method! visit_abstraction_id _ id = asubst id end @@ -425,20 +502,20 @@ let subst_ids_visitor (rsubst : T.RegionId.id -> T.RegionId.id) method visit_env (env : C.env) : C.env = visitor#visit_env () env end -let typed_value_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_value_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_value) : V.typed_value = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_typed_value v -let typed_value_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (v : V.typed_value) : V.typed_value = - typed_value_subst_ids rsubst + typed_value_subst_ids r_subst (fun x -> x) (fun x -> x) (fun x -> x) @@ -446,41 +523,41 @@ let typed_value_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) (fun x -> x) v -let typed_avalue_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_avalue_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_avalue) : V.typed_avalue = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_typed_avalue v -let abs_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let abs_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : V.abs) : V.abs = - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_abs x -let env_subst_ids (rsubst : T.RegionId.id -> T.RegionId.id) +let env_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) - (tsubst : T.TypeVarId.id -> T.TypeVarId.id) - (cgsubst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) + (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : C.env) : C.env = - (subst_ids_visitor rsubst rvsubst tsubst cgsubst ssubst bsubst asubst) + (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) #visit_env x -let typed_avalue_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) +let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : V.typed_avalue) : V.typed_avalue = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor rsubst + (subst_ids_visitor r_subst (fun x -> x) (fun x -> x) (fun x -> x) @@ -490,9 +567,9 @@ let typed_avalue_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) #visit_typed_avalue x -let env_subst_rids (rsubst : T.RegionId.id -> T.RegionId.id) (x : C.env) : C.env - = - (subst_ids_visitor rsubst +let env_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : C.env) : + C.env = + (subst_ids_visitor r_subst (fun x -> x) (fun x -> x) (fun x -> x) diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 17cdcabc..0f107897 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -43,10 +43,7 @@ type call = { borrows (we need to perform lookups). *) abstractions : V.AbstractionId.id list; - (* TODO: rename to "...args" *) - type_params : T.ety list; - (* TODO: rename to "...args" *) - const_generic_params : T.const_generic list; + generics : T.egeneric_args; args : V.typed_value list; args_places : mplace option list; (** Meta information *) dest : V.symbolic_value; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 7dda1f22..6c2c049b 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -52,6 +52,9 @@ type fun_context = { type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } [@@deriving show] +type trait_decls_context = A.trait_decl A.TraitDeclId.Map.t [@@deriving show] +type trait_impls_context = A.trait_impl A.TraitImplId.Map.t [@@deriving show] + (** Whenever we translate a function call or an ended abstraction, we store the related information (this is useful when translating ended children abstractions). @@ -120,6 +123,8 @@ type bs_ctx = { type_context : type_context; fun_context : fun_context; global_context : global_context; + trait_decls_ctx : trait_decls_context; + trait_impls_ctx : trait_impls_context; fun_decl : A.fun_decl; bid : T.RegionGroupId.id option; (** TODO: rename *) sg : fun_sig; @@ -205,7 +210,7 @@ type bs_ctx = { let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = Print.Ast.decls_and_fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls - ctx.fun_decl + ctx.trait_decls_ctx ctx.trait_impls_ctx ctx.fun_decl let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = let rvar_to_string = Print.Types.region_var_id_to_string in @@ -223,16 +228,19 @@ let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = adt_variant_to_string = ast_fmt.adt_variant_to_string; var_id_to_string; adt_field_names = ast_fmt.adt_field_names; + trait_decl_id_to_string = ast_fmt.trait_decl_id_to_string; + trait_impl_id_to_string = ast_fmt.trait_impl_id_to_string; + trait_clause_id_to_string = ast_fmt.trait_clause_id_to_string; } let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = - let type_params = ctx.fun_decl.signature.type_params in - let cg_params = ctx.fun_decl.signature.const_generic_params in + let generics = ctx.fun_decl.signature.generics in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + PrintPure.mk_ast_formatter type_decls fun_decls global_decls + ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types + generics.const_generics let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let fmt = bs_ctx_to_ctx_formatter ctx in @@ -254,12 +262,11 @@ let rty_to_string (ctx : bs_ctx) (ty : T.rty) : string = Print.PT.rty_to_string fmt ty let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = - let type_params = def.type_params in - let cg_params = def.const_generic_params in let type_decls = ctx.type_context.llbc_type_decls in let global_decls = ctx.global_context.llbc_global_decls in let fmt = - PrintPure.mk_type_formatter type_decls global_decls type_params cg_params + PrintPure.mk_type_formatter type_decls global_decls ctx.trait_decls_ctx + ctx.trait_impls_ctx def.generics.types def.generics.const_generics in PrintPure.type_decl_to_string fmt def 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) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 70ef5e3d..ca661108 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -280,9 +280,7 @@ let translate_crate_to_pure (crate : A.crate) : log#ldebug (lazy "translate_crate_to_pure"); (* Compute the type and function contexts *) - let type_context, fun_context, global_context = - compute_type_fun_global_contexts crate - in + let type_context, fun_context, global_context = compute_contexts crate in let fun_infos = FA.analyze_module crate fun_context.C.fun_decls global_context.C.global_decls !Config.use_state diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 925f6d39..95c7206a 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -14,11 +14,10 @@ type expl_info = subtype_info [@@deriving show] type type_borrows_info = { contains_static : bool; - (** Does the type (transitively) contains a static borrow? *) - contains_borrow : bool; - (** Does the type (transitively) contains a borrow? *) + (** Does the type (transitively) contain a static borrow? *) + contains_borrow : bool; (** Does the type (transitively) contain a borrow? *) contains_nested_borrows : bool; - (** Does the type (transitively) contains nested borrows? *) + (** Does the type (transitively) contain nested borrows? *) contains_borrow_under_mut : bool; } [@@deriving show] @@ -61,7 +60,7 @@ let initialize_g_type_info (param_infos : 'p) : 'p g_type_info = let initialize_type_decl_info (def : type_decl) : type_decl_info = let param_info = { under_borrow = false; under_mut_borrow = false } in - let param_infos = List.map (fun _ -> param_info) def.type_params in + let param_infos = List.map (fun _ -> param_info) def.generics.types in initialize_g_type_info param_infos let type_decl_info_to_partial_type_info (info : type_decl_info) : @@ -122,7 +121,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) (ty : 'r ty) : partial_type_info = match ty with - | Literal _ | Never -> ty_info + | Literal _ | Never | TraitType _ -> ty_info | TypeVar var_id -> ( (* Update the information for the proper parameter, if necessary *) match ty_info.param_infos with @@ -171,20 +170,18 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) analyze expl_info ty_info rty | Adt ( (Tuple | Assumed (Box | Vec | Option | Slice | Array | Str | Range)), - _, - tys, - _ ) -> + generics ) -> (* Nothing to update: just explore the type parameters *) List.fold_left (fun ty_info ty -> analyze expl_info ty_info ty) - ty_info tys - | Adt (AdtId adt_id, regions, tys, _cgs) -> + ty_info generics.types + | Adt (AdtId adt_id, generics) -> (* Lookup the information for this type definition *) let adt_info = TypeDeclId.Map.find adt_id infos in (* Update the type info with the information from the adt *) let ty_info = update_ty_info ty_info adt_info.borrows_info in (* Check if 'static appears in the region parameters *) - let found_static = List.exists r_is_static regions in + let found_static = List.exists r_is_static generics.regions in let borrows_info = ty_info.borrows_info in let borrows_info = { @@ -196,7 +193,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) let ty_info = { ty_info with borrows_info } in (* For every instantiated type parameter: update the exploration info * then explore the type *) - let params_tys = List.combine adt_info.param_infos tys in + let params_tys = List.combine adt_info.param_infos generics.types in let ty_info = List.fold_left (fun ty_info (param_info, ty) -> diff --git a/compiler/dune b/compiler/dune index 6785cad4..db099c3c 100644 --- a/compiler/dune +++ b/compiler/dune @@ -12,6 +12,7 @@ (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) (libraries charon core_unix unionFind ocamlgraph) (modules + AssociatedTypes Assumed Collections Config -- cgit v1.2.3 From 33bb0b7dbdf5cce28b58793e5fb280668a644525 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 31 Aug 2023 16:56:26 +0200 Subject: Finish updating SymbolicToPure.ml --- compiler/PrintPure.ml | 13 +- compiler/Pure.ml | 7 +- compiler/PureTypeCheck.ml | 1 + compiler/SymbolicToPure.ml | 306 +++++++++++++++++++++++++++++---------------- 4 files changed, 212 insertions(+), 115 deletions(-) (limited to 'compiler') diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 724f1e0a..41f1e3dd 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -251,6 +251,15 @@ let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = ty_to_string fmt true arg_ty ^ " -> " ^ ty_to_string fmt false ret_ty in if inside then "(" ^ ty ^ ")" else ty + | TraitType (trait_ref, generics, type_name) -> + let trait_ref = trait_ref_to_string fmt false trait_ref in + let s = + if generics = empty_generic_args then trait_ref ^ "::" ^ type_name + else + let generics = generic_args_to_string fmt generics in + "(" ^ trait_ref ^ " " ^ generics ^ ")::" ^ type_name + in + if inside then "(" ^ s ^ ")" else s and generic_args_to_strings (fmt : type_formatter) (inside : bool) (generics : generic_args) : string list = @@ -567,10 +576,10 @@ let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = let ty_fmt = ast_to_type_formatter fmt in - let type_params = List.map type_var_to_string sg.type_params in + let generics = generic_params_to_strings ty_fmt sg.generics in let inputs = List.map (ty_to_string ty_fmt false) sg.inputs in let output = ty_to_string ty_fmt false sg.output in - let all_types = List.concat [ type_params; inputs; [ output ] ] in + let all_types = List.concat [ generics; inputs; [ output ] ] in String.concat " -> " all_types let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 147c14b9..272ec328 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -273,6 +273,8 @@ type ty = | TypeVar of type_var_id | Literal of literal_type | Arrow of ty * ty + | TraitType of trait_ref * generic_args * string + (** The string is for the name of the associated type *) and trait_ref = { trait_id : trait_instance_id; generics : generic_args } @@ -867,11 +869,10 @@ type fun_sig_info = { - etc. *) type fun_sig = { - type_params : type_var list; - const_generic_params : const_generic_var list; + generics : generic_params; (** TODO: we should analyse the signature to make the type parameters implicit whenever possible *) inputs : ty list; - (** The input types. + (** The types of the inputs. Note that those input types take into account the [fuel] parameter, if the function uses fuel for termination, and the [state] parameter, diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 77b12811..27736ecb 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -69,6 +69,7 @@ type tc_ctx = { env : ty VarId.Map.t; (** Environment from variables to types *) const_generics : ty T.ConstGenericVarId.Map.t; (** The types of the const generics *) + (* TODO: add trait type constraints *) } let check_literal (v : literal) (ty : literal_type) : unit = diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 6c2c049b..c827475b 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -109,8 +109,7 @@ type loop_info = { loop_id : LoopId.id; input_vars : var list; input_svl : V.symbolic_value list; - type_args : ty list; - const_generic_args : const_generic list; + generics : generic_args; forward_inputs : texpression list option; (** The forward inputs are initialized at [None] *) forward_output_no_state_no_result : var option; @@ -275,26 +274,27 @@ let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = PrintPure.texpression_to_string fmt false "" " " e let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = - let type_params = sg.type_params in - let cg_params = sg.const_generic_params in + let type_params = sg.generics.types in + let cg_params = sg.generics.const_generics in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + PrintPure.mk_ast_formatter type_decls fun_decls global_decls + ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let cg_params = def.signature.const_generic_params in + let generics = def.signature.generics in + let type_params = generics.types in + let cg_params = generics.const_generics in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + PrintPure.mk_ast_formatter type_decls fun_decls global_decls + ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params in PrintPure.fun_decl_to_string fmt def @@ -312,17 +312,18 @@ let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = Print.Values.abs_to_string fmt verbose indent indent_incr abs let get_instantiated_fun_sig (fun_id : A.fun_id) - (back_id : T.RegionGroupId.id option) (tys : ty list) - (cgs : const_generic list) (ctx : bs_ctx) : inst_fun_sig = + (back_id : T.RegionGroupId.id option) (generics : generic_args) + (ctx : bs_ctx) : inst_fun_sig = (* Lookup the non-instantiated function signature *) let sg = (RegularFunIdNotLoopMap.find (fun_id, back_id) ctx.fun_context.fun_sigs).sg in (* Create the substitution *) - let tsubst = make_type_subst sg.type_params tys in - let cgsubst = make_const_generic_subst sg.const_generic_params cgs in + (* There shouldn't be any reference to Self *) + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics sg.generics generics tr_self in (* Apply *) - fun_sig_substitute tsubst cgsubst sg + fun_sig_substitute subst sg let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = @@ -375,37 +376,99 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) (* Update the context and return *) ({ ctx with calls; abstractions }, fun_id) +(* Some generic translation functions (we need to translate different "flavours" + of types: sty, forward types, backward types, etc.) *) +let rec translate_generic_args (translate_ty : 'r T.ty -> ty) + (generics : 'r T.generic_args) : generic_args = + (* Can't translate types with regions for now *) + assert (generics.regions = []); + let types = List.map translate_ty generics.types in + let const_generics = generics.const_generics in + let trait_refs = + List.map (translate_trait_ref translate_ty) generics.trait_refs + in + { types; const_generics; trait_refs } + +and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : + trait_ref = + let trait_id = translate_trait_instance_id translate_ty tr.trait_id in + let generics = translate_generic_args translate_ty tr.generics in + { trait_id; generics } + +and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) + (id : 'r T.trait_instance_id) : trait_instance_id = + let translate_trait_instance_id = translate_trait_instance_id translate_ty in + match id with + | T.Self -> Self + | TraitImpl id -> TraitImpl id + | BuiltinOrAuto _ -> + (* We should have eliminated those in the prepasses *) + raise (Failure "Unreachable") + | Clause id -> Clause id + | ParentClause (inst_id, clause_id) -> + let inst_id = translate_trait_instance_id inst_id in + ParentClause (inst_id, clause_id) + | ItemClause (inst_id, item_name, clause_id) -> + let inst_id = translate_trait_instance_id inst_id in + ItemClause (inst_id, item_name, clause_id) + | TraitRef tr -> TraitRef (translate_trait_ref translate_ty tr) + | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) + let rec translate_sty (ty : T.sty) : ty = let translate = translate_sty in match ty with - | T.Adt (type_id, regions, tys, cgs) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - let tys = List.map translate tys in + | T.Adt (type_id, generics) -> ( + let generics = translate_sgeneric_args generics in match type_id with - | T.AdtId adt_id -> Adt (AdtId adt_id, tys, cgs) - | T.Tuple -> mk_simpl_tuple_ty tys + | T.AdtId adt_id -> Adt (AdtId adt_id, generics) + | T.Tuple -> + assert (generics.const_generics = []); + mk_simpl_tuple_ty generics.types | T.Assumed aty -> ( match aty with - | T.Vec -> Adt (Assumed Vec, tys, cgs) - | T.Option -> Adt (Assumed Option, tys, cgs) + | T.Vec -> Adt (Assumed Vec, generics) + | T.Option -> Adt (Assumed Option, generics) | T.Box -> ( (* Eliminate the boxes *) - match tys with + match generics.types with | [ ty ] -> ty | _ -> raise (Failure "Box/vec/option type with incorrect number of arguments") ) - | T.Array -> Adt (Assumed Array, tys, cgs) - | T.Slice -> Adt (Assumed Slice, tys, cgs) - | T.Str -> Adt (Assumed Str, tys, cgs) - | T.Range -> Adt (Assumed Range, tys, cgs))) + | T.Array -> Adt (Assumed Array, generics) + | T.Slice -> Adt (Assumed Slice, generics) + | T.Str -> Adt (Assumed Str, generics) + | T.Range -> Adt (Assumed Range, generics))) | TypeVar vid -> TypeVar vid | Literal ty -> Literal ty | Never -> raise (Failure "Unreachable") | Ref (_, rty, _) -> translate rty + | TraitType (trait_ref, generics, type_name) -> + let trait_ref = translate_strait_ref trait_ref in + let generics = translate_sgeneric_args generics in + TraitType (trait_ref, generics, type_name) + +and translate_sgeneric_args (generics : T.sgeneric_args) : generic_args = + translate_generic_args translate_sty generics + +and translate_strait_ref (tr : T.strait_ref) : trait_ref = + translate_trait_ref translate_sty tr + +and translate_strait_instance_id (id : T.strait_instance_id) : trait_instance_id + = + translate_trait_instance_id translate_sty id + +let translate_trait_clause (clause : T.trait_clause) : trait_clause = + let { T.clause_id; meta = _; trait_id; generics } = clause in + let generics = translate_sgeneric_args generics in + { clause_id; trait_id; generics } + +let translate_generic_params (generics : T.generic_params) : generic_params = + let { T.regions = _; types; const_generics; trait_clauses } = generics in + let trait_clauses = List.map translate_trait_clause trait_clauses in + { types; const_generics; trait_clauses } let translate_field (f : T.field) : field = let field_name = f.field_name in @@ -436,15 +499,15 @@ let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = point of moving this definition for now. *) let translate_type_decl (def : T.type_decl) : type_decl = - (* Translate *) let def_id = def.T.def_id in let name = def.name in + let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) - assert (def.region_params = []); - let type_params = def.type_params in - let const_generic_params = def.const_generic_params in + assert (regions = []); + let trait_clauses = List.map translate_trait_clause trait_clauses in + let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.T.kind in - { def_id; name; type_params; const_generic_params; kind } + { def_id; name; generics; kind } let translate_type_id (id : T.type_id) : type_id = match id with @@ -472,28 +535,33 @@ let translate_type_id (id : T.type_id) : type_id = let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = let translate = translate_fwd_ty type_infos in match ty with - | T.Adt (type_id, regions, tys, cgs) -> ( - (* Can't translate types with regions for now *) - assert (regions = []); - (* Translate the type parameters *) - let t_tys = List.map translate tys in + | T.Adt (type_id, generics) -> ( + let t_generics = translate_fwd_generic_args type_infos generics in (* Eliminate boxes and simplify tuples *) match type_id with | AdtId _ | T.Assumed (T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows type_infos) tys)); + assert ( + not + (List.exists + (TypesUtils.ty_has_borrows type_infos) + generics.types)); let type_id = translate_type_id type_id in - Adt (type_id, t_tys, cgs) + Adt (type_id, t_generics) | Tuple -> (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the identity *) - mk_simpl_tuple_ty t_tys + mk_simpl_tuple_ty t_generics.types | T.Assumed T.Box -> ( (* We eliminate boxes *) (* No general parametricity for now *) - assert (not (List.exists (TypesUtils.ty_has_borrows type_infos) tys)); - match t_tys with + assert ( + not + (List.exists + (TypesUtils.ty_has_borrows type_infos) + generics.types)); + match t_generics.types with | [ bty ] -> bty | _ -> raise @@ -504,12 +572,34 @@ 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 + | 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 + TraitType (trait_ref, generics, type_name) + +and translate_fwd_generic_args (type_infos : TA.type_infos) + (generics : 'r T.generic_args) : generic_args = + translate_generic_args (translate_fwd_ty type_infos) generics + +and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : 'r T.trait_ref) : + trait_ref = + translate_trait_ref (translate_fwd_ty type_infos) tr + +and translate_fwd_trait_instance_id (type_infos : TA.type_infos) + (id : 'r T.trait_instance_id) : trait_instance_id = + translate_trait_instance_id (translate_fwd_ty type_infos) id (** Simply calls [translate_fwd_ty] *) let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = let type_infos = ctx.type_context.type_infos in translate_fwd_ty type_infos ty +(** Simply calls [translate_fwd_generic_args] *) +let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : 'r T.generic_args) + : generic_args = + let type_infos = ctx.type_context.type_infos in + translate_fwd_generic_args type_infos generics + (** Translate a type, when some regions may have ended. We return an option, because the translated type may be empty. @@ -522,7 +612,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) (* A small helper for "leave" types *) let wrap ty = if inside_mut then Some ty else None in match ty with - | T.Adt (type_id, _, tys, cgs) -> ( + | T.Adt (type_id, generics) -> ( match type_id with | T.AdtId _ | Assumed (T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> @@ -530,22 +620,24 @@ let rec translate_back_ty (type_infos : TA.type_infos) assert (not (TypesUtils.ty_has_borrows type_infos ty)); let type_id = translate_type_id type_id in if inside_mut then - let tys_t = List.filter_map translate tys in - Some (Adt (type_id, tys_t, cgs)) + (* We do not want to filter anything, so we translate the generics + as "forward" types *) + let generics = translate_fwd_generic_args type_infos generics in + Some (Adt (type_id, generics)) else None | Assumed T.Box -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); (* Eliminate the box *) - match tys with + match generics.types with | [ bty ] -> translate bty | _ -> raise (Failure "Unreachable: boxes receive exactly one type parameter") ) | T.Tuple -> ( - (* Tuples can contain borrows (which we eliminated) *) - let tys_t = List.filter_map translate tys in + (* Tuples can contain borrows (which we eliminate) *) + let tys_t = List.filter_map translate generics.types in match tys_t with | [] -> None | _ -> @@ -566,6 +658,13 @@ 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) + | TraitType (trait_ref, generics, type_name) -> + assert (generics.regions = []); + (* Translate the trait ref and the generics as "forward" generics - + we do not want to filter any type *) + 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)) (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) @@ -579,7 +678,7 @@ let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = (List.map (fun (cg : T.const_generic_var) -> (cg.index, ctx_translate_fwd_ty ctx (T.Literal cg.ty))) - ctx.sg.const_generic_params) + ctx.sg.generics.const_generics) in let env = VarId.Map.empty in { @@ -682,7 +781,8 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) Note that the function also takes a list of names for the inputs, and computes, for every output for the backward functions, a corresponding name (outputs for backward functions come from borrows in the inputs - of the forward function) which we use as hints to generate pretty names. + of the forward function) which we use as hints to generate pretty names + in the extracted code. *) let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id) (type_infos : TA.type_infos) (sg : A.fun_sig) @@ -815,9 +915,8 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) (* Wrap in a result type *) if effect_info.can_fail then mk_result_ty output else output in - (* Type/const generic parameters *) - let type_params = sg.type_params in - let const_generic_params = sg.const_generic_params in + (* Generic parameters *) + let generics = translate_generic_params sg.generics in (* Return *) let has_fuel = fuel <> [] in let num_fwd_inputs_no_state = List.length fwd_inputs in @@ -845,9 +944,7 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) effect_info; } in - let sg = - { type_params; const_generic_params; inputs; output; doutputs; info } - in + let sg = { generics; inputs; output; doutputs; info } in { sg; output_names } let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = @@ -926,7 +1023,7 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = (** Peel boxes as long as the value is of the form [Box] *) let rec unbox_typed_value (v : V.typed_value) : V.typed_value = match (v.value, v.ty) with - | V.Adt av, T.Adt (T.Assumed T.Box, _, _, _) -> ( + | V.Adt av, T.Adt (T.Assumed T.Box, _) -> ( match av.field_values with | [ bv ] -> unbox_typed_value bv | _ -> raise (Failure "Unreachable")) @@ -971,16 +1068,16 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) let field_values = List.map translate av.field_values in (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with - | T.Adt (T.Tuple, _, _, _) -> + | T.Adt (T.Tuple, _) -> assert (variant_id = None); mk_simpl_tuple_texpression field_values | _ -> - (* Retrieve the type, the translated type arguments and the - * const generic arguments from the translated type (simpler this way) *) - let adt_id, type_args, const_generic_args = ty_as_adt ty in + (* Retrieve the type and the translated generics from the translated + type (simpler this way) *) + let adt_id, generics = ty_as_adt ty in (* Create the constructor *) let qualif_id = AdtCons { adt_id; variant_id = av.variant_id } in - let qualif = { id = qualif_id; type_args; const_generic_args } in + let qualif = { id = qualif_id; generics } in let cons_e = Qualif qualif in let field_tys = List.map (fun (v : texpression) -> v.ty) field_values @@ -1047,7 +1144,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (* Translate the field values *) let field_values = List.filter_map translate adt_v.field_values in (* For now, only tuples can contain borrows *) - let adt_id, _, _, _ = TypesUtils.ty_as_adt av.ty in + let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | T.AdtId _ | T.Assumed @@ -1194,7 +1291,7 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) (* For now, only tuples can contain borrows - note that if we gave * something like a [&mut Vec] to a function, we give back the * vector value upon visiting the "abstraction borrow" node *) - let adt_id, _, _, _ = TypesUtils.ty_as_adt av.ty in + let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with | T.AdtId _ | T.Assumed @@ -1467,8 +1564,7 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = (* Translate the function call *) - let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in - let const_generic_args = call.const_generic_params in + let generics = ctx_translate_fwd_generic_args ctx call.generics in let args = let args = List.map (typed_value_to_texpression ctx call.ctx) call.args in let args_mplaces = List.map translate_opt_mplace call.args_places in @@ -1570,7 +1666,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | None -> dest | Some out_state -> mk_simpl_tuple_pattern [ out_state; dest ] in - let func = { id = FunOrOp fun_id; type_args; const_generic_args } in + let func = { id = FunOrOp fun_id; generics } in let input_tys = (List.map (fun (x : texpression) -> x.ty)) args in let ret_ty = if effect_info.can_fail then mk_result_ty dest_v.ty else dest_v.ty @@ -1701,8 +1797,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) let effect_info = get_fun_effect_info ctx.fun_context.fun_infos fun_id None (Some rg_id) in - let type_args = List.map (ctx_translate_fwd_ty ctx) call.type_params in - let const_generic_args = call.const_generic_params in + let generics = ctx_translate_fwd_generic_args ctx call.generics in (* Retrieve the original call and the parent abstractions *) let _forward, backwards = get_abs_ancestors ctx abs call_id in (* Retrieve the values consumed when we called the forward function and @@ -1751,10 +1846,7 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) in (* Sanity check: there is the proper number of inputs and outputs, and they have the proper type *) let _ = - let inst_sg = - get_instantiated_fun_sig fun_id (Some rg_id) type_args const_generic_args - ctx - in + let inst_sg = get_instantiated_fun_sig fun_id (Some rg_id) generics ctx in log#ldebug (lazy ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" @@ -1797,7 +1889,7 @@ and translate_end_abstraction_fun_call (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 = { id = FunOrOp func; type_args; const_generic_args } in + let func = { id = FunOrOp func; generics } in let func = { e = Qualif func; ty = func_ty } in let call = mk_apps func args in (* **Optimization**: @@ -1920,8 +2012,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (Some rg_id) in let loop_info = LoopId.Map.find loop_id ctx.loops in - let type_args = loop_info.type_args in - let const_generic_args = loop_info.const_generic_args in + let generics = loop_info.generics in let fwd_inputs = Option.get loop_info.forward_inputs in (* Retrieve the additional backward inputs. Note that those are actually the backward inputs of the function we are synthesizing (and that we @@ -1970,7 +2061,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) 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 = { id = FunOrOp func; type_args; const_generic_args } in + let func = { id = FunOrOp func; generics } in let func = { e = Qualif func; ty = func_ty } in let call = mk_apps func args in (* **Optimization**: @@ -2030,9 +2121,7 @@ and translate_global_eval (gid : A.GlobalDeclId.id) (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = let ctx, var = fresh_var_for_symbolic_value sval ctx in let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in - let global_expr = - { id = Global gid; type_args = []; const_generic_args = [] } - in + let global_expr = { id = Global gid; generics = empty_generic_args } in (* We use translate_fwd_ty to translate the global type *) let ty = ctx_translate_fwd_ty ctx decl.ty in let gval = { e = Qualif global_expr; ty } in @@ -2046,11 +2135,7 @@ and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) let v = typed_value_to_texpression ctx ectx v in let args = [ v ] in let func = - { - id = FunOrOp (Fun (Pure Assert)); - type_args = []; - const_generic_args = []; - } + { id = FunOrOp (Fun (Pure Assert)); generics = empty_generic_args } in let func_ty = mk_arrow (Literal Bool) mk_unit_ty in let func = { e = Qualif func; ty = func_ty } in @@ -2198,7 +2283,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (branch : S.expression) (ctx : bs_ctx) : texpression = (* TODO: always introduce a match, and use micro-passes to turn the the match into a let? *) - let type_id, _, _, _ = TypesUtils.ty_as_adt sv.V.sv_ty in + let type_id, _ = TypesUtils.ty_as_adt sv.V.sv_ty in let ctx, vars = fresh_vars_for_symbolic_values svl ctx in let branch = translate_expression branch ctx in match type_id with @@ -2233,10 +2318,10 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) * field. * We use the [dest] variable in order not to have to recompute * the type of the result of the projection... *) - let adt_id, type_args, const_generic_args = ty_as_adt scrutinee.ty in + let adt_id, generics = ty_as_adt scrutinee.ty in let gen_field_proj (field_id : FieldId.id) (dest : var) : texpression = let proj_kind = { adt_id; field_id } in - let qualif = { id = Proj proj_kind; type_args; const_generic_args } in + let qualif = { id = Proj proj_kind; generics } in let proj_e = Qualif qualif in let proj_ty = mk_arrow scrutinee.ty dest.ty in let proj = { e = proj_e; ty = proj_ty } in @@ -2426,13 +2511,7 @@ and translate_forward_end (ectx : C.eval_ctx) let loop_call = let fun_id = Fun (FromLlbc (fid, Some loop_id, None)) in - let func = - { - id = FunOrOp fun_id; - type_args = loop_info.type_args; - const_generic_args = loop_info.const_generic_args; - } - 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 = if effect_info.can_fail then mk_result_ty out_pat.ty else out_pat.ty @@ -2551,14 +2630,24 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = (* Note that we will retrieve the input values later in the [ForwardEnd] (and will introduce the outputs at that moment, together with the actual - call to the loop forward function *) - let type_args = - List.map (fun (ty : T.type_var) -> TypeVar ty.T.index) ctx.sg.type_params - in - let const_generic_args = - List.map - (fun (cg : T.const_generic_var) -> T.ConstGenericVar cg.T.index) - ctx.sg.const_generic_params + call to the loop forward function) *) + let generics = + let { types; const_generics; trait_clauses } = ctx.sg.generics in + let types = + List.map (fun (ty : T.type_var) -> TypeVar ty.T.index) types + in + let const_generics = + List.map + (fun (cg : T.const_generic_var) -> T.ConstGenericVar cg.T.index) + const_generics + in + let trait_refs = + List.map + (fun (c : trait_clause) -> + { trait_id = Clause c.clause_id; generics = empty_generic_args }) + trait_clauses + in + { types; const_generics; trait_refs } in let loop_info = @@ -2566,8 +2655,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = loop_id; input_vars = inputs; input_svl = loop.input_svalues; - type_args; - const_generic_args; + generics; forward_inputs = None; forward_output_no_state_no_result = None; } @@ -2658,8 +2746,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) let func = { id = FunOrOp (Fun (Pure FuelEqZero)); - type_args = []; - const_generic_args = []; + generics = empty_generic_args; } in let func_ty = mk_arrow mk_fuel_ty mk_bool_ty in @@ -2671,8 +2758,7 @@ let wrap_in_match_fuel (fuel0 : VarId.id) (fuel : VarId.id) (body : texpression) let func = { id = FunOrOp (Fun (Pure FuelDecrease)); - type_args = []; - const_generic_args = []; + generics = empty_generic_args; } in let func_ty = mk_arrow mk_fuel_ty mk_fuel_ty in -- cgit v1.2.3 From f8555e3c1ecfc9667795c19975067b37ba5c617f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 31 Aug 2023 17:08:08 +0200 Subject: Update TranslateCore and factor out some definitions in PrintPure --- compiler/PrintPure.ml | 38 ++++++++++++-------------------------- compiler/TranslateCore.ml | 46 ++++++++++++++++++++++++++++++---------------- 2 files changed, 42 insertions(+), 42 deletions(-) (limited to 'compiler') diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 41f1e3dd..77d25823 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -144,17 +144,18 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) (trait_decls : A.trait_decl TraitDeclId.Map.t) (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) (const_generic_params : const_generic_var list) : ast_formatter = - let type_var_id_to_string vid = - let var = T.TypeVarId.nth type_params vid in - type_var_to_string var - in - let const_generic_var_id_to_string vid = - let var = T.ConstGenericVarId.nth const_generic_params vid in - const_generic_var_to_string var - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id type_decls in - name_to_string def.name + let ({ + type_var_id_to_string; + type_decl_id_to_string; + const_generic_var_id_to_string; + global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; + } + : type_formatter) = + mk_type_formatter type_decls global_decls trait_decls trait_impls + type_params const_generic_params in let adt_variant_to_string = Print.Types.type_ctx_to_adt_variant_to_string_fun type_decls @@ -173,21 +174,6 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let def = FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in - let global_decl_id_to_string def_id = - let def = GlobalDeclId.Map.find def_id global_decls in - global_name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = TraitDeclId.Map.find def_id trait_decls in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = TraitImplId.Map.find def_id trait_impls in - name_to_string def.name - in - let trait_clause_id_to_string id = - Print.PT.trait_clause_id_to_pretty_string id - in { type_var_id_to_string; const_generic_var_id_to_string; diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index ba5e237b..1b1572d6 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -18,25 +18,37 @@ type fun_context = { } [@@deriving show] +type trait_decls_context = C.trait_decls_context [@@deriving show] +type trait_impls_context = C.trait_impls_context [@@deriving show] type global_context = C.global_context [@@deriving show] type trans_ctx = { type_context : type_context; fun_context : fun_context; global_context : global_context; + trait_decls_context : trait_decls_context; + trait_impls_context : trait_impls_context; } type fun_and_loops = Pure.fun_decl * Pure.fun_decl list type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list type pure_fun_translation = fun_and_loops * fun_and_loops list -let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let type_params = def.type_params in - let cg_params = def.const_generic_params in +let trans_ctx_to_type_formatter (ctx : trans_ctx) + (type_params : Pure.type_var list) + (const_generic_params : Pure.const_generic_var list) : + PrintPure.type_formatter = let type_decls = ctx.type_context.type_decls in let global_decls = ctx.global_context.global_decls in + let trait_decls = ctx.trait_decls_context.trait_decls in + let trait_impls = ctx.trait_impls_context.trait_impls in + PrintPure.mk_type_formatter type_decls global_decls trait_decls trait_impls + type_params const_generic_params + +let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = + let generics = def.generics in let fmt = - PrintPure.mk_type_formatter type_decls global_decls type_params cg_params + trans_ctx_to_type_formatter ctx generics.types generics.const_generics in PrintPure.type_decl_to_string fmt def @@ -44,27 +56,29 @@ let type_id_to_string (ctx : trans_ctx) (id : Pure.TypeDeclId.id) : string = Print.fun_name_to_string (Pure.TypeDeclId.Map.find id ctx.type_context.type_decls).name -let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = - let type_params = sg.type_params in - let cg_params = sg.const_generic_params in +let trans_ctx_to_ast_formatter (ctx : trans_ctx) + (type_params : Pure.type_var list) + (const_generic_params : Pure.const_generic_var list) : + PrintPure.ast_formatter = let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in let global_decls = ctx.global_context.global_decls in + let trait_decls = ctx.trait_decls_context.trait_decls in + let trait_impls = ctx.trait_impls_context.trait_impls in + PrintPure.mk_ast_formatter type_decls fun_decls global_decls trait_decls + trait_impls type_params const_generic_params + +let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = + let generics = sg.generics in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + trans_ctx_to_ast_formatter ctx generics.types generics.const_generics in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = - let type_params = def.signature.type_params in - let cg_params = def.signature.const_generic_params in - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in + let generics = def.signature.generics in let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params - cg_params + trans_ctx_to_ast_formatter ctx generics.types generics.const_generics in PrintPure.fun_decl_to_string fmt def -- cgit v1.2.3 From c61b32393508479657b51b777a0b4816815a55a5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 31 Aug 2023 19:10:00 +0200 Subject: Make progress on Extract and ExtractBase --- compiler/Config.ml | 8 +++ compiler/Extract.ml | 143 ++++++++++++++++++++++++++++++++++-------------- compiler/ExtractBase.ml | 33 +++++++---- 3 files changed, 132 insertions(+), 52 deletions(-) (limited to 'compiler') diff --git a/compiler/Config.ml b/compiler/Config.ml index bd80769f..ccbb4c75 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -323,3 +323,11 @@ let wrap_opaque_in_sig = ref false information), we use short names (i.e., the original field names). *) let record_fields_short_names = ref false + +(** Parameterize the traits with their associated types, so as not to use + types as first class objects. + + This is useful for some backends with limited expressiveness like HOL4, + and to account for type constraints (like [fn f(...) where T::bar = usize]). + *) +let parameterize_trait_types = ref false diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 7daec16f..4238a152 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -757,6 +757,21 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) : string = + (* Small helper to derive var names from ADT type names. + + We do the following: + - convert the type name to snake case + - take the first letter of every "letter group" + Ex.: "HashMap" -> "hash_map" -> "hm" + *) + let name_from_type_ident (name : string) : string = + let cl = to_snake_case name in + let cl = String.split_on_char '_' cl in + let cl = List.filter (fun s -> String.length s > 0) cl in + assert (List.length cl > 0); + let cl = List.map (fun s -> s.[0]) cl in + StringUtils.string_of_chars cl + in (* If there is a basename, we use it *) match basename with | Some basename -> @@ -765,11 +780,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | None -> ( (* No basename: we use the first letter of the type *) match ty with - | Adt (type_id, tys, _) -> ( + | Adt (type_id, generics) -> ( match type_id with | Tuple -> (* The "pair" case is frequent enough to have its special treatment *) - if List.length tys = 2 then "p" else "t" + if List.length generics.types = 2 then "p" else "t" | Assumed Result -> "r" | Assumed Error -> ConstStrings.error_basename | Assumed Fuel -> ConstStrings.fuel_basename @@ -784,21 +799,13 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let def = TypeDeclId.Map.find adt_id ctx.type_context.type_decls in - (* We do the following: - * - compute the type name, and retrieve the last ident - * - convert this to snake case - * - take the first letter of every "letter group" + (* Derive the var name from the last ident of the type name * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" *) - (* Thename shouldn't be empty, and its last element should + (* The name shouldn't be empty, and its last element should * be an ident *) let cl = List.nth def.name (List.length def.name - 1) in - let cl = to_snake_case (Names.as_ident cl) in - let cl = String.split_on_char '_' cl in - let cl = List.filter (fun s -> String.length s > 0) cl in - assert (List.length cl > 0); - let cl = List.map (fun s -> s.[0]) cl in - StringUtils.string_of_chars cl) + name_from_type_ident (Names.as_ident cl)) | TypeVar _ -> ( (* TODO: use "t" also for F* *) match !backend with @@ -806,7 +813,8 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) | Literal lty -> ( match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") - | Arrow _ -> "f") + | Arrow _ -> "f" + | TraitType (_, _, name) -> name_from_type_ident name) in let type_var_basename (_varset : StringSet.t) (basename : string) : string = (* Rust type variables are snake-case and start with a capital letter *) @@ -1131,13 +1139,13 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = let extract_rec = extract_ty ctx fmt no_params_tys in match ty with - | Adt (type_id, tys, cgs) -> ( - let has_params = tys <> [] || cgs <> [] in + | Adt (type_id, generics) -> ( + let has_params = generics <> empty_generic_args in match type_id with | Tuple -> (* This is a bit annoying, but in F*/Coq/HOL4 [()] is not the unit type: * we have to write [unit]... *) - if tys = [] then F.pp_print_string fmt (unit_name ()) + if generics.types = [] then F.pp_print_string fmt (unit_name ()) else ( F.pp_print_string fmt "("; Collections.List.iter_link @@ -1152,7 +1160,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) in F.pp_print_string fmt product; F.pp_print_space fmt ()) - (extract_rec true) tys; + (extract_rec true) generics.types; F.pp_print_string fmt ")") | AdtId _ | Assumed _ -> ( (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: @@ -1169,36 +1177,34 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (* TODO: for now, only the opaque *functions* are extracted in the opaque module. The opaque *types* are assumed. *) F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx); - if tys <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_rec true) tys); - if cgs <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_const_generic ctx fmt true) - cgs); + extract_generic_args ctx fmt no_params_tys generics; if print_paren then F.pp_print_string fmt ")" | HOL4 -> - (* Const generics are unsupported in HOL4 *) - assert (cgs = []); + let { types; const_generics; trait_refs } = generics in + (* Const generics are not supported in HOL4 *) + assert (const_generics = []); let print_tys = match type_id with | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) | Assumed _ -> true | _ -> raise (Failure "Unreachable") in - if tys <> [] && print_tys then ( - let print_paren = List.length tys > 1 in + if const_generics <> [] && print_tys then ( + let print_paren = List.length types > 1 in if print_paren then F.pp_print_string fmt "("; Collections.List.iter_link (fun () -> F.pp_print_string fmt ","; F.pp_print_space fmt ()) - (extract_rec true) tys; + (extract_rec true) types; if print_paren then F.pp_print_string fmt ")"; F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx))) + F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx); + if trait_refs <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_trait_ref ctx fmt no_params_tys true) + trait_refs))) | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) | Literal lty -> extract_literal_type ctx fmt lty | Arrow (arg_ty, ret_ty) -> @@ -1209,6 +1215,64 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); extract_rec false ret_ty; if inside then F.pp_print_string fmt ")" + | TraitType (trait_ref, generics, type_name) -> + if !parameterize_trait_types then raise (Failure "Unimplemented") + else ( + (* HOL4 doesn't have 1st class types *) + assert (!backend <> HOL4); + if trait_ref.trait_id <> Self then ( + F.pp_print_string fmt "("; + extract_trait_ref ctx fmt no_params_tys false trait_ref; + extract_generic_args ctx fmt no_params_tys generics; + (* TODO: lookup the type name *) + F.pp_print_string fmt (")." ^ type_name)) + else + (* Can only happen when extracting the signature of a trait method + *declaration*. If extracting items for a trait method implementation, + the type should have been normalized. For trait method declarations + we directly reference the item. *) + let trait_decl_id = Option.get ctx.trait_decl_id in + assert (generics = empty_generic_args); + F.pp_print_string fmt type_name) + +and extract_trait_ref (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 "("; + extract_trait_instance_id ctx fmt no_params_tys inside tr.trait_id; + extract_generic_args ctx fmt no_params_tys tr.generics; + if use_brackets then F.pp_print_string fmt ")" + +and extract_generic_args (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 types <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_ty ctx fmt no_params_tys true) + types); + if const_generics <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_const_generic ctx fmt true) + const_generics); + if trait_refs <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_trait_ref ctx fmt no_params_tys true) + trait_refs) + +and extract_trait_instance_id (_ctx : extraction_ctx) (_fmt : F.formatter) + (_no_params_tys : TypeDeclId.Set.t) (_inside : bool) + (id : trait_instance_id) : unit = + match id with + | Self -> raise (Failure "TODO") + | TraitImpl _ -> raise (Failure "TODO") + | Clause _ -> raise (Failure "TODO") + | ParentClause _ -> raise (Failure "TODO") + | ItemClause _ -> raise (Failure "TODO") + | TraitRef _ -> raise (Failure "TODO") + | UnknownTrait _ -> raise (Failure "TODO") (** Compute the names for all the top-level identifiers used in a type definition (type name, variant names, field names, etc. but not type @@ -1551,19 +1615,16 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) *) let is_opaque = type_kind = None in let is_opaque_coq = !backend = Coq && is_opaque in - let use_forall = - is_opaque_coq && (def.type_params <> [] || def.const_generic_params <> []) - in + let use_forall = is_opaque_coq && def.generics <> empty_generic_params in (* Retrieve the definition name *) let with_opaque_pre = false in let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in (* 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 = - ctx_add_type_const_generic_params def.type_params def.const_generic_params - ctx + let ctx_body, type_params, cg_params, trait_clauses = + ctx_add_generic_params def.generics ctx in - let ty_cg_params = List.append type_params cg_params in + let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then F.pp_print_break fmt 0 0; @@ -1586,7 +1647,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* HOL4 doesn't support const generics *) assert (cg_params = [] || !backend <> HOL4); (* Print the type/const generic parameters *) - if ty_cg_params <> [] && !backend <> HOL4 then ( + if all_params <> [] && !backend <> HOL4 then ( if use_forall then ( F.pp_print_space fmt (); F.pp_print_string fmt ":"; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index d733c763..96ecfd42 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -586,6 +586,8 @@ type extraction_ctx = { in case a Rust function only has one backward translation and we filter the forward function because it returns unit. *) + trait_decl_id : trait_decl_id option; + (** If we are extracting a trait declaration, identifies it *) } (** Debugging function, used when communicating name collisions to the user, @@ -885,12 +887,24 @@ let ctx_add_const_generic_params (vars : const_generic_var list) ctx_add_const_generic_var var.name var.index ctx) ctx vars -let ctx_add_type_const_generic_params (tvars : type_var list) - (cgvars : const_generic_var list) (ctx : extraction_ctx) : - extraction_ctx * string list * string list = - let ctx, tys = ctx_add_type_params tvars ctx in - let ctx, cgs = ctx_add_const_generic_params cgvars ctx in - (ctx, tys, cgs) +let ctx_add_trait_clauses (clauses : trait_clause list) (ctx : extraction_ctx) : + extraction_ctx * string list = + List.fold_left_map + (fun ctx (c : trait_clause) -> ctx_add_trait_clause c ctx) + ctx clauses + +(** Returns the lists of names for: + - the type variables + - the const generic variables + - the trait clauses + *) +let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : + extraction_ctx * string list * string list * string list = + let { types; const_generics; trait_clauses } = generics in + let ctx, tys = ctx_add_type_params types ctx in + let ctx, cgs = ctx_add_const_generic_params const_generics ctx in + let ctx, tcs = ctx_add_trait_clauses trait_clauses ctx in + (ctx, tys, cgs, tcs) let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : extraction_ctx * string = @@ -1003,14 +1017,11 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) | None -> None | Some rg_id -> let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in - let regions = + let region_names = List.map - (fun rid -> T.RegionVarId.nth sg.region_params rid) + (fun rid -> (T.RegionVarId.nth sg.generics.regions rid).name) rg.regions in - let region_names = - List.map (fun (r : T.region_var) -> r.name) regions - in Some { id = rg_id; region_names } in let is_opaque = def.body = None in -- cgit v1.2.3 From 06360698561019d7f480dcb4263e2099d9a03ca5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 1 Sep 2023 12:01:03 +0200 Subject: Implement the normalization functions in AssociatedTypes --- compiler/AssociatedTypes.ml | 262 +++++++++++++++++++++++++++++++++-- compiler/Contexts.ml | 43 ++++++ compiler/InterpreterLoopsJoinCtxs.ml | 6 + compiler/InterpreterStatements.ml | 2 +- compiler/Substitute.ml | 36 ++++- 5 files changed, 335 insertions(+), 14 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 4e5625cb..8e08db6e 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -18,11 +18,255 @@ module L = Logging (** The local logger *) let log = L.associated_types_log +(** A trait instance id refers to a local clause if it only uses the variants: + [Self], [Clause], [ParentClause], [ItemClause] *) +let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = + match id with + | T.Self | Clause _ -> true + | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ -> false + | ParentClause (id, _) | ItemClause (id, _, _) -> + trait_instance_id_is_local_clause id + +(** About the conversion functions: for now we need them (TODO: merge ety, rty, etc.), + but they should be applied to types without regions. + *) +type 'r norm_ctx = { + ctx : C.eval_ctx; + get_ty_repr : 'r C.trait_type_ref -> 'r T.ty option; + convert_ety : T.ety -> 'r T.ty; + convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; +} + (** Normalize a type by simplyfying the references to trait associated types and choosing a representative when there are equalities between types enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. *) -let ctx_normalize_type (_ctx : C.eval_ctx) (_ty : 'r T.ty) : 'r T.ty = - raise (Failure "Unimplemented") +let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = + fun ctx ty -> + match ty with + | T.Adt (id, generics) -> Adt (id, ctx_normalize_generic_args ctx generics) + | TypeVar _ | Literal _ | Never -> ty + | Ref (r, ty, rkind) -> + let ty = ctx_normalize_ty ctx ty in + T.Ref (r, ty, rkind) + | TraitType (trait_ref, generics, type_name) -> ( + (* Normalize and attempt to project the type from the trait ref *) + let trait_ref = ctx_normalize_trait_ref ctx trait_ref in + let generics = ctx_normalize_generic_args ctx generics in + let ty : 'r T.ty = + match trait_ref.trait_id with + | T.TraitRef { T.trait_id = T.TraitImpl impl_id; generics; _ } -> + (* Lookup the implementation *) + let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in + (* Lookup the type *) + let ty = snd (List.assoc type_name trait_impl.types) in + (* Annoying: convert etype to an stype - TODO: hwo to avoid that? *) + let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in + (* Substitute - annoying: we can't use *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = + Subst.make_subst_from_generics_no_regions trait_impl.generics + generics tr_self + in + let ty = Subst.ty_substitute subst ty in + (* Reconvert *) + let ty : 'r T.ty = ctx.convert_ety (Subst.erase_regions ty) in + (* Normalize *) + ctx_normalize_ty ctx ty + | _ -> + (* We can't project *) + assert (trait_instance_id_is_local_clause trait_ref.trait_id); + T.TraitType (trait_ref, generics, type_name) + in + let tr : 'r C.trait_type_ref = { C.trait_ref; type_name } in + (* Lookup the representative, if there is *) + match ctx.get_ty_repr tr with None -> ty | Some ty -> ty) + +(** This returns the normalized trait instance id together with an optional + reference to a trait **implementation**. + + We need this in particular to simplify the trait instance ids after we + performed a substitution. + + Example: + ======== + {[ + trait Trait { + type S + } + + impl TraitImpl for Foo { + type S = usize + } + + fn f(...) -> T::S; + + ... + let x = f[TraitImpl](...); // T::S ~~> TraitImpl::S ~~> usize + ]} + + Several remarks: + - as we do not allow higher-order types (yet) then local clauses (and + sub-clauses) can't have generic arguments + - the [TraitRef] case only happens because of substitution, the role of + the normalization is in particular to eliminate it. Inside a [TraitRef] + there is necessarily: + - an id referencing a local (sub-)clause, that is an id using the variants + [Self], [Clause], [ItemClause] and [ParentClause] exclusively. We can't + simplify those cases: all we can do is remove the [TraitRef] wrapper + by leveraging the fact that the generic arguments must be empty. + - a [TraitImpl]. Note that the [TraitImpl] is necessarily just a [TraitImpl], + it can't be for instance a [ParentClause(TraitImpl ...)] because the + trait resolution would then directly reference the implementation + designated by [ParentClause(TraitImpl ...)] (and same for the other cases). + In this case we can lookup the trait implementation and recursively project + over it. + *) +and ctx_normalize_trait_instance_id : + 'r. + 'r norm_ctx -> + 'r T.trait_instance_id -> + 'r T.trait_instance_id * 'r T.trait_ref option = + fun ctx id -> + match id with + | Self -> (id, None) + | TraitImpl _ -> + (* The [TraitImpl] shouldn't be inside any projection - we check this + elsewhere by asserting that whenever we return [None] for the impl + trait ref, then the id actually refers to a local clause. *) + (id, None) + | Clause _ -> (id, None) + | BuiltinOrAuto _ -> (id, None) + | ParentClause (inst_id, clause_id) -> ( + let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in + (* Check if the inst_id refers to a specific implementation, if yes project *) + match impl with + | None -> + (* This is actually a local clause *) + assert (trait_instance_id_is_local_clause inst_id); + (ParentClause (inst_id, clause_id), None) + | Some impl -> + (* We figure out the parent clause by doing the following: + {[ + // The implementation we are looking at + impl Impl1 : Trait1 { ... } + + // Check the trait it implements + trait Trait1 : ParentTrait1 + ParentTrait2 { ... } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + those are the parent clauses + ]} + + We can find the parent clauses in the [trait_decl_ref] field, which + tells us which specific instantiation of [Trait1] is implemented + by [Impl1]. + *) + let clause = + T.TraitClauseId.nth impl.trait_decl_ref.decl_generics.trait_refs + clause_id + in + (* Sanity check: the clause necessarily refers to an impl *) + let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (TraitRef clause, Some clause)) + | ItemClause (inst_id, item_name, clause_id) -> ( + let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in + (* Check if the inst_id refers to a specific implementation, if yes project *) + match impl with + | None -> + (* This is actually a local clause *) + assert (trait_instance_id_is_local_clause inst_id); + (ParentClause (inst_id, clause_id), None) + | Some impl -> + (* We figure out the item clause by doing the following: + {[ + // The implementation we are looking at + impl Impl1 : Trait1 { + type S = ... + with Impl2 : Trait2 ... // Instances satisfying the declared bounds + ^^^^^^^^^^^^^^^^^^ + Lookup the clause from here + } + ]} + *) + (* The referenced instance should be an impl *) + let impl_id = + TypesUtils.trait_instance_id_as_trait_impl impl.trait_id + in + let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in + (* Lookup the clause *) + let item = List.assoc item_name trait_impl.types in + let clause = T.TraitClauseId.nth (fst item) clause_id in + (* Sanity check: the clause necessarily refers to an impl *) + let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (* We need to convert the clause type - + TODO: we have too many problems with those conversions, we should + merge the types. *) + let clause = ctx.convert_etrait_ref clause in + (TraitRef clause, Some clause)) + | TraitRef { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } -> + (* We can't simplify the id *yet* : we will simplify it when projecting. + However, we have an implementation to return *) + (* Normalize the generics *) + let generics = ctx_normalize_generic_args ctx generics in + let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in + let trait_ref : 'r T.trait_ref = + { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } + in + (TraitRef trait_ref, Some trait_ref) + | TraitRef trait_ref -> + (* The trait instance id necessarily refers to a local sub-clause. We + can't project over it and can only peel off the [TraitRef] wrapper *) + assert (trait_instance_id_is_local_clause trait_ref.trait_id); + assert (trait_ref.generics = TypesUtils.mk_empty_generic_args); + (trait_ref.trait_id, None) + | UnknownTrait _ -> + (* This is actually an error case *) + (id, None) + +and ctx_normalize_generic_args (ctx : 'r norm_ctx) + (generics : 'r T.generic_args) : 'r T.generic_args = + let { T.regions; types; const_generics; trait_refs } = generics in + let types = List.map (ctx_normalize_ty ctx) types in + let trait_refs = List.map (ctx_normalize_trait_ref ctx) trait_refs in + { T.regions; types; const_generics; trait_refs } + +and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : + 'r T.trait_ref = + let { T.trait_id; generics; trait_decl_ref } = trait_ref in + let trait_id, _ = ctx_normalize_trait_instance_id ctx trait_id in + let generics = ctx_normalize_generic_args ctx generics in + let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in + { T.trait_id; generics; trait_decl_ref } + +(* Not sure this one is really necessary *) +and ctx_normalize_trait_decl_ref (ctx : 'r norm_ctx) + (trait_decl_ref : 'r T.trait_decl_ref) : 'r T.trait_decl_ref = + let { T.trait_decl_id; decl_generics } = trait_decl_ref in + let decl_generics = ctx_normalize_generic_args ctx decl_generics in + { T.trait_decl_id; decl_generics } + +let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = + let get_ty_repr x = C.RTraitTypeRefMap.find_opt x ctx.norm_trait_rtypes in + let ctx : T.RegionId.id T.region norm_ctx = + { + ctx; + get_ty_repr; + convert_ety = TypesUtils.ety_no_regions_to_rty; + convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; + } + in + ctx_normalize_ty ctx ty + +let ctx_normalize_ety (ctx : C.eval_ctx) (ty : T.ety) : T.ety = + let get_ty_repr x = C.ETraitTypeRefMap.find_opt x ctx.norm_trait_etypes in + let ctx : T.erased_region norm_ctx = + { + ctx; + get_ty_repr; + convert_ety = (fun x -> x); + convert_etrait_ref = (fun x -> x); + } + in + ctx_normalize_ty ctx ty (** Same as [type_decl_get_instantiated_variants_fields_rtypes] but normalizes the types *) let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) @@ -33,7 +277,7 @@ let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) in List.map (fun (variant_id, types) -> - (variant_id, List.map (ctx_normalize_type ctx) types)) + (variant_id, List.map (ctx_normalize_rty ctx) types)) res (** Same as [type_decl_get_instantiated_field_rtypes] but normalizes the types *) @@ -43,7 +287,7 @@ let type_decl_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (def : T.type_decl) let types = Subst.type_decl_get_instantiated_field_rtypes def opt_variant_id generics in - List.map (ctx_normalize_type ctx) types + List.map (ctx_normalize_rty ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) @@ -52,7 +296,7 @@ let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) let types = Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id generics in - List.map (ctx_normalize_type ctx) types + List.map (ctx_normalize_rty ctx) types (** Same as [ctx_adt_value_get_instantiated_field_etypes] but normalizes the types *) let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) @@ -61,7 +305,7 @@ let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) let types = Subst.type_decl_get_instantiated_field_etypes def opt_variant_id generics in - List.map (ctx_normalize_type ctx) types + List.map (ctx_normalize_ety ctx) types (** Same as [ctx_adt_get_instantiated_field_etypes] but normalizes the types *) let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) @@ -71,7 +315,7 @@ let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id generics in - List.map (ctx_normalize_type ctx) types + List.map (ctx_normalize_ety ctx) types (** Same as [substitute_signature] but normalizes the types *) let ctx_subst_norm_signature (ctx : C.eval_ctx) @@ -86,6 +330,6 @@ let ctx_subst_norm_signature (ctx : C.eval_ctx) sg in let { A.regions_hierarchy; inputs; output } = sg in - let inputs = List.map (ctx_normalize_type ctx) inputs in - let output = ctx_normalize_type ctx output in + let inputs = List.map (ctx_normalize_rty ctx) inputs in + let output = ctx_normalize_rty ctx output in { regions_hierarchy; inputs; output } diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 2d396924..0719364e 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -270,6 +270,37 @@ type decls_ctx = { } [@@deriving show] +(** A reference to a trait associated type *) +type 'r trait_type_ref = { trait_ref : 'r trait_ref; type_name : string } +[@@deriving show, ord] + +type etrait_type_ref = erased_region trait_type_ref [@@deriving show, ord] + +type rtrait_type_ref = Types.RegionId.id Types.region trait_type_ref +[@@deriving show, ord] + +(* TODO: correctly use the functors so as not to have a duplication below *) +module ETraitTypeRefOrd = struct + type t = etrait_type_ref + + let compare = compare_etrait_type_ref + let to_string = show_etrait_type_ref + let pp_t = pp_etrait_type_ref + let show_t = show_etrait_type_ref +end + +module RTraitTypeRefOrd = struct + type t = rtrait_type_ref + + let compare = compare_rtrait_type_ref + let to_string = show_rtrait_type_ref + let pp_t = pp_rtrait_type_ref + let show_t = show_rtrait_type_ref +end + +module ETraitTypeRefMap = Collections.MakeMap (ETraitTypeRefOrd) +module RTraitTypeRefMap = Collections.MakeMap (RTraitTypeRefOrd) + (** Evaluation context *) type eval_ctx = { type_context : type_context; @@ -285,6 +316,18 @@ type eval_ctx = { can be symbolic values or concrete values (in the latter case: if we run in interpreter mode) *) trait_clauses : etrait_ref list; + norm_trait_etypes : ety ETraitTypeRefMap.t; + (** The normalized trait types (a map from trait types to their representatives). + Note that this doesn't support account higher-order types. *) + norm_trait_rtypes : rty RTraitTypeRefMap.t; + (** We need this because we manipulate two kinds of types. + Note that we actually forbid regions from appearing both in the trait + references and in the constraints given to the associated types, + meaning that we don't have to worry about mismatches due to changes + in region ids. + + TODO: how not to duplicate? + *) env : env; ended_regions : RegionId.Set.t; } diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index a34a7d06..045ba9d8 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -561,6 +561,8 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) const_generic_vars; const_generic_vars_map; trait_clauses; + norm_trait_etypes; + norm_trait_rtypes; env = _; ended_regions = ended_regions0; } = @@ -577,6 +579,8 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) const_generic_vars = _; const_generic_vars_map = _; trait_clauses = _; + norm_trait_etypes = _; + norm_trait_rtypes = _; env = _; ended_regions = ended_regions1; } = @@ -595,6 +599,8 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) const_generic_vars; const_generic_vars_map; trait_clauses; + norm_trait_etypes; + norm_trait_rtypes; env; ended_regions; } diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index d38f8b95..3fb07956 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -326,7 +326,7 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self sg.output in - Assoc.ctx_normalize_type ctx ty + Assoc.ctx_normalize_ety ctx ty let move_return_value (config : C.config) (pop_return_value : bool) (cf : V.typed_value option -> m_fun) : m_fun = diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 64e7716a..fe88faea 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -39,13 +39,22 @@ let ty_substitute_visitor (subst : ('r1, 'r2) subst) = method! visit_Self _ = subst.tr_self end -(** Substitute types variables and regions in a type. *) +(** Substitute types variables and regions in a type. + + **IMPORTANT**: this doesn't normalize the type. + *) let ty_substitute (subst : ('r1, 'r2) subst) (ty : 'r1 T.ty) : 'r2 T.ty = let visitor = ty_substitute_visitor subst in visitor#visit_ty () ty +(** **IMPORTANT**: this doesn't normalize the trait ref. *) +let trait_ref_substitute (subst : ('r1, 'r2) subst) (tr : 'r1 T.trait_ref) : + 'r2 T.trait_ref = + let visitor = ty_substitute_visitor subst in + visitor#visit_trait_ref () tr + (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : T.rty) : T.ety = +let erase_regions (ty : 'r T.ty) : T.ety = let subst = { r_subst = (fun _ -> T.Erased); @@ -169,8 +178,9 @@ let make_trait_subst_from_clauses (clauses : T.trait_clause list) trs let make_subst_from_generics (params : T.generic_params) - (args : 'r T.generic_args) (tr_self : 'r T.trait_instance_id) : - (T.region_var_id T.region, 'r) subst = + (args : 'r T.region T.generic_args) + (tr_self : 'r T.region T.trait_instance_id) : + (T.region_var_id T.region, 'r T.region) subst = let r_subst = make_region_subst_from_vars params.T.regions args.T.regions in let ty_subst = make_type_subst_from_vars params.T.types args.T.types in let cg_subst = @@ -182,6 +192,24 @@ let make_subst_from_generics (params : T.generic_params) in { r_subst; ty_subst; cg_subst; tr_subst; tr_self } +let make_subst_from_generics_no_regions : + 'r. + T.generic_params -> + 'r T.generic_args -> + 'r T.trait_instance_id -> + (T.region_var_id T.region, 'r) subst = + fun params args tr_self -> + let r_subst _ = raise (Failure "Unexpected region") in + let ty_subst = make_type_subst_from_vars params.T.types args.T.types in + let cg_subst = + make_const_generic_subst_from_vars params.T.const_generics + args.T.const_generics + in + let tr_subst = + make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs + in + { r_subst; ty_subst; cg_subst; tr_subst; tr_self } + let make_esubst_from_generics (params : T.generic_params) (generics : T.egeneric_args) (tr_self : T.etrait_instance_id) = let r_subst _ = T.Erased in -- cgit v1.2.3 From 1e39985a44646f1c352def6e4b29365a113a5dee Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 1 Sep 2023 14:43:11 +0200 Subject: Compute the normalized trait types maps and update Interpreter --- compiler/AssociatedTypes.ml | 135 +++++++++++++++++++++++++++++------ compiler/Contexts.ml | 2 +- compiler/Interpreter.ml | 88 +++++++++++++++-------- compiler/InterpreterLoopsJoinCtxs.ml | 3 - compiler/LlbcAst.ml | 1 + compiler/Substitute.ml | 47 ++++++++---- 6 files changed, 206 insertions(+), 70 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 8e08db6e..07ab70bd 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -14,10 +14,86 @@ module A = LlbcAst module C = Contexts module Subst = Substitute module L = Logging +module UF = UnionFind (** The local logger *) let log = L.associated_types_log +let trait_type_ref_substitute (subst : ('r, 'r1) Subst.subst) + (r : 'r C.trait_type_ref) : 'r1 C.trait_type_ref = + let { C.trait_ref; type_name } = r in + let trait_ref = Subst.trait_ref_substitute subst trait_ref in + { C.trait_ref; type_name } + +module RTyOrd = struct + type t = T.rty + + let compare = T.compare_rty + let to_string = T.show_rty + let pp_t = T.pp_rty + let show_t = T.show_rty +end + +module RTyMap = Collections.MakeMap (RTyOrd) + +(** Compute the representative classes of trait associated types, for normalization *) +let compute_norm_trait_types_from_preds + (trait_type_constraints : T.rtrait_type_constraint list) : + T.ety C.ETraitTypeRefMap.t * T.rty C.RTraitTypeRefMap.t = + (* Compute a union-find structure by recursively exploring the predicates and clauses *) + let norm : T.rty UF.elem RTyMap.t ref = ref RTyMap.empty in + let get_ref (ty : T.rty) : T.rty UF.elem = + match RTyMap.find_opt ty !norm with + | Some r -> r + | None -> + let r = UF.make ty in + norm := RTyMap.add ty r !norm; + r + in + let add_trait_type_constraint (c : T.rtrait_type_constraint) = + let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in + let trait_ty_ref = get_ref trait_ty in + let ty_ref = get_ref c.ty in + let new_repr = UF.get ty_ref in + let merged = UF.union trait_ty_ref ty_ref in + (* Not sure the set operation is necessary, but I want to control which + representative is chosen *) + UF.set merged new_repr + in + (* Explore the local predicates *) + List.iter add_trait_type_constraint trait_type_constraints; + (* TODO: explore the local clauses *) + (* Compute the norm maps *) + let rbindings = + List.map (fun (k, v) -> (k, UF.get v)) (RTyMap.bindings !norm) + in + (* Filter the keys to keep only the trait type aliases *) + let rbindings = + List.filter_map + (fun (k, v) -> + match k with + | T.TraitType (trait_ref, generics, type_name) -> + assert (generics = TypesUtils.mk_empty_generic_args); + Some ({ C.trait_ref; type_name }, v) + | _ -> None) + rbindings + in + let ebindings = + List.map + (fun (k, v) -> + ( trait_type_ref_substitute Subst.erase_regions_subst k, + Subst.erase_regions v )) + rbindings + in + (C.ETraitTypeRefMap.of_list ebindings, C.RTraitTypeRefMap.of_list rbindings) + +let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) + (trait_type_constraints : T.rtrait_type_constraint list) : C.eval_ctx = + let norm_trait_etypes, norm_trait_rtypes = + compute_norm_trait_types_from_preds trait_type_constraints + in + { ctx with C.norm_trait_etypes; norm_trait_rtypes } + (** A trait instance id refers to a local clause if it only uses the variants: [Self], [Clause], [ParentClause], [ItemClause] *) let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = @@ -244,29 +320,41 @@ and ctx_normalize_trait_decl_ref (ctx : 'r norm_ctx) let decl_generics = ctx_normalize_generic_args ctx decl_generics in { T.trait_decl_id; decl_generics } -let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = +let ctx_normalize_trait_type_constraint (ctx : 'r norm_ctx) + (ttc : 'r T.trait_type_constraint) : 'r T.trait_type_constraint = + let { T.trait_ref; generics; type_name; ty } = ttc in + let trait_ref = ctx_normalize_trait_ref ctx trait_ref in + let generics = ctx_normalize_generic_args ctx generics in + let ty = ctx_normalize_ty ctx ty in + { T.trait_ref; generics; type_name; ty } + +let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = let get_ty_repr x = C.RTraitTypeRefMap.find_opt x ctx.norm_trait_rtypes in - let ctx : T.RegionId.id T.region norm_ctx = - { - ctx; - get_ty_repr; - convert_ety = TypesUtils.ety_no_regions_to_rty; - convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; - } - in - ctx_normalize_ty ctx ty + { + ctx; + get_ty_repr; + convert_ety = TypesUtils.ety_no_regions_to_rty; + convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; + } -let ctx_normalize_ety (ctx : C.eval_ctx) (ty : T.ety) : T.ety = +let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = let get_ty_repr x = C.ETraitTypeRefMap.find_opt x ctx.norm_trait_etypes in - let ctx : T.erased_region norm_ctx = - { - ctx; - get_ty_repr; - convert_ety = (fun x -> x); - convert_etrait_ref = (fun x -> x); - } - in - ctx_normalize_ty ctx ty + { + ctx; + get_ty_repr; + convert_ety = (fun x -> x); + convert_etrait_ref = (fun x -> x); + } + +let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = + ctx_normalize_ty (mk_rnorm_ctx ctx) ty + +let ctx_normalize_ety (ctx : C.eval_ctx) (ty : T.ety) : T.ety = + ctx_normalize_ty (mk_enorm_ctx ctx) ty + +let ctx_normalize_rtrait_type_constraint (ctx : C.eval_ctx) + (ttc : T.rtrait_type_constraint) : T.rtrait_type_constraint = + ctx_normalize_trait_type_constraint (mk_rnorm_ctx ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_rtypes] but normalizes the types *) let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) @@ -329,7 +417,10 @@ let ctx_subst_norm_signature (ctx : C.eval_ctx) Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self sg in - let { A.regions_hierarchy; inputs; output } = sg in + let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in let inputs = List.map (ctx_normalize_rty ctx) inputs in let output = ctx_normalize_rty ctx output in - { regions_hierarchy; inputs; output } + let trait_type_constraints = + List.map (ctx_normalize_rtrait_type_constraint ctx) trait_type_constraints + in + { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 0719364e..9d22a643 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -40,6 +40,7 @@ type dummy_var_id = DummyVarId.id [@@deriving show, ord] fn f x : fun_type = let id = fresh_id () in ... + fun () -> ... let g = f x in // <-- the fresh identifier gets generated here let x1 = g () in // <-- no fresh generation here @@ -315,7 +316,6 @@ type eval_ctx = { (** The map from const generic vars to their values. Those values can be symbolic values or concrete values (in the latter case: if we run in interpreter mode) *) - trait_clauses : etrait_ref list; norm_trait_etypes : ety ETraitTypeRefMap.t; (** The normalized trait types (a map from trait types to their representatives). Note that this doesn't support account higher-order types. *) diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index eb66013d..b5e9fcb9 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -32,10 +32,12 @@ let compute_contexts (m : A.crate) : C.decls_ctx = let trait_impls_ctx = { C.trait_impls } in { C.type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } +(** **WARNING**: this function doesn't compute the normalized types + (for the trait type aliases). This should be computed afterwards. + *) let initialize_eval_context (ctx : C.decls_ctx) (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) - (const_generic_vars : T.const_generic_var list) - (trait_clauses : T.etrait_ref list) : C.eval_ctx = + (const_generic_vars : T.const_generic_var list) : C.eval_ctx = C.reset_global_counters (); let const_generic_vars_map = T.ConstGenericVarId.Map.of_list @@ -56,11 +58,53 @@ let initialize_eval_context (ctx : C.decls_ctx) C.type_vars; C.const_generic_vars; C.const_generic_vars_map; - C.trait_clauses; + C.norm_trait_etypes = C.ETraitTypeRefMap.empty (* Empty for now *); + C.norm_trait_rtypes = C.RTraitTypeRefMap.empty (* Empty for now *); C.env = [ C.Frame ]; C.ended_regions = T.RegionId.Set.empty; } +(** Instantiate a function signature for a symbolic execution *) +let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (fdef : A.fun_decl) : + A.inst_fun_sig = + let sg = fdef.signature in + let tr_self = + match fdef.kind with + | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ + | TraitMethodDecl _ | TraitMethodProvided _ -> + raise (Failure "Unimplemented") + in + let generics = + let { T.regions; types; const_generics; trait_clauses } = sg.generics in + let regions = List.map (fun _ -> T.Erased) regions in + let types = List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) types in + let const_generics = + List.map + (fun (v : T.const_generic_var) -> T.ConstGenericVar v.T.index) + const_generics + in + (* Annoying that we have to generate this substitution here *) + let r_subst _ = raise (Failure "Unexpected region") in + let ty_subst = Subst.make_type_subst_from_vars sg.generics.types types in + let cg_subst = + Subst.make_const_generic_subst_from_vars sg.generics.const_generics + const_generics + in + let tr_subst _ = raise (Failure "Unexpected local trait clause") in + let subst = { Subst.r_subst; ty_subst; cg_subst; tr_subst; tr_self } in + let trait_refs = + List.map + (fun (c : T.trait_clause) -> + let { T.trait_id = trait_decl_id; generics; _ } = c in + let generics = Subst.generic_args_substitute subst generics in + let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in + { T.trait_id = T.Clause c.clause_id; generics; trait_decl_ref }) + trait_clauses + in + { T.regions; types; const_generics; trait_refs } + in + instantiate_fun_sig ctx generics tr_self sg + (** Initialize an evaluation context to execute a function. Introduces local variables initialized in the following manner: @@ -94,18 +138,15 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) in let ctx = initialize_eval_context ctx region_groups sg.generics.types - sg.generics.const_generics sg.generics.trait_clauses + sg.generics.const_generics in (* Instantiate the signature *) - let type_params = - List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) sg.type_params - in - let cg_params = - List.map - (fun (v : T.const_generic_var) -> T.ConstGenericVar v.T.index) - sg.const_generic_params + let inst_sg = symbolic_instantiate_fun_sig ctx fdef in + (* Compute the normalization maps *) + let ctx = + AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx + inst_sg.trait_type_constraints in - let inst_sg = instantiate_fun_sig type_params cg_params sg in (* Create fresh symbolic values for the inputs *) let input_svs = List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs @@ -180,15 +221,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return * an instantiation of the signature, so that we use fresh * region ids for the return abstractions. *) let sg = fdef.signature in - let type_params = - List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) sg.type_params - in - let cg_params = - List.map - (fun (v : T.const_generic_var) -> T.ConstGenericVar v.T.index) - sg.const_generic_params - in - let ret_inst_sg = instantiate_fun_sig type_params cg_params sg in + let ret_inst_sg = symbolic_instantiate_fun_sig ctx fdef in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) let pop_return_value = is_regular_return in @@ -362,19 +395,14 @@ let evaluate_function_symbolic_synthesize_backward_from_return for the synthesis) - the symbolic AST generated by the symbolic execution *) -let evaluate_function_symbolic (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) - (global_context : C.global_context) (fdef : A.fun_decl) : - V.symbolic_value list * SA.expression option = +let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) + (fdef : A.fun_decl) : V.symbolic_value list * SA.expression option = (* Debug *) let name_to_string () = Print.fun_name_to_string fdef.A.name in log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); (* Create the evaluation context *) - let ctx, input_svs, inst_sg = - initialize_symbolic_context_for_fun type_context fun_context global_context - fdef - in + let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun ctx fdef in (* Create the continuation to finish the evaluation *) let config = C.mk_config C.SymbolicMode in @@ -518,7 +546,7 @@ module Test = struct (* Create the evaluation context *) let decls_ctx = compute_contexts crate in - let ctx = initialize_eval_context decls_ctx [] [] [] [] in + let ctx = initialize_eval_context decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 045ba9d8..fa44e20e 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -560,7 +560,6 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars; const_generic_vars; const_generic_vars_map; - trait_clauses; norm_trait_etypes; norm_trait_rtypes; env = _; @@ -578,7 +577,6 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars = _; const_generic_vars = _; const_generic_vars_map = _; - trait_clauses = _; norm_trait_etypes = _; norm_trait_rtypes = _; env = _; @@ -598,7 +596,6 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars; const_generic_vars; const_generic_vars_map; - trait_clauses; norm_trait_etypes; norm_trait_rtypes; env; diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml index f4d26e18..2db859b2 100644 --- a/compiler/LlbcAst.ml +++ b/compiler/LlbcAst.ml @@ -11,6 +11,7 @@ type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups (** A function signature, after instantiation *) type inst_fun_sig = { regions_hierarchy : abs_region_groups; + trait_type_constraints : rtrait_type_constraint list; inputs : rty list; output : rty; } diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index fe88faea..b1680282 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -41,30 +41,35 @@ let ty_substitute_visitor (subst : ('r1, 'r2) subst) = (** Substitute types variables and regions in a type. - **IMPORTANT**: this doesn't normalize the type. + **IMPORTANT**: this doesn't normalize the types. *) let ty_substitute (subst : ('r1, 'r2) subst) (ty : 'r1 T.ty) : 'r2 T.ty = let visitor = ty_substitute_visitor subst in visitor#visit_ty () ty -(** **IMPORTANT**: this doesn't normalize the trait ref. *) +(** **IMPORTANT**: this doesn't normalize the types. *) let trait_ref_substitute (subst : ('r1, 'r2) subst) (tr : 'r1 T.trait_ref) : 'r2 T.trait_ref = let visitor = ty_substitute_visitor subst in visitor#visit_trait_ref () tr +(** **IMPORTANT**: this doesn't normalize the types. *) +let generic_args_substitute (subst : ('r1, 'r2) subst) (g : 'r1 T.generic_args) + : 'r2 T.generic_args = + let visitor = ty_substitute_visitor subst in + visitor#visit_generic_args () g + +let erase_regions_subst : ('r, T.erased_region) subst = + { + r_subst = (fun _ -> T.Erased); + ty_subst = (fun vid -> T.TypeVar vid); + cg_subst = (fun id -> T.ConstGenericVar id); + tr_subst = (fun id -> T.Clause id); + tr_self = T.Self; + } + (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : 'r T.ty) : T.ety = - let subst = - { - r_subst = (fun _ -> T.Erased); - ty_subst = (fun vid -> T.TypeVar vid); - cg_subst = (fun id -> T.ConstGenericVar id); - tr_subst = (fun id -> T.Clause id); - tr_self = T.Self; - } - in - ty_substitute subst ty +let erase_regions (ty : 'r T.ty) : T.ety = ty_substitute erase_regions_subst ty (** Generate fresh regions for region variables. @@ -425,6 +430,15 @@ let fun_body_substitute_in_body let body = statement_substitute subst body.body in (locals, body) +let trait_type_constraint_substitute (subst : ('r1, 'r2) subst) + (ttc : 'r1 T.trait_type_constraint) : 'r2 T.trait_type_constraint = + let { T.trait_ref; generics; type_name; ty } = ttc in + let visitor = ty_substitute_visitor subst in + let trait_ref = visitor#visit_trait_ref () trait_ref in + let generics = visitor#visit_generic_args () generics in + let ty = visitor#visit_ty () ty in + { T.trait_ref; generics; type_name; ty } + (** Substitute a function signature. **IMPORTANT:** this function doesn't normalize the types. @@ -448,7 +462,12 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) { id; regions; parents } in let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in - { A.regions_hierarchy; inputs; output } + let trait_type_constraints = + List.map + (trait_type_constraint_substitute subst) + sg.preds.trait_type_constraints + in + { A.inputs; output; regions_hierarchy; trait_type_constraints } (** Substitute variable identifiers in a type *) let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) -- cgit v1.2.3 From aed317881d3083bba6a2cf154289486ef47ddf85 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 1 Sep 2023 16:57:07 +0200 Subject: Update PureMicroPasses --- compiler/InterpreterStatements.ml | 2 +- compiler/PureMicroPasses.ml | 61 ++++++++++++--------------------------- 2 files changed, 19 insertions(+), 44 deletions(-) (limited to 'compiler') diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 3fb07956..3a483b80 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1086,7 +1086,7 @@ and eval_transparent_function_call_concrete (config : C.config) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) - assert (ctx.trait_clauses = [] && generics.trait_refs = []); + assert (generics.trait_refs = []); (* There shouldn't be any reference to Self *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index b2f3bb9f..45e4ea98 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -583,8 +583,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | Qualif { id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; - type_args = _; - const_generic_args = _; + generics = _; } -> (* Lookup the def *) let decl = @@ -767,9 +766,9 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) *) let expression_contains_child_call_in_all_paths (ctx : trans_ctx) (id0 : A.fun_id) (lp_id0 : LoopId.id option) - (rg_id0 : T.RegionGroupId.id option) (tys0 : ty list) + (rg_id0 : T.RegionGroupId.id option) (generics0 : generic_args) (args0 : texpression list) (e : texpression) : bool = - let check_call (fun_id1 : fun_or_op_id) (tys1 : ty list) + let check_call (fun_id1 : fun_or_op_id) (generics1 : generic_args) (args1 : texpression list) : bool = (* Check the fun_ids, to see if call1's function is a child of call0's function *) match fun_id1 with @@ -816,8 +815,8 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) let input_eq (v0, v1) = PureUtils.remove_meta v0 = PureUtils.remove_meta v1 in - (* Compare the input types and the prefix of the input arguments *) - tys0 = tys1 && List.for_all input_eq args + (* Compare the generics and the prefix of the input arguments *) + generics0 = generics1 && List.for_all input_eq args else (* Not a child *) false else (* Not the same function *) @@ -843,8 +842,8 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) | Let (_, _, re, e) -> ( match opt_destruct_function_call re with | None -> fun () -> self#visit_texpression env e () - | Some (func1, tys1, args1) -> - let call_is_child = check_call func1 tys1 args1 in + | Some (func1, generics1, args1) -> + let call_is_child = check_call func1 generics1 args1 in if call_is_child then fun () -> true else fun () -> self#visit_texpression env e ()) | App _ -> ( @@ -1085,8 +1084,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | Qualif { id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; - type_args; - const_generic_args; + generics; } -> (* This is a struct *) (* Retrieve the definiton, to find how many fields there are *) @@ -1107,7 +1105,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = * [x.field] for some variable [x], and where the projection * is for the proper ADT *) let to_var_proj (i : int) (arg : texpression) : - (ty list * const_generic list * var_id) option = + (generic_args * var_id) option = match arg.e with | App (proj, x) -> ( match (proj.e, x.e) with @@ -1115,16 +1113,14 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = { id = Proj { adt_id = AdtId proj_adt_id; field_id }; - type_args = proj_type_args; - const_generic_args = proj_const_generic_args; + generics = proj_generics; }, Var v ) -> (* We check that this is the proper ADT, and the proper field *) if proj_adt_id = adt_id && FieldId.to_int field_id = i - then - Some (proj_type_args, proj_const_generic_args, v) + then Some (proj_generics, v) else None | _ -> None) | _ -> None @@ -1135,14 +1131,13 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = if List.length args = num_fields then (* Check that this is the same variable we project from - * note that we checked above that there is at least one field *) - let (_, _, x), end_args = Collections.List.pop args in - if List.for_all (fun (_, _, y) -> y = x) end_args then ( + let (_, x), end_args = Collections.List.pop args in + if List.for_all (fun (_, y) -> y = x) end_args then ( (* We can substitute *) (* Sanity check: all types correct *) assert ( List.for_all - (fun (tys, cgs, _) -> - tys = type_args && cgs = const_generic_args) + (fun (generics1, _) -> generics1 = generics) args); { e with e = Var x }) else super#visit_texpression env e @@ -1161,8 +1156,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ( Qualif { id = Proj { adt_id = AdtId proj_adt_id; field_id }; - type_args = _; - const_generic_args = _; + generics = _; }, Var v ) -> (* We check that this is the proper ADT, and the proper field *) @@ -1360,8 +1354,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_sig = { - type_params = fun_sig.type_params; - const_generic_params = fun_sig.const_generic_params; + generics = fun_sig.generics; inputs = inputs_tys; output; doutputs; @@ -2142,16 +2135,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : let num_filtered = List.length (List.filter (fun b -> not b) used_info) in - let { - type_params; - const_generic_params; - inputs; - output; - doutputs; - info; - } = - decl.signature - in + let { generics; inputs; output; doutputs; info } = decl.signature in let { has_fuel; num_fwd_inputs_with_fuel_no_state; @@ -2177,16 +2161,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : effect_info; } in - let signature = - { - type_params; - const_generic_params; - inputs; - output; - doutputs; - info; - } - in + let signature = { generics; inputs; output; doutputs; info } in { decl with signature } in -- cgit v1.2.3 From 0023f814ce638cd9b04ead9ec2e0c194d5efaefd Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 1 Sep 2023 18:22:15 +0200 Subject: Make good progress on Extract.ml --- compiler/Extract.ml | 414 ++++++++++++++++++++++-------------------------- compiler/ExtractBase.ml | 47 +++++- 2 files changed, 237 insertions(+), 224 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 4238a152..3c4feca5 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -836,6 +836,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) to_snake_case basename | Coq | Lean -> basename in + let trait_clause_basename (_varset : StringSet.t) (_clause : trait_clause) : + string = + (* TODO: actually use the clause to derive the name *) + "cl" + in let append_index (basename : string) (i : int) : string = basename ^ string_of_int i in @@ -931,6 +936,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) var_basename; type_var_basename; const_generic_var_basename; + trait_clause_basename; append_index; extract_literal; extract_unop; @@ -1246,16 +1252,18 @@ and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) and extract_generic_args (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 types <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_ty ctx fmt no_params_tys true) - types); - if const_generics <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_const_generic ctx fmt true) - const_generics); + if !backend <> HOL4 then ( + if types <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_ty ctx fmt no_params_tys true) + types); + if const_generics <> [] then ( + assert (!backend <> HOL4); + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_const_generic ctx fmt true) + const_generics)); if trait_refs <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) @@ -1588,6 +1596,93 @@ let extract_comment (fmt : F.formatter) (sl : string list) : unit = F.pp_print_string fmt rd; F.pp_close_box fmt () +let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = + let with_opaque_pre = false in + let trait_name = ctx_get_trait_decl with_opaque_pre clause.trait_id ctx in + F.pp_print_string fmt trait_name; + extract_generic_args ctx fmt no_params_tys clause.generics + +(** Insert a space, if necessary *) +let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = + if !space then space := false else F.pp_print_space fmt () + +let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (use_forall : bool) (as_implicits : bool) + (space : bool ref option) (generics : generic_params) + (type_params : string list) (cg_params : string list) + (trait_clauses : string list) : unit = + let all_params = List.concat [ type_params; cg_params; trait_clauses ] in + (* HOL4 doesn't support const generics *) + assert (cg_params = [] || !backend <> HOL4); + let left_bracket () = + if as_implicits then F.pp_print_string fmt "{" + else F.pp_print_string fmt "(" + in + let right_bracket () = + if as_implicits then F.pp_print_string fmt "}" + else F.pp_print_string fmt ")" + in + let insert_req_space () = + match space with + | None -> F.pp_print_space fmt () + | Some space -> insert_req_space fmt space + in + (* Print the type/const generic parameters *) + if all_params <> [] then ( + if use_forall then ( + insert_req_space (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "forall"); + (* Note that in HOL4 we don't print the type parameters. *) + if !backend <> HOL4 then ( + (* Print the type parameters *) + if type_params <> [] then ( + insert_req_space (); + (* ( *) + left_bracket (); + List.iter + (fun s -> + F.pp_print_string fmt s; + F.pp_print_space fmt ()) + type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()); + (* ) *) + right_bracket ()); + (* Print the const generic parameters *) + List.iter + (fun (var : const_generic_var) -> + insert_req_space (); + (* ( *) + left_bracket (); + let n = ctx_get_const_generic_var var.index ctx in + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_literal_type ctx fmt var.ty; + (* ) *) + right_bracket ()) + generics.const_generics); + (* Print the trait clauses *) + List.iter + (fun (clause : trait_clause) -> + insert_req_space (); + (* ( *) + left_bracket (); + let n = ctx_get_trait_clause_var clause.clause_id ctx in + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt no_params_tys clause; + (* ) *) + right_bracket ()) + generics.trait_clauses) + (** Extract a type declaration. This function is for all type declarations and all backends **at the exception** @@ -1624,7 +1719,6 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let ctx_body, type_params, cg_params, trait_clauses = ctx_add_generic_params def.generics ctx in - let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then F.pp_print_break fmt 0 0; @@ -1644,40 +1738,13 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (match qualif with | Some qualif -> F.pp_print_string fmt (qualif ^ " " ^ def_name) | None -> F.pp_print_string fmt def_name); - (* HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); - (* Print the type/const generic parameters *) - if all_params <> [] && !backend <> HOL4 then ( - if use_forall then ( - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "forall"); - (* Print the type parameters *) - if type_params <> [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - List.iter - (fun s -> - F.pp_print_string fmt s; - F.pp_print_space fmt ()) - type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword () ^ ")")); - (* Print the const generic parameters *) - List.iter - (fun (var : const_generic_var) -> - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - let n = ctx_get_const_generic_var var.index ctx in - F.pp_print_string fmt n; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt var.ty; - F.pp_print_string fmt ")") - def.const_generic_params); + (* HOL4 doesn't support const generics, and type definitions in HOL4 don't + support trait clauses *) + assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); + (* Print the generic parameters *) + let as_implicits = false in + extract_generic_params ctx_body fmt type_decl_group use_forall as_implicits + None def.generics type_params cg_params trait_clauses; (* Print the "=" if we extract the body*) if extract_body then ( F.pp_print_space fmt (); @@ -1737,9 +1804,12 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) let with_opaque_pre = false in let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in (* Generic parameters are unsupported *) - assert (def.const_generic_params = []); + assert (def.generics.const_generics = []); + (* Trait clauses on type definitions are unsupported *) + assert (def.generics.trait_clauses = []); + (* Types *) (* Count the number of parameters *) - let num_params = List.length def.type_params in + let num_params = List.length def.generics.types in (* Generate the declaration *) F.pp_print_space fmt (); F.pp_print_string fmt @@ -1760,8 +1830,7 @@ let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) let with_opaque_pre = false in let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in (* Sanity check *) - assert (def.type_params = []); - assert (def.const_generic_params = []); + assert (def.generics = empty_generic_params); (* Generate the declaration *) F.pp_print_space fmt (); F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); @@ -1801,13 +1870,12 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = assert (!backend = Coq); (* Generating the [Arguments] instructions is useful only if there are type parameters *) - if decl.type_params = [] && decl.const_generic_params = [] then () + if decl.generics.types = [] && decl.generics.const_generics = [] then () else (* Add the type params - note that we need those bindings only for the * body translation (they are not top-level) *) - let _ctx_body, type_params, cg_params = - ctx_add_type_const_generic_params decl.type_params - decl.const_generic_params ctx + let _ctx_body, type_params, cg_params, trait_clauses = + ctx_add_generic_params decl.generics ctx in (* Auxiliary function to extract an [Arguments Cons {T} _ _.] instruction *) let extract_arguments_info (cons_name : string) (fields : 'a list) : unit = @@ -1815,27 +1883,22 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0; (* Open a box *) F.pp_open_hovbox fmt ctx.indent_incr; - (* Small utility *) - let print_vars () = - List.iter - (fun (var : string) -> - F.pp_print_space fmt (); - F.pp_print_string fmt ("{" ^ var ^ "}")) - (List.append type_params cg_params) - in - let print_fields () = - List.iter - (fun _ -> - F.pp_print_space fmt (); - F.pp_print_string fmt "_") - fields - in F.pp_print_break fmt 0 0; F.pp_print_string fmt "Arguments"; F.pp_print_space fmt (); F.pp_print_string fmt cons_name; - print_vars (); - print_fields (); + (* Print the type/const params and the trait clauses (`{T}`) *) + List.iter + (fun (var : string) -> + F.pp_print_space fmt (); + F.pp_print_string fmt ("{" ^ var ^ "}")) + (List.concat [ type_params; cg_params; trait_clauses ]); + (* Print the fields (`_`) *) + List.iter + (fun _ -> + F.pp_print_space fmt (); + F.pp_print_string fmt "_") + fields; F.pp_print_string fmt "."; (* Close the box *) @@ -1888,9 +1951,8 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) let is_rec = decl_is_from_rec_group kind in if is_rec then (* Add the type params *) - let ctx, type_params, cg_params = - ctx_add_type_const_generic_params decl.type_params - decl.const_generic_params ctx + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params decl.generics ctx in let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in @@ -1911,33 +1973,13 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_print_space fmt (); let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in F.pp_print_string fmt field_name; - F.pp_print_space fmt (); - (* Print the type parameters *) - if type_params <> [] then ( - F.pp_print_string fmt "{"; - List.iter - (fun p -> - F.pp_print_string fmt p; - F.pp_print_space fmt ()) - type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type}"; - F.pp_print_space fmt ()); - (* Print the const generic parameters *) - if cg_params <> [] then - List.iter - (fun (v : const_generic_var) -> - F.pp_print_string fmt "{"; - let n = ctx_get_const_generic_var v.index ctx in - F.pp_print_string fmt n; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt v.ty; - F.pp_print_string fmt "}"; - F.pp_print_space fmt ()) - decl.const_generic_params; + (* Print the generics *) + let use_forall = false in + let as_implicits = true in + extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall + as_implicits None decl.generics type_params cg_params trait_clauses; (* Print the record parameter *) + F.pp_print_space fmt (); F.pp_print_string fmt "("; F.pp_print_string fmt record_var; F.pp_print_space fmt (); @@ -2183,11 +2225,11 @@ let extract_adt_g_value (inside : bool) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : extraction_ctx = match ty with - | Adt (Tuple, type_args, cg_args) -> + | Adt (Tuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) - assert (List.length type_args = List.length field_values); - assert (cg_args = []); + assert (List.length generics.types = List.length field_values); + assert (generics.const_generics = [] && generics.trait_refs = []); (* This is very annoying: in Coq, we can't write [()] for the value of type [unit], we have to write [tt]. *) if !backend = Coq && field_values = [] then ( @@ -2205,7 +2247,7 @@ let extract_adt_g_value in F.pp_print_string fmt ")"; ctx) - | Adt (adt_id, _, _) -> + | Adt (adt_id, _) -> (* "Regular" ADT *) (* If we are generating a pattern for a let-binding and we target Lean, @@ -2343,14 +2385,12 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (* Top-level qualifier *) match qualif.id with | FunOrOp fun_id -> - extract_function_call ctx fmt inside fun_id qualif.type_args - qualif.const_generic_args args + extract_function_call ctx fmt inside fun_id qualif.generics args | Global global_id -> extract_global ctx fmt global_id | AdtCons adt_cons_id -> - extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args - qualif.const_generic_args args + extract_adt_cons ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.type_args args) + extract_field_projector ctx fmt inside app proj qualif.generics args) | _ -> (* "Regular" expression *) (* Open parentheses *) @@ -2373,8 +2413,8 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (** Subcase of the app case: function call *) and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (fid : fun_or_op_id) (type_args : ty list) - (cg_args : const_generic list) (args : texpression list) : unit = + (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!). @@ -2396,19 +2436,9 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) let fun_name = ctx_get_function with_opaque_pre fun_id ctx in F.pp_print_string fmt fun_name; (* Sanity check: HOL4 doesn't support const generics *) - assert (cg_args = [] || !backend <> HOL4); - (* Print the type parameters, if the backend is not HOL4 *) - if !backend <> HOL4 then ( - List.iter - (fun ty -> - F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty true ty) - type_args; - List.iter - (fun cg -> - F.pp_print_space fmt (); - extract_const_generic ctx fmt true cg) - cg_args); + assert (generics.const_generics = [] || !backend <> HOL4); + (* Print the generics *) + extract_generic_args ctx fmt TypeDeclId.Set.empty generics; (* Print the arguments *) List.iter (fun ve -> @@ -2430,9 +2460,9 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (** Subcase of the app case: ADT constructor *) and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) - (adt_cons : adt_cons_id) (type_args : ty list) - (cg_args : const_generic list) (args : texpression list) : unit = - let e_ty = Adt (adt_cons.adt_id, type_args, cg_args) in + (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) + : unit = + let e_ty = Adt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = extract_adt_g_value @@ -2446,7 +2476,7 @@ and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (** Subcase of the app case: ADT field projector. *) and extract_field_projector (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (original_app : texpression) (proj : projection) - (_proj_type_params : ty list) (args : texpression list) : unit = + (_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 @@ -2905,11 +2935,11 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) let cs = ctx_get_struct false (Assumed Array) ctx in F.pp_print_string fmt cs; (* Print the parameters *) - let _, tys, cgs = ty_as_adt e_ty in - let ty = Collections.List.to_cons_nil tys in + let _, generics = ty_as_adt e_ty in + let ty = Collections.List.to_cons_nil generics.types in F.pp_print_space fmt (); extract_ty ctx fmt TypeDeclId.Set.empty true ty; - let cg = Collections.List.to_cons_nil cgs in + let cg = Collections.List.to_cons_nil generics.const_generics in F.pp_print_space fmt (); extract_const_generic ctx fmt true cg; F.pp_print_space fmt (); @@ -2936,10 +2966,6 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt () | _ -> raise (Failure "Unreachable") -(** Insert a space, if necessary *) -let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = - if !space then space := false else F.pp_print_space fmt () - (** A small utility to print the parameters of a function signature. We return two contexts: @@ -2947,6 +2973,8 @@ let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = - the context augmented with bindings for the type parameters *and* bindings for the input values + We also return names for the type parameters, const generics, etc. + TODO: do we really need the first one? We should probably always use the second one. It comes from the fact that when we print the input values for the @@ -2954,57 +2982,22 @@ let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = patterns, not the variables). We should figure a cleaner way. *) let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) - (fmt : F.formatter) (def : fun_decl) : extraction_ctx * extraction_ctx = + (fmt : F.formatter) (def : fun_decl) : + extraction_ctx * extraction_ctx * string list = (* Add the type parameters - note that we need those bindings only for the * body translation (they are not top-level) *) - let ctx, type_params, cg_params = - ctx_add_type_const_generic_params def.signature.type_params - def.signature.const_generic_params ctx + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params def.signature.generics ctx in - (* Print the parameters - rem.: we should have filtered the functions - * with no input parameters *) - (* The type parameters. - - Note that in HOL4 we don't print the type parameters. - *) - if (type_params <> [] || cg_params <> []) && !backend <> HOL4 then ( - (* Open a box for the type and const generic parameters *) - F.pp_open_hovbox fmt 0; - (* The type parameters *) - if type_params <> [] then ( - insert_req_space fmt space; - F.pp_print_string fmt "("; - List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in - F.pp_print_string fmt pname; - F.pp_print_space fmt ()) - def.signature.type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - let type_keyword = - match !backend with - | FStar -> "Type0" - | Coq | Lean -> "Type" - | HOL4 -> raise (Failure "Unreachable") - in - F.pp_print_string fmt (type_keyword ^ ")")); - (* The const generic parameters *) - if cg_params <> [] then - List.iter - (fun (p : const_generic_var) -> - let pname = ctx_get_const_generic_var p.index ctx in - insert_req_space fmt space; - F.pp_print_string fmt "("; - F.pp_print_string fmt pname; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt p.ty; - F.pp_print_string fmt ")") - def.signature.const_generic_params; - (* Close the box for the type parameters *) - F.pp_close_box fmt ()); + (* Print the generics *) + (* Open a box for the generics *) + F.pp_open_hovbox fmt 0; + let use_forall = false in + let as_implicits = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits + (Some space) 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 *) let ctx_body = match def.body with @@ -3027,7 +3020,7 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) ctx) ctx body.inputs_lvs in - (ctx, ctx_body) + (ctx, ctx_body, List.concat [ type_params; cg_params; trait_clauses ]) (** A small utility to print the types of the input parameters in the form: [u32 -> list u32 -> ...] @@ -3096,7 +3089,7 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) F.pp_print_space fmt (); (* Extract the parameters *) let space = ref true in - let _, _ = extract_fun_parameters space ctx fmt def in + let _, _, _ = extract_fun_parameters space ctx fmt def in insert_req_space fmt space; F.pp_print_string fmt ":"; (* Print the signature *) @@ -3158,7 +3151,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) F.pp_print_space fmt (); (* Extract the parameters *) let space = ref true in - let _, ctx_body = extract_fun_parameters space ctx fmt def in + let _, ctx_body, _ = extract_fun_parameters space ctx fmt def in (* Print the ":=" *) F.pp_print_space fmt (); F.pp_print_string fmt ":="; @@ -3298,9 +3291,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) *) let is_opaque_coq = !backend = Coq && is_opaque in let use_forall = - is_opaque_coq - && (def.signature.type_params <> [] - || def.signature.const_generic_params <> []) + is_opaque_coq && def.signature.generics <> empty_generic_params in (* Print the qualifier ("assume", etc.). @@ -3326,7 +3317,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open a box for "(PARAMS) :" *) F.pp_open_hovbox fmt 0; let space = ref true in - let ctx, ctx_body = extract_fun_parameters space ctx fmt def in + let ctx, ctx_body, all_params = extract_fun_parameters space ctx fmt def in (* Print the return type - note that we have to be careful when * printing the input values for the decrease clause, because * it introduces bindings in the context... We thus "forget" @@ -3374,20 +3365,13 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* The name of the decrease clause *) let decr_name = ctx_get_termination_measure def.def_id def.loop_id ctx in F.pp_print_string fmt decr_name; - (* Print the type/const generic parameters - TODO: we do this many + (* Print the generic parameters - TODO: we do this many times, we should have a helper to factor it out *) List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in - F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.type_params; - List.iter - (fun (p : const_generic_var) -> - let pname = ctx_get_const_generic_var p.index ctx in + (fun (name : string) -> F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.const_generic_params; + F.pp_print_string fmt name) + all_params; (* Print the input values: we have to be careful here to print * only the input values which are in common with the *forward* * function (the additional input values "given back" to the @@ -3474,19 +3458,12 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for [DECREASES] *) F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt terminates_name; - (* Print the type/const generic params - TODO: factor out *) + (* Print the generic params - TODO: factor out *) List.iter - (fun (p : type_var) -> - let pname = ctx_get_type_var p.index ctx in + (fun (name : string) -> F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.type_params; - List.iter - (fun (p : const_generic_var) -> - let pname = ctx_get_const_generic_var p.index ctx in - F.pp_print_space fmt (); - F.pp_print_string fmt pname) - def.signature.const_generic_params; + F.pp_print_string fmt name) + all_params; (* Print the variables *) List.iter (fun v -> @@ -3544,13 +3521,10 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) ctx_get_local_function with_opaque_pre def.def_id def.loop_id def.back_id ctx in - assert (def.signature.const_generic_params = []); + assert (def.signature.generics.const_generics = []); (* 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, _, _ = - ctx_add_type_const_generic_params def.signature.type_params - def.signature.const_generic_params ctx - in + let ctx, _, _, _ = ctx_add_generic_params def.signature.generics ctx in (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0; (* Open a box for the whole definition *) @@ -3726,10 +3700,9 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = assert body.is_global_decl_body; assert (Option.is_none body.back_id); - assert (List.length body.signature.inputs = 0); + assert (body.signature.inputs = []); assert (List.length body.signature.doutputs = 1); - assert (List.length body.signature.type_params = 0); - assert (List.length body.signature.const_generic_params = 0); + assert (body.signature.generics = empty_generic_params); (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; @@ -3799,8 +3772,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) (* Check if this is a unit function *) let sg = def.signature in if - sg.type_params = [] - && sg.const_generic_params = [] + sg.generics = empty_generic_params && (sg.inputs = [ mk_unit_ty ] || sg.inputs = []) && sg.output = mk_result_ty mk_unit_ty then ( diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 96ecfd42..2c704d3e 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -111,10 +111,10 @@ let decl_is_first_from_group (kind : decl_kind) : bool = let decl_is_not_last_from_group (kind : decl_kind) : bool = not (decl_is_last_from_group kind) -(* TODO: this should a module we give to a functor! *) - type type_decl_kind = Enum | Struct +(* TODO: this should be a module we give to a functor! *) + (** A formatter's role is twofold: 1. Come up with name suggestions. For instance, provided some information about a function (its basename, @@ -125,6 +125,9 @@ type type_decl_kind = Enum | Struct snake case, adding prefixes/suffixes, etc. 2. Format some specific terms, like constants. + + TODO: unclear that this is useful now that all the backends are so much + entangled in Extract.ml *) type formatter = { bool_name : string; @@ -288,6 +291,13 @@ type formatter = { (** Generates a type variable basename. *) const_generic_var_basename : StringSet.t -> string -> string; (** Generates a const generic variable basename. *) + trait_clause_basename : StringSet.t -> trait_clause -> string; + (** Return a base name for a trait clause. We might add a suffix to prevent + collisions. + + In the traduction we explicitely manipulate the trait clause instances, + that is we introduce one input variable for each trait clause. + *) append_index : string -> int -> string; (** Appends an index to a name - we use this to generate unique names: when doing so, the role of the formatter is just to concatenate @@ -396,6 +406,9 @@ type id = | TypeVarId of TypeVarId.id | ConstGenericVarId of ConstGenericVarId.id | VarId of VarId.id + | TraitDeclId of TraitDeclId.id + | TraitImplId of TraitImplId.id + | TraitClauseId of TraitClauseId.id | UnknownId (** Used for stored various strings like keywords, definitions which should always be in context, etc. and which can't be linked to one @@ -718,6 +731,9 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | ConstGenericVarId id -> "const_generic_var_id: " ^ ConstGenericVarId.to_string id | VarId id -> "var_id: " ^ VarId.to_string id + | TraitDeclId id -> "trait_decl_id: " ^ TraitDeclId.to_string id + | TraitImplId id -> "trait_impl_id: " ^ TraitImplId.to_string id + | TraitClauseId id -> "trait_clause_id: " ^ TraitClauseId.to_string id (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = @@ -787,6 +803,14 @@ let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = let is_opaque = false in ctx_get_type is_opaque (Assumed id) ctx +let ctx_get_trait_decl (with_opaque_pre : bool) (id : trait_decl_id) + (ctx : extraction_ctx) : string = + ctx_get with_opaque_pre (TraitDeclId id) ctx + +let ctx_get_trait_impl (with_opaque_pre : bool) (id : trait_impl_id) + (ctx : extraction_ctx) : string = + ctx_get with_opaque_pre (TraitImplId id) ctx + let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = let is_opaque = false in ctx_get is_opaque (VarId id) ctx @@ -800,6 +824,11 @@ let ctx_get_const_generic_var (id : ConstGenericVarId.id) (ctx : extraction_ctx) let is_opaque = false in ctx_get is_opaque (ConstGenericVarId id) ctx +let ctx_get_trait_clause_var (id : TraitClauseId.id) (ctx : extraction_ctx) : + string = + let is_opaque = false in + ctx_get is_opaque (TraitClauseId id) ctx + let ctx_get_field (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = let is_opaque = false in @@ -865,6 +894,16 @@ let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : let ctx = ctx_add is_opaque (VarId id) name ctx in (ctx, name) +(** Generate a unique trait clause name and add it to the context *) +let ctx_add_trait_clause (basename : string) (id : TraitClauseId.id) + (ctx : extraction_ctx) : extraction_ctx * string = + let is_opaque = false in + let name = + basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + in + let ctx = ctx_add is_opaque (TraitClauseId id) name ctx in + (ctx, name) + (** See {!ctx_add_var} *) let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : extraction_ctx * string list = @@ -890,7 +929,9 @@ let ctx_add_const_generic_params (vars : const_generic_var list) let ctx_add_trait_clauses (clauses : trait_clause list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map - (fun ctx (c : trait_clause) -> ctx_add_trait_clause c ctx) + (fun ctx (c : trait_clause) -> + let basename = ctx.fmt.trait_clause_basename ctx.names_map.names_set c in + ctx_add_trait_clause basename c.clause_id ctx) ctx clauses (** Returns the lists of names for: -- cgit v1.2.3 From 4cf1217f593b46a17130403df85b5f39f9e3eb85 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 10:04:14 +0200 Subject: Improve the collision detection --- compiler/ExtractBase.ml | 70 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 16 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 2c704d3e..02ff266e 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -458,21 +458,34 @@ type names_map = { *) } -let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) - (name : string) (nm : names_map) : names_map = - (* Check if there is a clash *) - (match StringMap.find_opt name nm.name_to_id with +(** Small helper to report name collision *) +let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) + (name : string) : unit = + let id1 = "\n- " ^ id_to_string id1 in + let id2 = "\n- " ^ id_to_string id2 in + let err = + "Name clash detected: the following identifiers are bound to the same name \ + \"" ^ name ^ "\":" ^ id1 ^ id2 + ^ "\nYou may want to rename some of your definitions, or report an issue." + in + log#serror err; + raise (Failure err) + +let names_map_get_id_from_name (name : string) (nm : names_map) : id option = + StringMap.find_opt name nm.name_to_id + +let names_map_check_collision (id_to_string : id -> string) (id : id) + (name : string) (nm : names_map) : unit = + match names_map_get_id_from_name name nm with | None -> () (* Ok *) | Some clash -> (* There is a clash: print a nice debugging message for the user *) - let id1 = "\n- " ^ id_to_string clash in - let id2 = "\n- " ^ id_to_string id in - let err = - "Name clash detected: the following identifiers are bound to the same \ - name \"" ^ name ^ "\":" ^ id1 ^ id2 - in - log#serror err; - raise (Failure err)); + report_name_collision id_to_string clash id name + +let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) + (name : string) (nm : names_map) : names_map = + (* Check if there is a clash *) + names_map_check_collision id_to_string id name nm; (* Sanity check *) assert (not (StringSet.mem name nm.names_set)); (* Insert *) @@ -743,17 +756,42 @@ let allow_collisions (id : id) : bool = let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - (* We do not use the same name map if we allow/disallow collisions *) + (* The id_to_string function to print nice debugging messages if there are + * collisions *) + let id_to_string (id : id) : string = id_to_string id ctx in + (* We do not use the same name map if we allow/disallow collisions. + We notably use it for field names: some backends like Lean can use the + type information to disambiguate field projections. + + Remark: what we do is actually subtle. Taking the example of fields: + - we allow fields from different ADT definitions to collide + - we do *not* allow field names to collide with other names + For instance, we don't allow naming a field "let". We enforce this by + not checking collision between ids for which we permit collisions (ex.: + between fields), but still checking collisions between those ids and the + others (ex.: fields and keywords). + *) if allow_collisions id then ( assert (not is_opaque); + (* Check with the other ids *) + names_map_check_collision id_to_string id name ctx.names_map; { ctx with unsafe_names_map = unsafe_names_map_add id name ctx.unsafe_names_map; }) else - (* The id_to_string function to print nice debugging messages if there are - * collisions *) - let id_to_string (id : id) : string = id_to_string id ctx in + (* Remark: we don't check that there are no collisions with the unsafe ids. + Importantly, we don't want some safe ids like keywords to clash with + unsafe ids like fields names. For this, we leverage the fact that we register + keywords *first*, then unsafe ids (meaning the clash will be detected with + the check in the other branch of the if ... then ... else ..., and we do + have to check for all possible collisions, which may be slightly too + restrictive). + + TODO: this is a bit hacky, we might want to improve the way we detect + clashes by being more precise. Overall, there is only an issue with + field names which are allowed to clash with each other. + *) let names_map = names_map_add id_to_string is_opaque id name ctx.names_map in -- cgit v1.2.3 From 0cafb31dd42c95f22e0b6680531c27fa0508e376 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 13:32:43 +0200 Subject: Make progress on the extraction --- compiler/AssociatedTypes.ml | 10 +++--- compiler/Extract.ml | 76 +++++++++++++++++++++++++++++---------------- compiler/ExtractBase.ml | 57 ++++++++++++++++++++++++++++------ compiler/PrintPure.ml | 4 +-- compiler/Pure.ml | 16 ++++++++-- compiler/SymbolicToPure.ml | 27 ++++++++++++---- 6 files changed, 138 insertions(+), 52 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 07ab70bd..c4a9538d 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -100,7 +100,7 @@ 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 - | ParentClause (id, _) | ItemClause (id, _, _) -> + | ParentClause (id, _, _) | ItemClause (id, _, _, _) -> trait_instance_id_is_local_clause id (** About the conversion functions: for now we need them (TODO: merge ety, rty, etc.), @@ -212,14 +212,14 @@ and ctx_normalize_trait_instance_id : (id, None) | Clause _ -> (id, None) | BuiltinOrAuto _ -> (id, None) - | ParentClause (inst_id, clause_id) -> ( + | ParentClause (inst_id, decl_id, clause_id) -> ( let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in (* Check if the inst_id refers to a specific implementation, if yes project *) match impl with | None -> (* This is actually a local clause *) assert (trait_instance_id_is_local_clause inst_id); - (ParentClause (inst_id, clause_id), None) + (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the parent clause by doing the following: {[ @@ -243,14 +243,14 @@ and ctx_normalize_trait_instance_id : (* Sanity check: the clause necessarily refers to an impl *) let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in (TraitRef clause, Some clause)) - | ItemClause (inst_id, item_name, clause_id) -> ( + | ItemClause (inst_id, decl_id, item_name, clause_id) -> ( let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in (* Check if the inst_id refers to a specific implementation, if yes project *) match impl with | None -> (* This is actually a local clause *) assert (trait_instance_id_is_local_clause inst_id); - (ParentClause (inst_id, clause_id), None) + (ParentClause (inst_id, decl_id, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: {[ diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 3c4feca5..ad89a59e 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1223,23 +1223,29 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) if inside then F.pp_print_string fmt ")" | TraitType (trait_ref, generics, type_name) -> if !parameterize_trait_types then raise (Failure "Unimplemented") - else ( + else if trait_ref.trait_id <> Self then ( (* HOL4 doesn't have 1st class types *) assert (!backend <> HOL4); - if trait_ref.trait_id <> Self then ( - F.pp_print_string fmt "("; - extract_trait_ref ctx fmt no_params_tys false trait_ref; - extract_generic_args ctx fmt no_params_tys generics; - (* TODO: lookup the type name *) - F.pp_print_string fmt (")." ^ type_name)) - else - (* Can only happen when extracting the signature of a trait method - *declaration*. If extracting items for a trait method implementation, - the type should have been normalized. For trait method declarations - we directly reference the item. *) - let trait_decl_id = Option.get ctx.trait_decl_id in - assert (generics = empty_generic_args); - F.pp_print_string fmt type_name) + let use_brackets = generics <> empty_generic_args in + if use_brackets then F.pp_print_string fmt "("; + extract_trait_ref ctx fmt no_params_tys false trait_ref; + extract_generic_args ctx fmt no_params_tys generics; + let name = + ctx_get_trait_assoc_type trait_ref.trait_decl_ref.trait_decl_id + type_name ctx + in + if use_brackets then F.pp_print_string fmt ")"; + F.pp_print_string fmt ("." ^ name)) + else + (* Can only happen when extracting the signature of a trait method + *declaration* or a provided trait method (for a declaration). + If extracting items for a trait method implementation, + the type should have been normalized. For trait method declarations + we directly reference the item. *) + assert (ctx.trait_decl_id <> None); + assert (generics = empty_generic_args); + let name = ctx_get_local_trait_assoc_type type_name ctx in + F.pp_print_string fmt name and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = @@ -1270,17 +1276,35 @@ and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) (extract_trait_ref ctx fmt no_params_tys true) trait_refs) -and extract_trait_instance_id (_ctx : extraction_ctx) (_fmt : F.formatter) - (_no_params_tys : TypeDeclId.Set.t) (_inside : bool) - (id : trait_instance_id) : unit = +and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) + : unit = + let with_opaque_pre = false in match id with - | Self -> raise (Failure "TODO") - | TraitImpl _ -> raise (Failure "TODO") - | Clause _ -> raise (Failure "TODO") - | ParentClause _ -> raise (Failure "TODO") - | ItemClause _ -> raise (Failure "TODO") - | TraitRef _ -> raise (Failure "TODO") - | UnknownTrait _ -> raise (Failure "TODO") + | Self -> + (* This has specific treatment depending on the item we're extracting + (associated type, etc.). We should have caught this elsewhere. *) + raise (Failure "Unexpected") + | TraitImpl id -> + let name = ctx_get_trait_impl with_opaque_pre id ctx in + F.pp_print_string fmt name + | Clause id -> + let name = ctx_get_local_trait_clause id ctx in + F.pp_print_string fmt name + | ParentClause (inst_id, decl_id, clause_id) -> + (* Use the trait decl id to lookup the name *) + let name = ctx_get_trait_parent_clause decl_id clause_id ctx in + extract_trait_instance_id ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt ("." ^ 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 decl_id item_name clause_id ctx in + extract_trait_instance_id ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt ("." ^ name) + | TraitRef trait_ref -> extract_trait_ref ctx fmt no_params_tys true trait_ref + | UnknownTrait _ -> + (* This is an error case *) + raise (Failure "Unexpected") (** Compute the names for all the top-level identifiers used in a type definition (type name, variant names, field names, etc. but not type @@ -1673,7 +1697,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) insert_req_space (); (* ( *) left_bracket (); - let n = ctx_get_trait_clause_var clause.clause_id ctx in + let n = ctx_get_local_trait_clause clause.clause_id ctx in F.pp_print_string fmt n; F.pp_print_space fmt (); F.pp_print_string fmt ":"; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 02ff266e..697b1027 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -408,7 +408,11 @@ type id = | VarId of VarId.id | TraitDeclId of TraitDeclId.id | TraitImplId of TraitImplId.id - | TraitClauseId of TraitClauseId.id + | LocalTraitClauseId of TraitClauseId.id + | LocalTraitAssocTypeId of string (** Specifically for: [Self::Ty] *) + | TraitAssocTypeId of TraitDeclId.id * string (** A trait associated type *) + | TraitParentClauseId of TraitDeclId.id * TraitClauseId.id + | TraitItemClauseId of TraitDeclId.id * string * TraitClauseId.id | UnknownId (** Used for stored various strings like keywords, definitions which should always be in context, etc. and which can't be linked to one @@ -746,7 +750,20 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | VarId id -> "var_id: " ^ VarId.to_string id | TraitDeclId id -> "trait_decl_id: " ^ TraitDeclId.to_string id | TraitImplId id -> "trait_impl_id: " ^ TraitImplId.to_string id - | TraitClauseId id -> "trait_clause_id: " ^ TraitClauseId.to_string id + | LocalTraitClauseId id -> + "local_trait_clause_id: " ^ TraitClauseId.to_string id + | LocalTraitAssocTypeId type_name -> "local_trait_assoc_type_id: " ^ type_name + | TraitParentClauseId (id, clause_id) -> + "trait_parent_clause_id: decl_id:" ^ TraitDeclId.to_string id + ^ ", clause_id: " + ^ TraitClauseId.to_string clause_id + | TraitItemClauseId (id, item_name, clause_id) -> + "trait_item_clause_id: decl_id:" ^ TraitDeclId.to_string id + ^ ", item name: " ^ item_name ^ ", clause_id: " + ^ TraitClauseId.to_string clause_id + | TraitAssocTypeId (id, type_name) -> + "trait_assoc_type_id: decl_id:" ^ TraitDeclId.to_string id + ^ ", type name: " ^ type_name (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = @@ -849,6 +866,26 @@ let ctx_get_trait_impl (with_opaque_pre : bool) (id : trait_impl_id) (ctx : extraction_ctx) : string = ctx_get with_opaque_pre (TraitImplId id) ctx +let ctx_get_trait_assoc_type (id : trait_decl_id) (type_name : string) + (ctx : extraction_ctx) : string = + let is_opaque = false in + ctx_get is_opaque (TraitAssocTypeId (id, type_name)) ctx + +let ctx_get_local_trait_assoc_type (type_name : string) (ctx : extraction_ctx) : + string = + let is_opaque = false in + ctx_get is_opaque (LocalTraitAssocTypeId type_name) ctx + +let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) + (ctx : extraction_ctx) : string = + let with_opaque_pre = false in + ctx_get with_opaque_pre (TraitParentClauseId (id, clause)) ctx + +let ctx_get_trait_item_clause (id : trait_decl_id) (item : string) + (clause : trait_clause_id) (ctx : extraction_ctx) : string = + let with_opaque_pre = false in + ctx_get with_opaque_pre (TraitItemClauseId (id, item, clause)) ctx + let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = let is_opaque = false in ctx_get is_opaque (VarId id) ctx @@ -862,10 +899,10 @@ let ctx_get_const_generic_var (id : ConstGenericVarId.id) (ctx : extraction_ctx) let is_opaque = false in ctx_get is_opaque (ConstGenericVarId id) ctx -let ctx_get_trait_clause_var (id : TraitClauseId.id) (ctx : extraction_ctx) : +let ctx_get_local_trait_clause (id : TraitClauseId.id) (ctx : extraction_ctx) : string = let is_opaque = false in - ctx_get is_opaque (TraitClauseId id) ctx + ctx_get is_opaque (LocalTraitClauseId id) ctx let ctx_get_field (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = @@ -933,13 +970,13 @@ let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : (ctx, name) (** Generate a unique trait clause name and add it to the context *) -let ctx_add_trait_clause (basename : string) (id : TraitClauseId.id) +let ctx_add_local_trait_clause (basename : string) (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = let is_opaque = false in let name = basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename in - let ctx = ctx_add is_opaque (TraitClauseId id) name ctx in + let ctx = ctx_add is_opaque (LocalTraitClauseId id) name ctx in (ctx, name) (** See {!ctx_add_var} *) @@ -964,12 +1001,12 @@ let ctx_add_const_generic_params (vars : const_generic_var list) ctx_add_const_generic_var var.name var.index ctx) ctx vars -let ctx_add_trait_clauses (clauses : trait_clause list) (ctx : extraction_ctx) : - extraction_ctx * string list = +let ctx_add_local_trait_clauses (clauses : trait_clause list) + (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (c : trait_clause) -> let basename = ctx.fmt.trait_clause_basename ctx.names_map.names_set c in - ctx_add_trait_clause basename c.clause_id ctx) + ctx_add_local_trait_clause basename c.clause_id ctx) ctx clauses (** Returns the lists of names for: @@ -982,7 +1019,7 @@ let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : let { types; const_generics; trait_clauses } = generics in let ctx, tys = ctx_add_type_params types ctx in let ctx, cgs = ctx_add_const_generic_params const_generics ctx in - let ctx, tcs = ctx_add_trait_clauses trait_clauses ctx in + let ctx, tcs = ctx_add_local_trait_clauses trait_clauses ctx in (ctx, tys, cgs, tcs) let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 77d25823..fc39074d 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -273,11 +273,11 @@ and trait_instance_id_to_string (fmt : type_formatter) (inside : bool) | Self -> "Self" | TraitImpl id -> fmt.trait_impl_id_to_string id | Clause id -> fmt.trait_clause_id_to_string id - | ParentClause (inst_id, clause_id) -> + | ParentClause (inst_id, _decl_id, clause_id) -> let inst_id = trait_instance_id_to_string fmt false inst_id in let clause_id = fmt.trait_clause_id_to_string clause_id in "parent(" ^ inst_id ^ ")::" ^ clause_id - | ItemClause (inst_id, item_name, clause_id) -> + | ItemClause (inst_id, _decl_id, item_name, clause_id) -> let inst_id = trait_instance_id_to_string fmt false inst_id in let clause_id = fmt.trait_clause_id_to_string clause_id in "(" ^ inst_id ^ ")::" ^ item_name ^ "::[" ^ clause_id ^ "]" diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 272ec328..725f71ad 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -276,7 +276,16 @@ type ty = | TraitType of trait_ref * generic_args * string (** The string is for the name of the associated type *) -and trait_ref = { trait_id : trait_instance_id; generics : generic_args } +and trait_ref = { + trait_id : trait_instance_id; + generics : generic_args; + trait_decl_ref : trait_decl_ref; +} + +and trait_decl_ref = { + trait_decl_id : trait_decl_id; + decl_generics : generic_args; (* The name: annoying field collisions... *) +} and generic_args = { types : ty list; @@ -288,8 +297,9 @@ and trait_instance_id = | Self | TraitImpl of trait_impl_id | Clause of trait_clause_id - | ParentClause of trait_instance_id * trait_clause_id - | ItemClause of trait_instance_id * trait_item_name * trait_clause_id + | ParentClause of trait_instance_id * trait_decl_id * trait_clause_id + | ItemClause of + trait_instance_id * trait_decl_id * trait_item_name * trait_clause_id | TraitRef of trait_ref | UnknownTrait of string [@@deriving diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index c827475b..166f08a0 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -393,7 +393,15 @@ and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : trait_ref = let trait_id = translate_trait_instance_id translate_ty tr.trait_id in let generics = translate_generic_args translate_ty tr.generics in - { trait_id; generics } + let trait_decl_ref = + translate_trait_decl_ref translate_ty tr.trait_decl_ref + in + { trait_id; generics; trait_decl_ref } + +and translate_trait_decl_ref (translate_ty : 'r T.ty -> ty) + (tr : 'r T.trait_decl_ref) : trait_decl_ref = + let decl_generics = translate_generic_args translate_ty tr.decl_generics in + { trait_decl_id = tr.trait_decl_id; decl_generics } and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) (id : 'r T.trait_instance_id) : trait_instance_id = @@ -405,12 +413,12 @@ and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) (* We should have eliminated those in the prepasses *) raise (Failure "Unreachable") | Clause id -> Clause id - | ParentClause (inst_id, clause_id) -> + | ParentClause (inst_id, decl_id, clause_id) -> let inst_id = translate_trait_instance_id inst_id in - ParentClause (inst_id, clause_id) - | ItemClause (inst_id, item_name, clause_id) -> + ParentClause (inst_id, decl_id, clause_id) + | ItemClause (inst_id, decl_id, item_name, clause_id) -> let inst_id = translate_trait_instance_id inst_id in - ItemClause (inst_id, item_name, clause_id) + ItemClause (inst_id, decl_id, item_name, clause_id) | TraitRef tr -> TraitRef (translate_trait_ref translate_ty tr) | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) @@ -2644,7 +2652,14 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let trait_refs = List.map (fun (c : trait_clause) -> - { trait_id = Clause c.clause_id; generics = empty_generic_args }) + let trait_decl_ref = + { trait_decl_id = c.trait_id; decl_generics = empty_generic_args } + in + { + trait_id = Clause c.clause_id; + generics = empty_generic_args; + trait_decl_ref; + }) trait_clauses in { types; const_generics; trait_refs } -- cgit v1.2.3 From b42c0a8fa4708d6bf8424d63b6a7fe4964ba0e3d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 15:18:36 +0200 Subject: Make progress on the extraction --- compiler/Extract.ml | 13 +++++- compiler/Pure.ml | 44 ++++++++++++++++++ compiler/PureMicroPasses.ml | 8 +++- compiler/SymbolicToPure.ml | 110 +++++++++++++++++++++++++++++++++++++++++++- compiler/Translate.ml | 109 ++++++++++++++++++++++++++++++++++++------- compiler/TranslateCore.ml | 1 + 6 files changed, 264 insertions(+), 21 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ad89a59e..e07305f1 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1301,7 +1301,8 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) let name = ctx_get_trait_item_clause decl_id item_name clause_id ctx in extract_trait_instance_id ctx fmt no_params_tys true inst_id; F.pp_print_string fmt ("." ^ name) - | TraitRef trait_ref -> extract_trait_ref ctx fmt no_params_tys true trait_ref + | TraitRef trait_ref -> + extract_trait_ref ctx fmt no_params_tys inside trait_ref | UnknownTrait _ -> (* This is an error case *) raise (Failure "Unexpected") @@ -3774,6 +3775,16 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break to insert lines between declarations *) F.pp_print_break fmt 0 0 +(** Extract a trait declaration *) +let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) + (trait_decl : trait_decl) : unit = + raise (Failure "TODO") + +(** Extract a trait implementation *) +let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) + (trait_impl : trait_impl) : unit = + raise (Failure "TODO") + (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 725f71ad..6c9f41f1 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -45,6 +45,8 @@ type trait_decl_id = T.trait_decl_id [@@deriving show, ord] type trait_impl_id = T.trait_impl_id [@@deriving show, ord] 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] (** The assumed types for the pure AST. @@ -361,11 +363,23 @@ type generic_params = { } [@@deriving show] +type trait_type_constraint = { + trait_ref : trait_ref; + generics : generic_args; + type_name : trait_item_name; + ty : ty; +} +[@@deriving show] + +type predicates = { trait_type_constraints : trait_type_constraint list } +[@@deriving show] + type type_decl = { def_id : TypeDeclId.id; name : name; generics : generic_params; kind : type_decl_kind; + preds : predicates; } [@@deriving show] @@ -881,6 +895,7 @@ type fun_sig_info = { type fun_sig = { generics : generic_params; (** TODO: we should analyse the signature to make the type parameters implicit whenever possible *) + preds : predicates; inputs : ty list; (** The types of the inputs. @@ -952,8 +967,11 @@ type fun_body = { } [@@deriving show] +type fun_kind = A.fun_kind [@@deriving show] + type fun_decl = { def_id : FunDeclId.id; + kind : fun_kind; num_loops : int; (** The number of loops in the parent forward function (basically the number of loops appearing in the original Rust functions, unless some loops are @@ -973,3 +991,29 @@ type fun_decl = { body : fun_body option; } [@@deriving show] + +type trait_decl = { + def_id : trait_decl_id; + name : name; + generics : generic_params; + preds : predicates; + all_trait_clauses : trait_clause list; + 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; +} +[@@deriving show] + +type trait_impl = { + def_id : trait_impl_id; + name : name; + impl_trait : trait_decl_ref; + generics : generic_params; + preds : predicates; + consts : (trait_item_name * (ty * global_decl_id)) list; + types : (trait_item_name * (trait_ref list * ty)) list; + required_methods : (trait_item_name * fun_decl_id) list; + provided_methods : (trait_item_name * fun_decl_id) list; +} +[@@deriving show] diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 45e4ea98..93609695 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1355,6 +1355,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_sig = { generics = fun_sig.generics; + preds = fun_sig.preds; inputs = inputs_tys; output; doutputs; @@ -1419,6 +1420,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_def = { def_id = def.def_id; + kind = def.kind; num_loops; loop_id = Some loop.loop_id; back_id = def.back_id; @@ -2135,7 +2137,9 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : let num_filtered = List.length (List.filter (fun b -> not b) used_info) in - let { generics; inputs; output; doutputs; info } = decl.signature in + let { generics; preds; inputs; output; doutputs; info } = + decl.signature + in let { has_fuel; num_fwd_inputs_with_fuel_no_state; @@ -2161,7 +2165,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : effect_info; } in - let signature = { generics; inputs; output; doutputs; info } in + let signature = { generics; preds; inputs; output; doutputs; info } in { decl with signature } in diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 166f08a0..1a981de1 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -4,6 +4,7 @@ open Pure open PureUtils module Id = Identifiers module C = Contexts +module A = LlbcAst module S = SymbolicAst module TA = TypesAnalysis module L = Logging @@ -473,6 +474,20 @@ let translate_trait_clause (clause : T.trait_clause) : trait_clause = let generics = translate_sgeneric_args generics in { clause_id; trait_id; generics } +let translate_strait_type_constraint (ttc : T.strait_type_constraint) : + trait_type_constraint = + let { T.trait_ref; generics; type_name; ty } = ttc in + let trait_ref = translate_strait_ref trait_ref in + let generics = translate_sgeneric_args generics in + let ty = translate_sty ty in + { trait_ref; generics; type_name; ty } + +let translate_predicates (preds : T.predicates) : predicates = + let trait_type_constraints = + List.map translate_strait_type_constraint preds.trait_type_constraints + in + { trait_type_constraints } + let translate_generic_params (generics : T.generic_params) : generic_params = let { T.regions = _; types; const_generics; trait_clauses } = generics in let trait_clauses = List.map translate_trait_clause trait_clauses in @@ -515,7 +530,8 @@ let translate_type_decl (def : T.type_decl) : type_decl = let trait_clauses = List.map translate_trait_clause trait_clauses in let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.T.kind in - { def_id; name; generics; kind } + let preds = translate_predicates def.preds in + { def_id; name; generics; kind; preds } let translate_type_id (id : T.type_id) : type_id = match id with @@ -952,7 +968,8 @@ let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) effect_info; } in - let sg = { generics; inputs; output; doutputs; info } in + let preds = translate_predicates sg.A.preds in + let sg = { generics; preds; inputs; output; doutputs; info } in { sg; output_names } let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = @@ -2932,6 +2949,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let def = { def_id; + kind = def.kind; num_loops; loop_id; back_id = bid; @@ -3002,3 +3020,91 @@ let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) List.fold_left (fun m (id, sg) -> RegularFunIdNotLoopMap.add id sg m) RegularFunIdNotLoopMap.empty translated + +let translate_trait_decl (type_infos : TA.type_infos) + (trait_decl : A.trait_decl) : trait_decl = + let { + A.def_id; + name; + generics; + preds; + all_trait_clauses; + consts; + types; + required_methods; + provided_methods; + } = + trait_decl + in + let generics = translate_generic_params generics in + let preds = translate_predicates preds in + let all_trait_clauses = List.map translate_trait_clause all_trait_clauses in + let consts = + List.map + (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) + consts + in + let types = + List.map + (fun (name, (trait_clauses, ty)) -> + ( name, + ( List.map translate_trait_clause trait_clauses, + Option.map (translate_fwd_ty type_infos) ty ) )) + types + in + { + def_id; + name; + generics; + preds; + all_trait_clauses; + consts; + types; + required_methods; + provided_methods; + } + +let translate_trait_impl (type_infos : TA.type_infos) + (trait_impl : A.trait_impl) : trait_impl = + let { + A.def_id; + name; + impl_trait; + generics; + preds; + consts; + types; + required_methods; + provided_methods; + } = + trait_impl + in + let impl_trait = + translate_trait_decl_ref (translate_fwd_ty type_infos) impl_trait + in + let generics = translate_generic_params generics in + let preds = translate_predicates preds in + let consts = + List.map + (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) + consts + in + let types = + List.map + (fun (name, (trait_refs, ty)) -> + ( name, + ( List.map (translate_fwd_trait_ref type_infos) trait_refs, + translate_fwd_ty type_infos ty ) )) + types + in + { + def_id; + name; + impl_trait; + generics; + preds; + consts; + types; + required_methods; + provided_methods; + } diff --git a/compiler/Translate.ml b/compiler/Translate.ml index ca661108..f4f59187 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -5,6 +5,7 @@ module T = Types module A = LlbcAst module SA = SymbolicAst module Micro = PureMicroPasses +module C = Contexts open PureUtils open TranslateCore @@ -28,18 +29,34 @@ let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : A.fun_decl) ("translate_function_to_symbolics: " ^ Print.fun_name_to_string fdef.A.name)); - let { type_context; fun_context; global_context } = trans_ctx in + let { + type_context; + fun_context; + global_context; + trait_decls_context; + trait_impls_context; + } = + trans_ctx + in let fun_context = { C.fun_decls = fun_context.fun_decls } in + (* TODO: we should merge trans_ctx and decls_ctx *) + let decls_ctx : C.decls_ctx = + { + C.type_ctx = type_context; + fun_ctx = fun_context; + global_ctx = global_context; + trait_decls_ctx = trait_decls_context; + trait_impls_ctx = trait_impls_context; + } + in + match fdef.body with | None -> None | Some _ -> (* Evaluate *) let synthesize = true in - let inputs, symb = - evaluate_function_symbolic synthesize type_context fun_context - global_context fdef - in + let inputs, symb = evaluate_function_symbolic synthesize decls_ctx fdef in Some (inputs, Option.get symb) (** Translate a function, by generating its forward and backward translations. @@ -57,7 +74,15 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (lazy ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); - let { type_context; fun_context; global_context } = trans_ctx in + let { + type_context; + fun_context; + global_context; + trait_decls_context; + trait_impls_context; + } = + trans_ctx + in let def_id = fdef.def_id in (* Compute the symbolic ASTs, if the function is transparent *) @@ -148,6 +173,8 @@ let translate_function_to_pure (trans_ctx : trans_ctx) type_context; fun_context; global_context; + trait_decls_ctx = trait_decls_context.trait_decls; + trait_impls_ctx = trait_impls_context.trait_impls; fun_decl = fdef; forward_inputs = []; (* Empty for now *) @@ -280,13 +307,21 @@ let translate_crate_to_pure (crate : A.crate) : log#ldebug (lazy "translate_crate_to_pure"); (* Compute the type and function contexts *) - let type_context, fun_context, global_context = compute_contexts crate in + let decls_ctx = compute_contexts crate in let fun_infos = - FA.analyze_module crate fun_context.C.fun_decls - global_context.C.global_decls !Config.use_state + FA.analyze_module crate decls_ctx.fun_ctx.C.fun_decls + decls_ctx.global_ctx.C.global_decls !Config.use_state + in + let fun_context = { fun_decls = decls_ctx.fun_ctx.fun_decls; fun_infos } in + let trans_ctx = + { + type_context = decls_ctx.type_ctx; + fun_context; + global_context = decls_ctx.global_ctx; + trait_decls_context = decls_ctx.trait_decls_ctx; + trait_impls_context = decls_ctx.trait_impls_ctx; + } in - let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in - let trans_ctx = { type_context; fun_context; global_context } in (* Translate all the type definitions *) let type_decls = @@ -323,7 +358,7 @@ let translate_crate_to_pure (crate : A.crate) : let sigs = List.append assumed_sigs local_sigs in let fun_sigs = SymbolicToPure.translate_fun_signatures fun_context.fun_infos - type_context.type_infos sigs + decls_ctx.type_ctx.type_infos sigs in (* Translate all the *transparent* functions *) @@ -696,6 +731,36 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) Extract.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) pure_ls +(** Export a trait declaration. *) +let export_trait_decl (fmt : Format.formatter) (_config : gen_config) + (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) : unit = + let trait_decl = + T.TraitDeclId.Map.find trait_decl_id + ctx.extract_ctx.trans_ctx.trait_decls_context.trait_decls + in + (* We translate the trait declaration on the fly (note that + trait declarations do not directly contain functions, constants, + etc.: they simply refer to them). *) + let type_infos = ctx.extract_ctx.trans_ctx.type_context.type_infos in + let trait_decl = SymbolicToPure.translate_trait_decl type_infos trait_decl in + let ctx = ctx.extract_ctx in + let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in + Extract.extract_trait_decl ctx fmt trait_decl + +(** Export a trait implementation. *) +let export_trait_impl (fmt : Format.formatter) (_config : gen_config) + (ctx : gen_ctx) (trait_impl_id : Pure.trait_impl_id) : unit = + let trait_impl = + T.TraitImplId.Map.find trait_impl_id + ctx.extract_ctx.trans_ctx.trait_impls_context.trait_impls + in + (* We translate the trait implementation on the fly (note that + trait implementations do not directly contain functions, constants, + etc.: they simply refer to them). *) + let type_infos = ctx.extract_ctx.trans_ctx.type_context.type_infos in + let trait_impl = SymbolicToPure.translate_trait_impl type_infos trait_impl in + Extract.extract_trait_impl ctx.extract_ctx fmt trait_impl + (** A generic utility to generate the extracted definitions: as we may want to split the definitions between different files (or not), we can control what is precisely extracted. @@ -710,6 +775,8 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) let export_functions_group = export_functions_group fmt config ctx in let export_global = export_global fmt config ctx in let export_types_group = export_types_group fmt config ctx in + let export_trait_decl = export_trait_decl fmt config ctx in + let export_trait_impl = export_trait_impl fmt config ctx in let export_state_type () : unit = let kind = @@ -723,11 +790,18 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) | Type (NonRec id) -> if config.extract_types then export_types_group false [ id ] | Type (Rec ids) -> if config.extract_types then export_types_group true ids - | Fun (NonRec id) -> + | Fun (NonRec id) -> ( (* Lookup *) let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in - (* Translate *) - export_functions_group [ pure_fun ] + (* Special case: we skip trait method *declarations* (we will + extract their type directly in the records we generate for + the trait declarations themselves, there is no point in having + separate type definitions) *) + match (fst (fst (snd pure_fun))).Pure.kind with + | TraitMethodDecl _ -> () + | _ -> + (* Translate *) + export_functions_group [ pure_fun ]) | Fun (Rec ids) -> (* General case of mutually recursive functions *) (* Lookup *) @@ -737,11 +811,13 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) (* Translate *) export_functions_group pure_funs | Global id -> export_global id + | TraitDecl id -> export_trait_decl id + | TraitImpl id -> export_trait_impl id in (* If we need to export the state type: we try to export it after we defined * the type definitions, because if the user wants to define a model for the - * type, he might want to reuse those in the state type. + * type, they might want to reuse those in the state type. * More specifically: if we extract functions in the same file as the type, * we have no choice but to define the state type before the functions, * because they may reuse this state type: in this case, we define/declare @@ -930,6 +1006,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : use_opaque_pre = !Config.split_files; use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; fun_name_info = PureUtils.RegularFunIdMap.empty; + trait_decl_id = None (* None by default *); } in diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index 1b1572d6..34a6434f 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -22,6 +22,7 @@ type trait_decls_context = C.trait_decls_context [@@deriving show] type trait_impls_context = C.trait_impls_context [@@deriving show] type global_context = C.global_context [@@deriving show] +(* TODO: we should use Contexts.decls_ctx *) type trans_ctx = { type_context : type_context; fun_context : fun_context; -- cgit v1.2.3 From a2f19257651df3c8473e17ef73a5389b9cb89bbf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 16:35:05 +0200 Subject: Make progress on the extraction --- compiler/Extract.ml | 218 ++++++++++++++++++++++++++++++++++++------------ compiler/ExtractBase.ml | 63 ++++++++++++-- compiler/Translate.ml | 1 + 3 files changed, 221 insertions(+), 61 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index e07305f1..e140ea1c 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -841,6 +841,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) (* TODO: actually use the clause to derive the name *) "cl" in + let trait_self_clause_basename = "self_clause" in let append_index (basename : string) (i : int) : string = basename ^ string_of_int i in @@ -936,6 +937,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) var_basename; type_var_basename; const_generic_var_basename; + trait_self_clause_basename; trait_clause_basename; append_index; extract_literal; @@ -1237,15 +1239,26 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) if use_brackets then F.pp_print_string fmt ")"; F.pp_print_string fmt ("." ^ name)) else - (* Can only happen when extracting the signature of a trait method - *declaration* or a provided trait method (for a declaration). - If extracting items for a trait method implementation, - the type should have been normalized. For trait method declarations - we directly reference the item. *) - assert (ctx.trait_decl_id <> None); - assert (generics = empty_generic_args); - let name = ctx_get_local_trait_assoc_type type_name ctx in - F.pp_print_string fmt name + (* There are two situations: + - we are extracting a declared item (typically a function signature) + for a trait declaration. We directly refer to the item (we extract + trait declarations as structures, so we can refer to their fields) + - we are extracting a provided method for a trait declaration. We + refer to the item in the self trait clause (see {!SelfTraitClauseId}). + + Remark: we can't get there for trait *implementations* because then the + types should have been normalized. + *) + let trait_decl_id = Option.get ctx.trait_decl_id in + let item_name = ctx_get_trait_assoc_type trait_decl_id type_name ctx in + assert (generics = empty_generic_args); + if ctx.is_provided_method then + (* Provided method: use the trait self clause *) + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt (self_clause ^ "." ^ item_name) + else + (* Declaration: directly refer to the item *) + F.pp_print_string fmt item_name and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = @@ -1632,11 +1645,37 @@ let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = if !space then space := false else F.pp_print_space fmt () +(** Extract the trait self clause. + + We add the trait self clause for provided methods (see {!TraitSelfClauseId}). + *) +let extract_trait_self_clause (insert_req_space : unit -> unit) + (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : A.trait_decl) + (params : string list) : unit = + insert_req_space (); + F.pp_print_string fmt "("; + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt self_clause; + F.pp_print_string fmt ":"; + let with_opaque_pre = false in + let trait_id = ctx_get_trait_decl with_opaque_pre trait_decl.def_id ctx in + F.pp_print_string fmt trait_id; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + params; + F.pp_print_string fmt ")" + +(** + - [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 (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (use_forall : bool) (as_implicits : bool) - (space : bool ref option) (generics : generic_params) - (type_params : string list) (cg_params : string list) - (trait_clauses : string list) : unit = + (space : bool ref option) (trait_decl : A.trait_decl option) + (generics : generic_params) (type_params : string list) + (cg_params : string list) (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) assert (cg_params = [] || !backend <> HOL4); @@ -1660,53 +1699,102 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ":"; F.pp_print_space fmt (); F.pp_print_string fmt "forall"); - (* Note that in HOL4 we don't print the type parameters. *) - if !backend <> HOL4 then ( - (* Print the type parameters *) - if type_params <> [] then ( - insert_req_space (); - (* ( *) - left_bracket (); + (* Small helper - we may need to split the parameters *) + let print_generics (type_params : string list) + (const_generics : const_generic_var list) + (trait_clauses : trait_clause list) : unit = + (* Note that in HOL4 we don't print the type parameters. *) + if !backend <> HOL4 then ( + (* Print the type parameters *) + if type_params <> [] then ( + insert_req_space (); + (* ( *) + left_bracket (); + List.iter + (fun s -> + F.pp_print_string fmt s; + F.pp_print_space fmt ()) + type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()); + (* ) *) + right_bracket ()); + (* Print the const generic parameters *) List.iter - (fun s -> - F.pp_print_string fmt s; - F.pp_print_space fmt ()) - type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ()); - (* ) *) - right_bracket ()); - (* Print the const generic parameters *) + (fun (var : const_generic_var) -> + insert_req_space (); + (* ( *) + left_bracket (); + let n = ctx_get_const_generic_var var.index ctx in + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_literal_type ctx fmt var.ty; + (* ) *) + right_bracket ()) + const_generics); + (* Print the trait clauses *) List.iter - (fun (var : const_generic_var) -> + (fun (clause : trait_clause) -> insert_req_space (); (* ( *) left_bracket (); - let n = ctx_get_const_generic_var var.index ctx in + let n = ctx_get_local_trait_clause clause.clause_id ctx in F.pp_print_string fmt n; F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - extract_literal_type ctx fmt var.ty; + extract_trait_clause_type ctx fmt no_params_tys clause; (* ) *) right_bracket ()) - generics.const_generics); - (* Print the trait clauses *) - List.iter - (fun (clause : trait_clause) -> - insert_req_space (); - (* ( *) - left_bracket (); - let n = ctx_get_local_trait_clause clause.clause_id ctx in - F.pp_print_string fmt n; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt no_params_tys clause; - (* ) *) - right_bracket ()) - generics.trait_clauses) + trait_clauses + in + (* If we extract the generics for a provided method for a trait declaration + (indicated by the trait decl given as input), we need to split the generics: + - we print the generics for the trait decl + - we print the trait self clause + - we print the generics for the trait method + *) + match trait_decl with + | None -> + print_generics type_params generics.const_generics + generics.trait_clauses + | Some trait_decl -> + (* Split the generics between the generics specific to the trait decl + and those specific to the trait method *) + let open Collections.List in + let dtype_params, mtype_params = + split_at type_params (length trait_decl.generics.types) + in + let dcgs, mcgs = + split_at generics.const_generics + (length trait_decl.generics.const_generics) + in + let dtrait_clauses, mtrait_clauses = + split_at generics.trait_clauses + (length trait_decl.generics.trait_clauses) + in + (* Extract the trait decl generics *) + print_generics dtype_params dcgs dtrait_clauses; + (* Extract the trait self clause *) + let params = + concat + [ + dtype_params; + map + (fun (cg : const_generic_var) -> + ctx_get_const_generic_var cg.index ctx) + dcgs; + map + (fun c -> ctx_get_local_trait_clause c.clause_id ctx) + dtrait_clauses; + ] + in + extract_trait_self_clause insert_req_space ctx fmt trait_decl params; + (* Extract the method generics *) + print_generics mtype_params mcgs mtrait_clauses) (** Extract a type declaration. @@ -1769,7 +1857,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Print the generic parameters *) let as_implicits = false in extract_generic_params ctx_body fmt type_decl_group use_forall as_implicits - None def.generics type_params cg_params trait_clauses; + None None def.generics type_params cg_params trait_clauses; (* Print the "=" if we extract the body*) if extract_body then ( F.pp_print_space fmt (); @@ -2002,7 +2090,8 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) let use_forall = false in let as_implicits = true in extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall - as_implicits None decl.generics type_params cg_params trait_clauses; + as_implicits None None decl.generics type_params cg_params + trait_clauses; (* Print the record parameter *) F.pp_print_space fmt (); F.pp_print_string fmt "("; @@ -2994,8 +3083,8 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (** A small utility to print the parameters of a function signature. We return two contexts: - - the context augmented with bindings for the type parameters - - the context augmented with bindings for the type parameters *and* + - the context augmented with bindings for the generics + - the context augmented with bindings for the generics *and* bindings for the input values We also return names for the type parameters, const generics, etc. @@ -3009,6 +3098,28 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : extraction_ctx * extraction_ctx * string list = + (* First, add the associated types and constants if the function is a method + in a trait declaration. + + About the order: we want to make sure the names are reserved for + those (variable names might collide with them but it is ok, we will add + suffixes to the variables). + + TODO: micro-pass to update what happens when calling trait provided + functions. + *) + let ctx, trait_decl = + match def.kind with + | TraitMethodProvided (decl_id, _) -> + let trait_decl = + T.TraitDeclId.Map.find decl_id + ctx.trans_ctx.trait_decls_context.trait_decls + in + let ctx, _ = ctx_add_trait_self_clause ctx in + let ctx = { ctx with is_provided_method = true } in + (ctx, Some trait_decl) + | _ -> (ctx, None) + in (* Add the type parameters - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = @@ -3020,7 +3131,8 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) let use_forall = false in let as_implicits = false in extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits - (Some space) def.signature.generics type_params cg_params trait_clauses; + (Some 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 *) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 697b1027..251d8b36 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -291,6 +291,7 @@ type formatter = { (** Generates a type variable basename. *) const_generic_var_basename : StringSet.t -> string -> string; (** Generates a const generic variable basename. *) + trait_self_clause_basename : string; trait_clause_basename : StringSet.t -> trait_clause -> string; (** Return a base name for a trait clause. We might add a suffix to prevent collisions. @@ -409,10 +410,44 @@ type id = | TraitDeclId of TraitDeclId.id | TraitImplId of TraitImplId.id | LocalTraitClauseId of TraitClauseId.id - | LocalTraitAssocTypeId of string (** Specifically for: [Self::Ty] *) | TraitAssocTypeId of TraitDeclId.id * string (** A trait associated type *) | TraitParentClauseId of TraitDeclId.id * TraitClauseId.id | TraitItemClauseId of TraitDeclId.id * string * TraitClauseId.id + | TraitSelfClauseId + (** Specifically for the clause: [Self : Trait]. + + For now, we forbid provided methods (methods in trait declarations + with a default implementation) from being overriden in trait implementations. + We extract trait provided methods such that they take an instance of + the trait as input: this instance is given by the trait self clause. + + For instance: + {[ + // + // Rust + // + trait ToU64 { + fn to_u64(&self) -> u64; + + // Provided method + fn is_pos(&self) -> bool { + self.to_u64() > 0 + } + } + + // + // Generated code + // + struct ToU64 (T : Type) { + to_u64 : T -> u64; + } + + // The trait self clause + // vvvvvvvvvvvvvvvvvvvvvv + let is_pos (T : Type) (trait_self : ToU64 T) (self : T) : bool = + trait_self.to_u64 self > 0 + ]} + *) | UnknownId (** Used for stored various strings like keywords, definitions which should always be in context, etc. and which can't be linked to one @@ -618,6 +653,7 @@ type extraction_ctx = { *) trait_decl_id : trait_decl_id option; (** If we are extracting a trait declaration, identifies it *) + is_provided_method : bool; } (** Debugging function, used when communicating name collisions to the user, @@ -752,7 +788,6 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TraitImplId id -> "trait_impl_id: " ^ TraitImplId.to_string id | LocalTraitClauseId id -> "local_trait_clause_id: " ^ TraitClauseId.to_string id - | LocalTraitAssocTypeId type_name -> "local_trait_assoc_type_id: " ^ type_name | TraitParentClauseId (id, clause_id) -> "trait_parent_clause_id: decl_id:" ^ TraitDeclId.to_string id ^ ", clause_id: " @@ -764,11 +799,14 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TraitAssocTypeId (id, type_name) -> "trait_assoc_type_id: decl_id:" ^ TraitDeclId.to_string id ^ ", type name: " ^ type_name + | TraitSelfClauseId -> "trait_self_clause" (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = match id with - | FieldId (_, _) -> !Config.record_fields_short_names + | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitAssocTypeId _ + -> + !Config.record_fields_short_names | _ -> false let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) @@ -858,6 +896,10 @@ let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = let is_opaque = false in ctx_get_type is_opaque (Assumed id) ctx +let ctx_get_trait_self_clause (ctx : extraction_ctx) : string = + let with_opaque_pre = false in + ctx_get with_opaque_pre TraitSelfClauseId ctx + let ctx_get_trait_decl (with_opaque_pre : bool) (id : trait_decl_id) (ctx : extraction_ctx) : string = ctx_get with_opaque_pre (TraitDeclId id) ctx @@ -871,11 +913,6 @@ let ctx_get_trait_assoc_type (id : trait_decl_id) (type_name : string) let is_opaque = false in ctx_get is_opaque (TraitAssocTypeId (id, type_name)) ctx -let ctx_get_local_trait_assoc_type (type_name : string) (ctx : extraction_ctx) : - string = - let is_opaque = false in - ctx_get is_opaque (LocalTraitAssocTypeId type_name) ctx - let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = let with_opaque_pre = false in @@ -969,6 +1006,16 @@ let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : let ctx = ctx_add is_opaque (VarId id) name ctx in (ctx, name) +(** Generate a unique variable name for the trait self clause and add it to the context *) +let ctx_add_trait_self_clause (ctx : extraction_ctx) : extraction_ctx * string = + let is_opaque = false in + let basename = ctx.fmt.trait_self_clause_basename in + let name = + basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + in + let ctx = ctx_add is_opaque TraitSelfClauseId name ctx in + (ctx, name) + (** Generate a unique trait clause name and add it to the context *) let ctx_add_local_trait_clause (basename : string) (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index f4f59187..790dbe14 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -1007,6 +1007,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; fun_name_info = PureUtils.RegularFunIdMap.empty; trait_decl_id = None (* None by default *); + is_provided_method = false (* false by default *); } in -- cgit v1.2.3 From 0e0f3d586e7e74003ebff129a1e91b87602467e7 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 16:51:36 +0200 Subject: Make more progress --- compiler/Extract.ml | 19 +++++++++----- compiler/ExtractBase.ml | 2 ++ compiler/Translate.ml | 70 ++++++++++++++++++++++++++++++++++++------------- 3 files changed, 67 insertions(+), 24 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index e140ea1c..17f850a3 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1650,7 +1650,7 @@ let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = We add the trait self clause for provided methods (see {!TraitSelfClauseId}). *) let extract_trait_self_clause (insert_req_space : unit -> unit) - (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : A.trait_decl) + (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : trait_decl) (params : string list) : unit = insert_req_space (); F.pp_print_string fmt "("; @@ -1673,7 +1673,7 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) *) let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (use_forall : bool) (as_implicits : bool) - (space : bool ref option) (trait_decl : A.trait_decl option) + (space : bool ref option) (trait_decl : trait_decl option) (generics : generic_params) (type_params : string list) (cg_params : string list) (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in @@ -3111,10 +3111,7 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) let ctx, trait_decl = match def.kind with | TraitMethodProvided (decl_id, _) -> - let trait_decl = - T.TraitDeclId.Map.find decl_id - ctx.trans_ctx.trait_decls_context.trait_decls - in + let trait_decl = T.TraitDeclId.Map.find decl_id ctx.trans_trait_decls in let ctx, _ = ctx_add_trait_self_clause ctx in let ctx = { ctx with is_provided_method = true } in (ctx, Some trait_decl) @@ -3887,6 +3884,16 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break to insert lines between declarations *) F.pp_print_break fmt 0 0 +(** Similar to {!extract_type_decl_register_names} *) +let extract_trait_decl_register_names (ctx : extraction_ctx) (d : trait_decl) : + extraction_ctx = + raise (Failure "TODO") + +(** Similar to {!extract_type_decl_register_names} *) +let extract_trait_impl_register_names (ctx : extraction_ctx) (d : trait_impl) : + extraction_ctx = + raise (Failure "TODO") + (** Extract a trait declaration *) let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : trait_decl) : unit = diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 251d8b36..2855b3b9 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -654,6 +654,8 @@ type extraction_ctx = { trait_decl_id : trait_decl_id option; (** If we are extracting a trait declaration, identifies it *) is_provided_method : bool; + trans_trait_decls : Pure.trait_decl Pure.TraitDeclId.Map.t; + trans_trait_impls : Pure.trait_impl Pure.TraitImplId.Map.t; } (** Debugging function, used when communicating name collisions to the user, diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 790dbe14..8df69961 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -301,8 +301,13 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Return *) (pure_forward, pure_backwards) +(* TODO: factor out the return type *) let translate_crate_to_pure (crate : A.crate) : - trans_ctx * Pure.type_decl list * (bool * pure_fun_translation) list = + trans_ctx + * Pure.type_decl list + * (bool * pure_fun_translation) list + * Pure.trait_decl list + * Pure.trait_impl list = (* Debug *) log#ldebug (lazy "translate_crate_to_pure"); @@ -368,13 +373,28 @@ let translate_crate_to_pure (crate : A.crate) : (A.FunDeclId.Map.values crate.functions) in + (* Translate the trait declarations *) + let type_infos = trans_ctx.type_context.type_infos in + let trait_decls = + List.map + (SymbolicToPure.translate_trait_decl type_infos) + (T.TraitDeclId.Map.values trans_ctx.trait_decls_context.trait_decls) + in + + (* Translate the trait implementations *) + let trait_impls = + List.map + (SymbolicToPure.translate_trait_impl type_infos) + (T.TraitImplId.Map.values trans_ctx.trait_impls_context.trait_impls) + in + (* Apply the micro-passes *) let pure_translations = Micro.apply_passes_to_pure_fun_translations trans_ctx pure_translations in (* Return *) - (trans_ctx, type_decls, pure_translations) + (trans_ctx, type_decls, pure_translations, trait_decls, trait_impls) (** Extraction context *) type gen_ctx = { @@ -735,14 +755,8 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) let export_trait_decl (fmt : Format.formatter) (_config : gen_config) (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) : unit = let trait_decl = - T.TraitDeclId.Map.find trait_decl_id - ctx.extract_ctx.trans_ctx.trait_decls_context.trait_decls + T.TraitDeclId.Map.find trait_decl_id ctx.extract_ctx.trans_trait_decls in - (* We translate the trait declaration on the fly (note that - trait declarations do not directly contain functions, constants, - etc.: they simply refer to them). *) - let type_infos = ctx.extract_ctx.trans_ctx.type_context.type_infos in - let trait_decl = SymbolicToPure.translate_trait_decl type_infos trait_decl in let ctx = ctx.extract_ctx in let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in Extract.extract_trait_decl ctx fmt trait_decl @@ -751,14 +765,8 @@ let export_trait_decl (fmt : Format.formatter) (_config : gen_config) let export_trait_impl (fmt : Format.formatter) (_config : gen_config) (ctx : gen_ctx) (trait_impl_id : Pure.trait_impl_id) : unit = let trait_impl = - T.TraitImplId.Map.find trait_impl_id - ctx.extract_ctx.trans_ctx.trait_impls_context.trait_impls + T.TraitImplId.Map.find trait_impl_id ctx.extract_ctx.trans_trait_impls in - (* We translate the trait implementation on the fly (note that - trait implementations do not directly contain functions, constants, - etc.: they simply refer to them). *) - let type_infos = ctx.extract_ctx.trans_ctx.type_context.type_infos in - let trait_impl = SymbolicToPure.translate_trait_impl type_infos trait_impl in Extract.extract_trait_impl ctx.extract_ctx fmt trait_impl (** A generic utility to generate the extracted definitions: as we may want to @@ -978,7 +986,9 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : unit = (* Translate the module to the pure AST *) - let trans_ctx, trans_types, trans_funs = translate_crate_to_pure crate in + let trans_ctx, trans_types, trans_funs, trans_trait_decls, trans_trait_impls = + translate_crate_to_pure crate + in (* Initialize the extraction context - for now we extract only to F*. * We initialize the names map by registering the keywords used in the @@ -997,6 +1007,18 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in (* Put everything in the context *) let ctx = + let trans_trait_decls = + T.TraitDeclId.Map.of_list + (List.map + (fun (d : Pure.trait_decl) -> (d.def_id, d)) + trans_trait_decls) + in + let trans_trait_impls = + T.TraitImplId.Map.of_list + (List.map + (fun (d : Pure.trait_impl) -> (d.def_id, d)) + trans_trait_impls) + in { ExtractBase.trans_ctx; names_map; @@ -1008,6 +1030,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : fun_name_info = PureUtils.RegularFunIdMap.empty; trait_decl_id = None (* None by default *); is_provided_method = false (* false by default *); + trans_trait_decls; + trans_trait_impls; } in @@ -1034,7 +1058,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in let rec_functions = PureUtils.FunLoopIdSet.of_list rec_functions in - (* Register unique names for all the top-level types, globals and functions. + (* Register unique names for all the top-level types, globals, functions... * Note that the order in which we generate the names doesn't matter: * we just need to generate a mapping from identifier to name, and make * sure there are no name clashes. *) @@ -1071,6 +1095,16 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (A.GlobalDeclId.Map.values crate.globals) in + let ctx = + List.fold_left Extract.extract_trait_decl_register_names ctx + trans_trait_decls + in + + let ctx = + List.fold_left Extract.extract_trait_impl_register_names ctx + trans_trait_impls + in + (* Open the output file *) (* First compute the filename by replacing the extension and converting the * case (rust module names are snake case) *) -- cgit v1.2.3 From 0c0b7692cc3d95adf21bccf83d5bb2f81487ca4f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 17:56:35 +0200 Subject: Register the names for the trait decls --- compiler/Extract.ml | 90 +++++++++++++++++++++++++++++++++++++++++++++---- compiler/ExtractBase.ml | 78 +++++++++++++++++++++++++++++++++++++----- 2 files changed, 154 insertions(+), 14 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 17f850a3..5eb30daa 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -720,6 +720,41 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) fname ^ suffix in + let trait_decl_name (trait_decl : trait_decl) : string = + type_name_to_snake_case trait_decl.name + in + + let trait_impl_name (trait_impl : trait_impl) : string = + get_fun_name trait_impl.name + in + + let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) + : string = + (* TODO: improve - it would be better to not use indices *) + let clause = "parent_clause_" ^ TraitClauseId.to_string clause.clause_id in + if !Config.record_fields_short_names then clause + else trait_decl_name trait_decl ^ "_" ^ clause + in + let trait_type_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_const_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_method_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_type_clause_name (trait_decl : trait_decl) (item : string) + (clause : trait_clause) : string = + (* TODO: improve - it would be better to not use indices *) + trait_type_name trait_decl item + ^ "_clause_" + ^ TraitClauseId.to_string clause.clause_id + in + let termination_measure_name (_fid : A.FunDeclId.id) (fname : fun_name) (num_loops : int) (loop_id : LoopId.id option) : string = let fname = get_fun_name fname in @@ -933,6 +968,13 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) fun_name; termination_measure_name; decreases_proof_name; + trait_decl_name; + trait_impl_name; + trait_parent_clause_name; + trait_const_name; + trait_type_name; + trait_method_name; + trait_type_clause_name; opaque_pre; var_basename; type_var_basename; @@ -1233,8 +1275,8 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) extract_trait_ref ctx fmt no_params_tys false trait_ref; extract_generic_args ctx fmt no_params_tys generics; let name = - ctx_get_trait_assoc_type trait_ref.trait_decl_ref.trait_decl_id - type_name ctx + ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name + ctx in if use_brackets then F.pp_print_string fmt ")"; F.pp_print_string fmt ("." ^ name)) @@ -1250,7 +1292,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) types should have been normalized. *) let trait_decl_id = Option.get ctx.trait_decl_id in - let item_name = ctx_get_trait_assoc_type trait_decl_id type_name ctx in + let item_name = ctx_get_trait_type trait_decl_id type_name ctx in assert (generics = empty_generic_args); if ctx.is_provided_method then (* Provided method: use the trait self clause *) @@ -3885,9 +3927,45 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0 (** Similar to {!extract_type_decl_register_names} *) -let extract_trait_decl_register_names (ctx : extraction_ctx) (d : trait_decl) : - extraction_ctx = - raise (Failure "TODO") +let extract_trait_decl_register_names (ctx : extraction_ctx) + (trait_decl : trait_decl) : extraction_ctx = + let { + def_id = _; + name = _; + generics; + preds = _; + all_trait_clauses = _; + consts; + types; + required_methods; + provided_methods = _; + } = + trait_decl + in + let ctx = ctx_add_trait_decl trait_decl ctx in + let ctx = + List.fold_left + (fun ctx clause -> ctx_add_trait_parent_clause trait_decl clause ctx) + ctx generics.trait_clauses + in + let ctx = + List.fold_left + (fun ctx (name, (_, _)) -> ctx_add_trait_const trait_decl name ctx) + ctx consts + in + let ctx = + List.fold_left + (fun ctx (name, (clauses, _)) -> + let ctx = ctx_add_trait_type trait_decl name ctx in + List.fold_left + (fun ctx clause -> + ctx_add_trait_type_clause trait_decl name clause ctx) + ctx clauses) + ctx types + in + List.fold_left + (fun ctx (name, _) -> ctx_add_trait_method trait_decl name ctx) + ctx required_methods (** Similar to {!extract_type_decl_register_names} *) let extract_trait_impl_register_names (ctx : extraction_ctx) (d : trait_impl) : diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 2855b3b9..7e6a2d40 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -242,6 +242,13 @@ type formatter = { the same purpose as in {!field:fun_name}. - loop identifier, if this is for a loop *) + trait_decl_name : trait_decl -> string; + trait_impl_name : trait_impl -> string; + trait_parent_clause_name : trait_decl -> trait_clause -> string; + trait_const_name : trait_decl -> string -> string; + trait_type_name : trait_decl -> string -> string; + trait_method_name : trait_decl -> string -> string; + trait_type_clause_name : trait_decl -> string -> trait_clause -> string; opaque_pre : unit -> string; (** TODO: obsolete, remove. @@ -410,7 +417,7 @@ type id = | TraitDeclId of TraitDeclId.id | TraitImplId of TraitImplId.id | LocalTraitClauseId of TraitClauseId.id - | TraitAssocTypeId of TraitDeclId.id * string (** A trait associated type *) + | TraitItemId of TraitDeclId.id * string (** A trait associated item *) | TraitParentClauseId of TraitDeclId.id * TraitClauseId.id | TraitItemClauseId of TraitDeclId.id * string * TraitClauseId.id | TraitSelfClauseId @@ -798,16 +805,15 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = "trait_item_clause_id: decl_id:" ^ TraitDeclId.to_string id ^ ", item name: " ^ item_name ^ ", clause_id: " ^ TraitClauseId.to_string clause_id - | TraitAssocTypeId (id, type_name) -> - "trait_assoc_type_id: decl_id:" ^ TraitDeclId.to_string id - ^ ", type name: " ^ type_name + | TraitItemId (id, name) -> + "trait_item_id: decl_id:" ^ TraitDeclId.to_string id ^ ", type name: " + ^ name | TraitSelfClauseId -> "trait_self_clause" (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = match id with - | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitAssocTypeId _ - -> + | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ -> !Config.record_fields_short_names | _ -> false @@ -910,10 +916,22 @@ let ctx_get_trait_impl (with_opaque_pre : bool) (id : trait_impl_id) (ctx : extraction_ctx) : string = ctx_get with_opaque_pre (TraitImplId id) ctx -let ctx_get_trait_assoc_type (id : trait_decl_id) (type_name : string) +let ctx_get_trait_item (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = let is_opaque = false in - ctx_get is_opaque (TraitAssocTypeId (id, type_name)) ctx + ctx_get is_opaque (TraitItemId (id, item_name)) ctx + +let ctx_get_trait_const (id : trait_decl_id) (item_name : string) + (ctx : extraction_ctx) : string = + ctx_get_trait_item id item_name ctx + +let ctx_get_trait_type (id : trait_decl_id) (item_name : string) + (ctx : extraction_ctx) : string = + ctx_get_trait_item id item_name ctx + +let ctx_get_trait_method (id : trait_decl_id) (item_name : string) + (ctx : extraction_ctx) : string = + ctx_get_trait_item id item_name ctx let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = @@ -1205,6 +1223,50 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) ctx.fun_name_info; } +let ctx_add_trait_decl (d : trait_decl) (ctx : extraction_ctx) : extraction_ctx + = + let is_opaque = false in + let name = ctx.fmt.trait_decl_name d in + ctx_add is_opaque (TraitDeclId d.def_id) name ctx + +let ctx_add_trait_impl (d : trait_impl) (ctx : extraction_ctx) : extraction_ctx + = + let is_opaque = false in + let name = ctx.fmt.trait_impl_name d in + ctx_add is_opaque (TraitImplId d.def_id) name ctx + +let ctx_add_trait_const (d : trait_decl) (item : string) (ctx : extraction_ctx) + : extraction_ctx = + let is_opaque = false in + let name = ctx.fmt.trait_const_name d item in + ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx + +let ctx_add_trait_type (d : trait_decl) (item : string) (ctx : extraction_ctx) : + extraction_ctx = + let is_opaque = false in + let name = ctx.fmt.trait_type_name d item in + ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx + +let ctx_add_trait_method (d : trait_decl) (item : string) (ctx : extraction_ctx) + : extraction_ctx = + let is_opaque = false in + let name = ctx.fmt.trait_method_name d item in + ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx + +let ctx_add_trait_parent_clause (d : trait_decl) (clause : trait_clause) + (ctx : extraction_ctx) : extraction_ctx = + let is_opaque = false in + let name = ctx.fmt.trait_parent_clause_name d clause in + ctx_add is_opaque (TraitParentClauseId (d.def_id, clause.clause_id)) name ctx + +let ctx_add_trait_type_clause (d : trait_decl) (item : string) + (clause : trait_clause) (ctx : extraction_ctx) : extraction_ctx = + let is_opaque = false in + let name = ctx.fmt.trait_type_clause_name d item clause in + ctx_add is_opaque + (TraitItemClauseId (d.def_id, item, clause.clause_id)) + name ctx + type names_map_init = { keywords : string list; assumed_adts : (assumed_ty * string) list; -- cgit v1.2.3 From 9fe9fc0ab70b8629722d60748bbede554017172c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 18:59:19 +0200 Subject: Make progress on extracting trait decls and merge gen_ctx and extraction_ctx --- compiler/Extract.ml | 150 ++++++++++++++++++++++++++++++++++++++++++-- compiler/ExtractBase.ml | 4 ++ compiler/Translate.ml | 163 +++++++++++++++++++++--------------------------- 3 files changed, 219 insertions(+), 98 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 5eb30daa..f911290e 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -3943,16 +3943,19 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) trait_decl in let ctx = ctx_add_trait_decl trait_decl ctx in + (* Parent clauses *) let ctx = List.fold_left (fun ctx clause -> ctx_add_trait_parent_clause trait_decl clause ctx) ctx generics.trait_clauses in + (* Constants *) let ctx = List.fold_left (fun ctx (name, (_, _)) -> ctx_add_trait_const trait_decl name ctx) ctx consts in + (* Types *) let ctx = List.fold_left (fun ctx (name, (clauses, _)) -> @@ -3963,19 +3966,156 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) ctx clauses) ctx types in + (* Required methods *) + (* TODO: for the methods, we need to add fields for the forward/backward functions *) + raise (Failure "TODO"); List.fold_left - (fun ctx (name, _) -> ctx_add_trait_method trait_decl name ctx) + (fun ctx (name, id) -> ctx_add_trait_method trait_decl name ctx) ctx required_methods (** Similar to {!extract_type_decl_register_names} *) -let extract_trait_impl_register_names (ctx : extraction_ctx) (d : trait_impl) : - extraction_ctx = +let extract_trait_impl_register_names (ctx : extraction_ctx) + (trait_impl : trait_impl) : extraction_ctx = + (* For now we do not support overriding provided methods *) + assert (trait_impl.provided_methods = []); + (* Everything is actually taken care of by {!extract_trait_decl_register_names} *) + ctx + +(** Small helper. + + The type `ty` is to be understood in a very general sense. + *) +let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (ty : unit -> unit) : unit = + F.pp_print_space fmt (); + F.pp_open_vbox fmt ctx.indent_incr; + F.pp_print_string fmt item_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + ty (); + F.pp_print_string fmt ";"; + F.pp_close_box fmt () + +(** Small helper. + + Extract the items for a method in a trait decl. + *) +let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) + (decl : trait_decl) (name : string) (id : fun_decl_id) : unit = + let item_name = ctx_get_trait_const decl.def_id name ctx in + (* Lookup the definition *) + (* let def = + FunDeclId.Map.find ctx. + in *) raise (Failure "TODO") (** Extract a trait declaration *) let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) - (trait_decl : trait_decl) : unit = - raise (Failure "TODO") + (decl : trait_decl) : unit = + (* Retrieve the trait name *) + let with_opaque_pre = false in + let decl_name = ctx_get_trait_decl with_opaque_pre decl.def_id ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + extract_comment fmt [ "[" ^ Print.name_to_string decl.name ^ "]" ]; + F.pp_print_break fmt 0 0; + (* Open two boxes for the definition, so that whenever possible it gets printed on + * one line and indents are correct *) + F.pp_open_hvbox fmt 0; + F.pp_open_vbox fmt ctx.indent_incr; + + (* `struct Trait (....) =` *) + (* Open the box for the name + generics *) + F.pp_open_vbox fmt ctx.indent_incr; + let qualif = + Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec (Some Struct)) + in + F.pp_print_string fmt qualif; + F.pp_print_space fmt (); + F.pp_print_string fmt decl_name; + + (* Print the generics *) + (* We ignore the trait clauses, which we extract as *fields* *) + let generics = { decl.generics with trait_clauses = [] } in + (* 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 generics ctx + in + let use_forall = false in + let as_implicits = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits + None None decl.generics type_params cg_params trait_clauses; + + F.pp_print_space fmt (); + F.pp_print_string fmt "{"; + + (* Close the box for the name + generics *) + F.pp_close_box fmt (); + + (* + * Extract the items + *) + + (* The parent clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + let ty () = + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + decl.generics.trait_clauses; + + (* The constants *) + List.iter + (fun (name, (ty, _)) -> + let item_name = ctx_get_trait_const decl.def_id name ctx in + let ty () = + let inside = false in + extract_ty ctx fmt TypeDeclId.Set.empty inside ty + in + extract_trait_decl_item ctx fmt item_name ty) + decl.consts; + + (* The types *) + List.iter + (fun (name, (clauses, _)) -> + (* Extract the type *) + let item_name = ctx_get_trait_type decl.def_id name ctx in + let ty () = F.pp_print_string fmt (type_keyword ()) in + extract_trait_decl_item ctx fmt item_name ty; + (* Extract the clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + in + let ty () = + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + clauses) + decl.types; + + (* The required methods *) + List.iter + (fun (name, id) -> extract_trait_decl_method_items ctx fmt decl name id) + decl.required_methods; + + (* Close the brackets *) + F.pp_print_space fmt (); + F.pp_print_string fmt "}"; + + (* Close the two outer boxes for the definition *) + F.pp_close_box fmt (); + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 (** Extract a trait implementation *) let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 7e6a2d40..26940c0c 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -621,6 +621,7 @@ type fun_name_info = { keep_fwd : bool; num_backs : int } functions, etc. *) type extraction_ctx = { + crate : A.crate; trans_ctx : trans_ctx; names_map : names_map; (** The map for id to names, where we forbid name collisions @@ -661,6 +662,9 @@ type extraction_ctx = { trait_decl_id : trait_decl_id option; (** If we are extracting a trait declaration, identifies it *) is_provided_method : bool; + trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; + trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; + functions_with_decreases_clause : PureUtils.FunLoopIdSet.t; trans_trait_decls : Pure.trait_decl Pure.TraitDeclId.Map.t; trans_trait_impls : Pure.trait_impl Pure.TraitImplId.Map.t; } diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 8df69961..b26ce23b 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -396,14 +396,7 @@ let translate_crate_to_pure (crate : A.crate) : (* Return *) (trans_ctx, type_decls, pure_translations, trait_decls, trait_impls) -(** Extraction context *) -type gen_ctx = { - crate : A.crate; - extract_ctx : ExtractBase.extraction_ctx; - trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; - functions_with_decreases_clause : PureUtils.FunLoopIdSet.t; -} +type gen_ctx = ExtractBase.extraction_ctx type gen_config = { extract_types : bool; @@ -482,9 +475,9 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) || ((not is_opaque) && config.extract_transparent) then ( if extract_decl then - Extract.extract_type_decl ctx.extract_ctx fmt type_decl_group kind def; + Extract.extract_type_decl ctx fmt type_decl_group kind def; if extract_extra_info then - Extract.extract_type_decl_extra_info ctx.extract_ctx fmt kind def) + Extract.extract_type_decl_extra_info ctx fmt kind def) (** Export a group of types. @@ -536,7 +529,7 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) End ]} *) - Extract.start_type_decl_group ctx.extract_ctx fmt is_rec defs; + Extract.start_type_decl_group ctx fmt is_rec defs; List.iteri (fun i def -> let kind = kind_from_index i in @@ -557,7 +550,7 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) *) let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : A.GlobalDeclId.id) : unit = - let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in + let global_decls = ctx.trans_ctx.global_context.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in let _, ((body, loop_fwds), body_backs) = A.FunDeclId.Map.find global.body_id ctx.trans_funs @@ -576,7 +569,7 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) groups are always singletons, so the [extract_global_decl] function takes care of generating the delimiters. *) - Extract.extract_global_decl ctx.extract_ctx fmt global body config.interface + Extract.extract_global_decl ctx fmt global body config.interface (** Utility. @@ -657,14 +650,13 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) then Some (fun () -> - Extract.extract_fun_decl ctx.extract_ctx fmt kind has_decr_clause - def) + Extract.extract_fun_decl ctx fmt kind has_decr_clause def) else None) decls in let extract_defs = List.filter_map (fun x -> x) extract_defs in if extract_defs <> [] then ( - Extract.start_fun_decl_group ctx.extract_ctx fmt is_rec decls; + Extract.start_fun_decl_group ctx fmt is_rec decls; List.iter (fun f -> f ()) extract_defs; Extract.end_fun_decl_group fmt is_rec decls) @@ -700,11 +692,10 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) if has_decr_clause then match !Config.backend with | Lean -> - Extract.extract_template_lean_termination_and_decreasing - ctx.extract_ctx fmt decl + Extract.extract_template_lean_termination_and_decreasing ctx fmt + decl | FStar -> - Extract.extract_template_fstar_decreases_clause ctx.extract_ctx - fmt decl + Extract.extract_template_fstar_decreases_clause ctx fmt decl | Coq -> raise (Failure "Coq doesn't have decreases/termination clauses") | HOL4 -> @@ -747,27 +738,21 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) if config.test_trans_unit_functions then List.iter (fun (keep_fwd, ((fwd, _), _)) -> - if keep_fwd then - Extract.extract_unit_test_if_unit_fun ctx.extract_ctx fmt fwd) + if keep_fwd then Extract.extract_unit_test_if_unit_fun ctx fmt fwd) pure_ls (** Export a trait declaration. *) let export_trait_decl (fmt : Format.formatter) (_config : gen_config) (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) : unit = - let trait_decl = - T.TraitDeclId.Map.find trait_decl_id ctx.extract_ctx.trans_trait_decls - in - let ctx = ctx.extract_ctx in + let trait_decl = T.TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls in let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in Extract.extract_trait_decl ctx fmt trait_decl (** Export a trait implementation. *) let export_trait_impl (fmt : Format.formatter) (_config : gen_config) (ctx : gen_ctx) (trait_impl_id : Pure.trait_impl_id) : unit = - let trait_impl = - T.TraitImplId.Map.find trait_impl_id ctx.extract_ctx.trans_trait_impls - in - Extract.extract_trait_impl ctx.extract_ctx fmt trait_impl + let trait_impl = T.TraitImplId.Map.find trait_impl_id ctx.trans_trait_impls in + Extract.extract_trait_impl ctx fmt trait_impl (** A generic utility to generate the extracted definitions: as we may want to split the definitions between different files (or not), we can control @@ -790,7 +775,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) let kind = if config.interface then ExtractBase.Declared else ExtractBase.Assumed in - Extract.extract_state_type fmt ctx.extract_ctx kind + Extract.extract_state_type fmt ctx kind in let export_decl_group (dg : A.declaration_group) : unit = @@ -856,7 +841,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if config.extract_transparent then "Definitions" else "OpaqueDefs" in Format.pp_print_break fmt 0 0; - Format.pp_open_vbox fmt ctx.extract_ctx.indent_incr; + Format.pp_open_vbox fmt ctx.indent_incr; Format.pp_print_string fmt ("structure " ^ struct_name ^ " where"); Format.pp_print_break fmt 0 0); List.iter export_decl_group ctx.crate.declarations; @@ -1005,6 +990,43 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : mk_formatter_and_names_map trans_ctx crate.name variant_concatenate_type_name in + + (* We need to compute which functions are recursive, in order to know + * whether we should generate a decrease clause or not. *) + let rec_functions = + List.map + (fun (_, ((fwd, loop_fwds), _)) -> + let fwd = + if fwd.Pure.signature.info.effect_info.is_rec then + [ (fwd.def_id, None) ] + else [] + in + let loop_fwds = + List.map + (fun (def : Pure.fun_decl) -> [ (def.def_id, def.loop_id) ]) + loop_fwds + in + fwd :: loop_fwds) + trans_funs + in + let rec_functions : PureUtils.fun_loop_id list = + List.concat (List.concat rec_functions) + in + let rec_functions = PureUtils.FunLoopIdSet.of_list rec_functions in + + (* Put the translated definitions in maps *) + let trans_types = + Pure.TypeDeclId.Map.of_list + (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) + in + let trans_funs = + A.FunDeclId.Map.of_list + (List.map + (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> + ((fst fd).def_id, (keep_fwd, (fd, bdl)))) + trans_funs) + in + (* Put everything in the context *) let ctx = let trans_trait_decls = @@ -1020,7 +1042,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : trans_trait_impls) in { - ExtractBase.trans_ctx; + ExtractBase.crate; + trans_ctx; names_map; unsafe_names_map = { id_to_name = ExtractBase.IdMap.empty }; fmt; @@ -1032,32 +1055,12 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : is_provided_method = false (* false by default *); trans_trait_decls; trans_trait_impls; + trans_types; + trans_funs; + functions_with_decreases_clause = rec_functions; } in - (* We need to compute which functions are recursive, in order to know - * whether we should generate a decrease clause or not. *) - let rec_functions = - List.map - (fun (_, ((fwd, loop_fwds), _)) -> - let fwd = - if fwd.Pure.signature.info.effect_info.is_rec then - [ (fwd.def_id, None) ] - else [] - in - let loop_fwds = - List.map - (fun (def : Pure.fun_decl) -> [ (def.def_id, def.loop_id) ]) - loop_fwds - in - fwd :: loop_fwds) - trans_funs - in - let rec_functions : PureUtils.fun_loop_id list = - List.concat (List.concat rec_functions) - in - let rec_functions = PureUtils.FunLoopIdSet.of_list rec_functions in - (* Register unique names for all the top-level types, globals, functions... * Note that the order in which we generate the names doesn't matter: * we just need to generate a mapping from identifier to name, and make @@ -1065,7 +1068,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : let ctx = List.fold_left (fun ctx def -> Extract.extract_type_decl_register_names ctx def) - ctx trans_types + ctx + (Pure.TypeDeclId.Map.values trans_types) in let ctx = @@ -1087,7 +1091,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : else Extract.extract_fun_decl_register_names ctx keep_fwd gen_decr_clause defs) - ctx trans_funs + ctx + (A.FunDeclId.Map.values trans_funs) in let ctx = @@ -1133,19 +1138,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (namespace, crate_name, Filename.concat dest_dir crate_name) in - (* Put the translated definitions in maps *) - let trans_types = - Pure.TypeDeclId.Map.of_list - (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) - in - let trans_funs = - A.FunDeclId.Map.of_list - (List.map - (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> - ((fst fd).def_id, (keep_fwd, (fd, bdl)))) - trans_funs) - in - let mkdir_if dest_dir = if not (Sys.file_exists dest_dir) then ( log#linfo (lazy ("Creating missing directory: " ^ dest_dir)); @@ -1201,16 +1193,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in (* Extract the file(s) *) - let gen_ctx = - { - crate; - extract_ctx = ctx; - trans_types; - trans_funs; - functions_with_decreases_clause = rec_functions; - } - in - let module_delimiter = match !Config.backend with | FStar -> "." @@ -1257,7 +1239,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (* Check if there are opaque types and functions - in which case we need * to split *) - let has_opaque_types, has_opaque_funs = module_has_opaque_decls gen_ctx in + let has_opaque_types, has_opaque_funs = module_has_opaque_decls ctx in let has_opaque_types = has_opaque_types || !Config.use_state in (* Extract the types *) @@ -1296,7 +1278,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = []; } in - extract_file types_config gen_ctx file_info; + extract_file types_config ctx file_info; (* Extract the template clauses *) (if needs_clauses_module && !Config.extract_template_decreases_clauses then @@ -1324,7 +1306,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = []; } in - extract_file template_clauses_config gen_ctx file_info); + extract_file template_clauses_config ctx file_info); (* Extract the opaque functions, if needed *) let opaque_funs_module = @@ -1359,12 +1341,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : interface = true; } in - let gen_ctx = - { - gen_ctx with - extract_ctx = { gen_ctx.extract_ctx with use_opaque_pre = false }; - } - in + let ctx = { ctx with use_opaque_pre = false } in let file_info = { filename = opaque_filename; @@ -1378,7 +1355,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = [ types_module ]; } in - extract_file opaque_config gen_ctx file_info; + extract_file opaque_config ctx file_info; (* Return the additional dependencies *) [ opaque_imported_module ]) else [] @@ -1417,7 +1394,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : [ types_module ] @ opaque_funs_module @ clauses_module; } in - extract_file fun_config gen_ctx file_info) + extract_file fun_config ctx file_info) else let gen_config = { @@ -1447,7 +1424,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : custom_includes = []; } in - extract_file gen_config gen_ctx file_info); + extract_file gen_config ctx file_info); (* Generate the build file *) match !Config.backend with -- cgit v1.2.3 From 9fb4886f9003f75e8d3aafaf51586ab5f9001744 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 19:18:25 +0200 Subject: Update the type TranslateCore.fun_and_loops --- compiler/Extract.ml | 4 ++-- compiler/PureMicroPasses.ml | 17 +++++++++-------- compiler/Translate.ml | 46 ++++++++++++++++++++++----------------------- compiler/TranslateCore.ml | 2 +- 4 files changed, 35 insertions(+), 34 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index f911290e..73a081a7 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2329,7 +2329,7 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) (has_decreases_clause : fun_decl -> bool) (def : pure_fun_translation) : extraction_ctx = - let (fwd, loop_fwds), back_ls = def in + let { f = fwd; loops = loop_fwds }, back_ls = def in (* Register the decrease clauses, if necessary *) let register_decreases ctx def = if has_decreases_clause def then @@ -2350,7 +2350,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) (* Register the backward functions' names *) let ctx = List.fold_left - (fun ctx (back, loop_backs) -> + (fun ctx { f = back; loops = loop_backs } -> let ctx = register_fun ctx back in register_funs ctx loop_backs) ctx back_ls diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 93609695..72e3d05e 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1461,7 +1461,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = altogether. *) let keep_forward (trans : pure_fun_translation) : bool = - let (fwd, _), backs = trans in + let { f = fwd; _ }, backs = trans in (* Note that at this point, the output types are no longer seen as tuples: * they should be lists of length 1. *) if @@ -1908,7 +1908,7 @@ let apply_end_passes_to_def (ctx : trans_ctx) (def : fun_decl) : fun_decl = [ctx]: used only for printing. *) let apply_passes_to_def (ctx : trans_ctx) (def : fun_decl) : - (fun_decl * fun_decl list) option = + fun_and_loops option = (* Debug *) log#ldebug (lazy @@ -1949,9 +1949,9 @@ let apply_passes_to_def (ctx : trans_ctx) (def : fun_decl) : let def, loops = decompose_loops def in (* Apply the remaining passes *) - let def = apply_end_passes_to_def ctx def in + let f = apply_end_passes_to_def ctx def in let loops = List.map (apply_end_passes_to_def ctx) loops in - Some (def, loops) + Some { f; loops } (** Small utility for {!filter_loop_inputs} *) let filter_prefix (keep : bool list) (ls : 'a list) : 'a list = @@ -1996,10 +1996,11 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : (List.concat (List.concat (List.map - (fun (_, ((fwd, loops_fwd), backs)) -> + (fun (_, ({ f = fwd; loops = loops_fwd }, backs)) -> [ fwd :: loops_fwd ] :: List.map - (fun (back, loops_back) -> [ back :: loops_back ]) + (fun { f = back; loops = loops_back } -> + [ back :: loops_back ]) backs) transl))) in @@ -2246,8 +2247,8 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : let transl = List.map (fun (b, (fwd, backs)) -> - let filter_fun_and_loops (f, fl) = - (filter_in_one f, List.map filter_in_one fl) + let filter_fun_and_loops f = + { f = filter_in_one f.f; loops = List.map filter_in_one f.loops } in let fwd = filter_fun_and_loops fwd in let backs = List.map filter_fun_and_loops backs in diff --git a/compiler/Translate.ml b/compiler/Translate.ml index b26ce23b..2f751693 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -439,8 +439,8 @@ let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = in let has_opaque_funs = A.FunDeclId.Map.exists - (fun _ ((_, ((t_fwd, _), _)) : bool * pure_fun_translation) -> - Option.is_none t_fwd.body) + (fun _ ((_, (fwd, _)) : bool * pure_fun_translation) -> + Option.is_none fwd.f.body) ctx.trans_funs in (has_opaque_types, has_opaque_funs) @@ -552,7 +552,7 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : A.GlobalDeclId.id) : unit = let global_decls = ctx.trans_ctx.global_context.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in - let _, ((body, loop_fwds), body_backs) = + let _, ({ f = body; loops = loop_fwds }, body_backs) = A.FunDeclId.Map.find global.body_id ctx.trans_funs in assert (body_backs = []); @@ -676,7 +676,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Extract the decrease clauses template bodies *) if config.extract_template_decreases_clauses then List.iter - (fun (_, ((fwd, loop_fwds), _)) -> + (fun (_, (fwd, _)) -> (* We only generate decreases clauses for the forward functions, because the termination argument should only depend on the forward inputs. The backward functions thus use the same decreases clauses as the @@ -702,8 +702,8 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) raise (Failure "HOL4 doesn't have decreases/termination clauses") in - extract_decrease fwd; - List.iter extract_decrease loop_fwds) + extract_decrease fwd.f; + List.iter extract_decrease fwd.loops) pure_ls; (* Concatenate the function definitions, filtering the useless forward @@ -711,12 +711,12 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) let decls = List.concat (List.map - (fun (keep_fwd, ((fwd, fwd_loops), (back_ls : fun_and_loops list))) -> - let fwd = if keep_fwd then List.append fwd_loops [ fwd ] else [] in + (fun (keep_fwd, (fwd, (back_ls : fun_and_loops list))) -> + let fwd = if keep_fwd then List.append fwd.loops [ fwd.f ] else [] in let back : Pure.fun_decl list = List.concat (List.map - (fun (back, loop_backs) -> List.append loop_backs [ back ]) + (fun back -> List.append back.loops [ back.f ]) back_ls) in List.append fwd back) @@ -737,8 +737,8 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Insert unit tests if necessary *) if config.test_trans_unit_functions then List.iter - (fun (keep_fwd, ((fwd, _), _)) -> - if keep_fwd then Extract.extract_unit_test_if_unit_fun ctx fmt fwd) + (fun (keep_fwd, (fwd, _)) -> + if keep_fwd then Extract.extract_unit_test_if_unit_fun ctx fmt fwd.f) pure_ls (** Export a trait declaration. *) @@ -790,7 +790,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) extract their type directly in the records we generate for the trait declarations themselves, there is no point in having separate type definitions) *) - match (fst (fst (snd pure_fun))).Pure.kind with + match (fst (snd pure_fun)).f.Pure.kind with | TraitMethodDecl _ -> () | _ -> (* Translate *) @@ -995,18 +995,18 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : * whether we should generate a decrease clause or not. *) let rec_functions = List.map - (fun (_, ((fwd, loop_fwds), _)) -> - let fwd = - if fwd.Pure.signature.info.effect_info.is_rec then - [ (fwd.def_id, None) ] + (fun (_, (fwd, _)) -> + let fwd_f = + if fwd.f.Pure.signature.info.effect_info.is_rec then + [ (fwd.f.def_id, None) ] else [] in let loop_fwds = List.map (fun (def : Pure.fun_decl) -> [ (def.def_id, def.loop_id) ]) - loop_fwds + fwd.loops in - fwd :: loop_fwds) + fwd_f :: loop_fwds) trans_funs in let rec_functions : PureUtils.fun_loop_id list = @@ -1019,11 +1019,11 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : Pure.TypeDeclId.Map.of_list (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) in - let trans_funs = + let trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t = A.FunDeclId.Map.of_list (List.map - (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> - ((fst fd).def_id, (keep_fwd, (fd, bdl)))) + (fun ((keep_fwd, (fwd, bdl)) : bool * pure_fun_translation) -> + (fwd.f.def_id, (keep_fwd, (fwd, bdl)))) trans_funs) in @@ -1074,10 +1074,10 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : let ctx = List.fold_left - (fun ctx (keep_fwd, defs) -> + (fun ctx ((keep_fwd, defs) : bool * pure_fun_translation) -> (* If requested by the user, register termination measures and decreases proofs for all the recursive functions *) - let fwd_def = fst (fst defs) in + let fwd_def = (fst defs).f in let gen_decr_clause (def : Pure.fun_decl) = !Config.extract_decreases_clauses && PureUtils.FunLoopIdSet.mem diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index 34a6434f..9694c95e 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -31,7 +31,7 @@ type trans_ctx = { trait_impls_context : trait_impls_context; } -type fun_and_loops = Pure.fun_decl * Pure.fun_decl list +type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list type pure_fun_translation = fun_and_loops * fun_and_loops list -- cgit v1.2.3 From cce09bb0fb64b07b07613d7db59857651e040c20 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 19:29:11 +0200 Subject: Update TranslateCore.pure_fun_translation --- compiler/Extract.ml | 3 ++- compiler/ExtractBase.ml | 2 +- compiler/PureMicroPasses.ml | 20 ++++++++++---------- compiler/Translate.ml | 40 +++++++++++++++++++--------------------- compiler/TranslateCore.ml | 2 +- 5 files changed, 33 insertions(+), 34 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 73a081a7..5c0a08ad 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2329,7 +2329,8 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) (has_decreases_clause : fun_decl -> bool) (def : pure_fun_translation) : extraction_ctx = - let { f = fwd; loops = loop_fwds }, back_ls = def in + let { f = fwd; loops = loop_fwds } = def.fwd in + let back_ls = def.backs in (* Register the decrease clauses, if necessary *) let register_decreases ctx def = if has_decreases_clause def then diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 26940c0c..7a21d42d 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1197,7 +1197,7 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) in let sg = llbc_def.signature in let num_rgs = List.length sg.regions_hierarchy in - let keep_fwd, (_, backs) = trans_group in + let keep_fwd, { fwd = _; backs } = trans_group in let num_backs = List.length backs in let rg_info = match def.back_id with diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 72e3d05e..e97a9cd7 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1461,12 +1461,12 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = altogether. *) let keep_forward (trans : pure_fun_translation) : bool = - let { f = fwd; _ }, backs = trans in + let { fwd; backs } = trans in (* Note that at this point, the output types are no longer seen as tuples: * they should be lists of length 1. *) if !Config.filter_useless_functions - && fwd.signature.output = mk_result_ty mk_unit_ty + && fwd.f.signature.output = mk_result_ty mk_unit_ty && backs <> [] then false else true @@ -1996,8 +1996,8 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : (List.concat (List.concat (List.map - (fun (_, ({ f = fwd; loops = loops_fwd }, backs)) -> - [ fwd :: loops_fwd ] + (fun (_, { fwd; backs }) -> + [ fwd.f :: fwd.loops ] :: List.map (fun { f = back; loops = loops_back } -> [ back :: loops_back ]) @@ -2246,13 +2246,13 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : in let transl = List.map - (fun (b, (fwd, backs)) -> + (fun (b, { fwd; backs }) -> let filter_fun_and_loops f = { f = filter_in_one f.f; loops = List.map filter_in_one f.loops } in let fwd = filter_fun_and_loops fwd in let backs = List.map filter_fun_and_loops backs in - (b, (fwd, backs))) + (b, { fwd; backs })) transl in @@ -2278,10 +2278,10 @@ let apply_passes_to_pure_fun_translations (ctx : trans_ctx) let apply_to_one (trans : fun_decl * fun_decl list) : bool * pure_fun_translation = (* Apply the passes to the individual functions *) - let forward, backwards = trans in - let forward = Option.get (apply_passes_to_def ctx forward) in - let backwards = List.filter_map (apply_passes_to_def ctx) backwards in - let trans = (forward, backwards) in + let fwd, backs = trans in + let fwd = Option.get (apply_passes_to_def ctx fwd) in + let backs = List.filter_map (apply_passes_to_def ctx) backs in + let trans = { fwd; backs } in (* Compute whether we need to filter the forward function or not *) (keep_forward trans, trans) in diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 2f751693..7122e462 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -439,8 +439,8 @@ let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = in let has_opaque_funs = A.FunDeclId.Map.exists - (fun _ ((_, (fwd, _)) : bool * pure_fun_translation) -> - Option.is_none fwd.f.body) + (fun _ ((_, trans) : bool * pure_fun_translation) -> + Option.is_none trans.fwd.f.body) ctx.trans_funs in (has_opaque_types, has_opaque_funs) @@ -552,11 +552,10 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : A.GlobalDeclId.id) : unit = let global_decls = ctx.trans_ctx.global_context.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in - let _, ({ f = body; loops = loop_fwds }, body_backs) = - A.FunDeclId.Map.find global.body_id ctx.trans_funs - in - assert (body_backs = []); - assert (loop_fwds = []); + let _, trans = A.FunDeclId.Map.find global.body_id ctx.trans_funs in + assert (trans.fwd.loops = []); + assert (trans.backs = []); + let body = trans.fwd.f in let is_opaque = Option.is_none body.Pure.body in if @@ -676,7 +675,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Extract the decrease clauses template bodies *) if config.extract_template_decreases_clauses then List.iter - (fun (_, (fwd, _)) -> + (fun (_, { fwd; _ }) -> (* We only generate decreases clauses for the forward functions, because the termination argument should only depend on the forward inputs. The backward functions thus use the same decreases clauses as the @@ -711,15 +710,13 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) let decls = List.concat (List.map - (fun (keep_fwd, (fwd, (back_ls : fun_and_loops list))) -> + (fun (keep_fwd, { fwd; backs }) -> let fwd = if keep_fwd then List.append fwd.loops [ fwd.f ] else [] in - let back : Pure.fun_decl list = + let backs : Pure.fun_decl list = List.concat - (List.map - (fun back -> List.append back.loops [ back.f ]) - back_ls) + (List.map (fun back -> List.append back.loops [ back.f ]) backs) in - List.append fwd back) + List.append fwd backs) pure_ls) in @@ -737,8 +734,9 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Insert unit tests if necessary *) if config.test_trans_unit_functions then List.iter - (fun (keep_fwd, (fwd, _)) -> - if keep_fwd then Extract.extract_unit_test_if_unit_fun ctx fmt fwd.f) + (fun (keep_fwd, trans) -> + if keep_fwd then + Extract.extract_unit_test_if_unit_fun ctx fmt trans.fwd.f) pure_ls (** Export a trait declaration. *) @@ -790,7 +788,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) extract their type directly in the records we generate for the trait declarations themselves, there is no point in having separate type definitions) *) - match (fst (snd pure_fun)).f.Pure.kind with + match (snd pure_fun).fwd.f.Pure.kind with | TraitMethodDecl _ -> () | _ -> (* Translate *) @@ -995,7 +993,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : * whether we should generate a decrease clause or not. *) let rec_functions = List.map - (fun (_, (fwd, _)) -> + (fun (_, { fwd; _ }) -> let fwd_f = if fwd.f.Pure.signature.info.effect_info.is_rec then [ (fwd.f.def_id, None) ] @@ -1022,8 +1020,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : let trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t = A.FunDeclId.Map.of_list (List.map - (fun ((keep_fwd, (fwd, bdl)) : bool * pure_fun_translation) -> - (fwd.f.def_id, (keep_fwd, (fwd, bdl)))) + (fun ((keep_fwd, { fwd; backs }) : bool * pure_fun_translation) -> + (fwd.f.def_id, (keep_fwd, { fwd; backs }))) trans_funs) in @@ -1077,7 +1075,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (fun ctx ((keep_fwd, defs) : bool * pure_fun_translation) -> (* If requested by the user, register termination measures and decreases proofs for all the recursive functions *) - let fwd_def = (fst defs).f in + let fwd_def = defs.fwd.f in let gen_decr_clause (def : Pure.fun_decl) = !Config.extract_decreases_clauses && PureUtils.FunLoopIdSet.mem diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index 9694c95e..9fd27c59 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -33,7 +33,7 @@ type trans_ctx = { type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list -type pure_fun_translation = fun_and_loops * fun_and_loops list +type pure_fun_translation = { fwd : fun_and_loops; backs : fun_and_loops list } let trans_ctx_to_type_formatter (ctx : trans_ctx) (type_params : Pure.type_var list) -- cgit v1.2.3 From dfcbfab4030be2f03b159a4b298ed75ac2f236ae Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 19:41:03 +0200 Subject: Add the keep_fwd field in TranslateCore.pure_fun_translation --- compiler/ExtractBase.ml | 2 +- compiler/PureMicroPasses.ml | 28 +++++++++++++--------------- compiler/Translate.ml | 34 ++++++++++++++++------------------ compiler/TranslateCore.ml | 13 ++++++++++++- 4 files changed, 42 insertions(+), 35 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 7a21d42d..885467c2 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -663,7 +663,7 @@ type extraction_ctx = { (** If we are extracting a trait declaration, identifies it *) is_provided_method : bool; trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; + trans_funs : pure_fun_translation A.FunDeclId.Map.t; functions_with_decreases_clause : PureUtils.FunLoopIdSet.t; trans_trait_decls : Pure.trait_decl Pure.TraitDeclId.Map.t; trans_trait_impls : Pure.trait_impl Pure.TraitImplId.Map.t; diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index e97a9cd7..6c9c3a91 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1460,8 +1460,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = In such situation, we can remove the forward function definition altogether. *) -let keep_forward (trans : pure_fun_translation) : bool = - let { fwd; backs } = trans in +let keep_forward (fwd : fun_and_loops) (backs : fun_and_loops list) : bool = (* Note that at this point, the output types are no longer seen as tuples: * they should be lists of length 1. *) if @@ -1977,8 +1976,8 @@ end module FunLoopIdMap = Collections.MakeMap (FunLoopIdOrderedType) (** Filter the useless loop input parameters. *) -let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : - (bool * pure_fun_translation) list = +let filter_loop_inputs (transl : pure_fun_translation list) : + pure_fun_translation list = (* We need to explore groups of mutually recursive functions. In order to compute which parameters are useless, we need to explore the functions by groups of mutually recursive definitions. @@ -1996,7 +1995,7 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : (List.concat (List.concat (List.map - (fun (_, { fwd; backs }) -> + (fun { fwd; backs; _ } -> [ fwd.f :: fwd.loops ] :: List.map (fun { f = back; loops = loops_back } -> @@ -2246,13 +2245,13 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : in let transl = List.map - (fun (b, { fwd; backs }) -> + (fun trans -> let filter_fun_and_loops f = { f = filter_in_one f.f; loops = List.map filter_in_one f.loops } in - let fwd = filter_fun_and_loops fwd in - let backs = List.map filter_fun_and_loops backs in - (b, { fwd; backs })) + let fwd = filter_fun_and_loops trans.fwd in + let backs = List.map filter_fun_and_loops trans.backs in + { trans with fwd; backs }) transl in @@ -2273,18 +2272,17 @@ let filter_loop_inputs (transl : (bool * pure_fun_translation) list) : but convenient. *) let apply_passes_to_pure_fun_translations (ctx : trans_ctx) - (transl : (fun_decl * fun_decl list) list) : - (bool * pure_fun_translation) list = - let apply_to_one (trans : fun_decl * fun_decl list) : - bool * pure_fun_translation = + (transl : (fun_decl * fun_decl list) list) : pure_fun_translation list = + let apply_to_one (trans : fun_decl * fun_decl list) : pure_fun_translation = (* Apply the passes to the individual functions *) let fwd, backs = trans in let fwd = Option.get (apply_passes_to_def ctx fwd) in let backs = List.filter_map (apply_passes_to_def ctx) backs in - let trans = { fwd; backs } in (* Compute whether we need to filter the forward function or not *) - (keep_forward trans, trans) + let keep_fwd = keep_forward fwd backs in + { keep_fwd; fwd; backs } in + let transl = List.map apply_to_one transl in (* Filter the useless inputs in the loop functions *) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 7122e462..835edd46 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -305,7 +305,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) let translate_crate_to_pure (crate : A.crate) : trans_ctx * Pure.type_decl list - * (bool * pure_fun_translation) list + * pure_fun_translation list * Pure.trait_decl list * Pure.trait_impl list = (* Debug *) @@ -439,8 +439,7 @@ let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = in let has_opaque_funs = A.FunDeclId.Map.exists - (fun _ ((_, trans) : bool * pure_fun_translation) -> - Option.is_none trans.fwd.f.body) + (fun _ (trans : pure_fun_translation) -> Option.is_none trans.fwd.f.body) ctx.trans_funs in (has_opaque_types, has_opaque_funs) @@ -552,7 +551,7 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : A.GlobalDeclId.id) : unit = let global_decls = ctx.trans_ctx.global_context.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in - let _, trans = A.FunDeclId.Map.find global.body_id ctx.trans_funs in + let trans = A.FunDeclId.Map.find global.body_id ctx.trans_funs in assert (trans.fwd.loops = []); assert (trans.backs = []); let body = trans.fwd.f in @@ -665,7 +664,7 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) check if the forward and backward functions are mutually recursive. *) let export_functions_group (fmt : Format.formatter) (config : gen_config) - (ctx : gen_ctx) (pure_ls : (bool * pure_fun_translation) list) : unit = + (ctx : gen_ctx) (pure_ls : pure_fun_translation list) : unit = (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = PureUtils.FunLoopIdSet.mem (def.def_id, def.loop_id) @@ -675,7 +674,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Extract the decrease clauses template bodies *) if config.extract_template_decreases_clauses then List.iter - (fun (_, { fwd; _ }) -> + (fun { fwd; _ } -> (* We only generate decreases clauses for the forward functions, because the termination argument should only depend on the forward inputs. The backward functions thus use the same decreases clauses as the @@ -710,7 +709,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) let decls = List.concat (List.map - (fun (keep_fwd, { fwd; backs }) -> + (fun { keep_fwd; fwd; backs } -> let fwd = if keep_fwd then List.append fwd.loops [ fwd.f ] else [] in let backs : Pure.fun_decl list = List.concat @@ -734,8 +733,8 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (* Insert unit tests if necessary *) if config.test_trans_unit_functions then List.iter - (fun (keep_fwd, trans) -> - if keep_fwd then + (fun trans -> + if trans.keep_fwd then Extract.extract_unit_test_if_unit_fun ctx fmt trans.fwd.f) pure_ls @@ -788,7 +787,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) extract their type directly in the records we generate for the trait declarations themselves, there is no point in having separate type definitions) *) - match (snd pure_fun).fwd.f.Pure.kind with + match pure_fun.fwd.f.Pure.kind with | TraitMethodDecl _ -> () | _ -> (* Translate *) @@ -993,7 +992,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : * whether we should generate a decrease clause or not. *) let rec_functions = List.map - (fun (_, { fwd; _ }) -> + (fun { fwd; _ } -> let fwd_f = if fwd.f.Pure.signature.info.effect_info.is_rec then [ (fwd.f.def_id, None) ] @@ -1017,11 +1016,10 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : Pure.TypeDeclId.Map.of_list (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) in - let trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t = + let trans_funs : pure_fun_translation A.FunDeclId.Map.t = A.FunDeclId.Map.of_list (List.map - (fun ((keep_fwd, { fwd; backs }) : bool * pure_fun_translation) -> - (fwd.f.def_id, (keep_fwd, { fwd; backs }))) + (fun (trans : pure_fun_translation) -> (trans.fwd.f.def_id, trans)) trans_funs) in @@ -1072,10 +1070,10 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : let ctx = List.fold_left - (fun ctx ((keep_fwd, defs) : bool * pure_fun_translation) -> + (fun ctx (trans : pure_fun_translation) -> (* If requested by the user, register termination measures and decreases proofs for all the recursive functions *) - let fwd_def = defs.fwd.f in + let fwd_def = trans.fwd.f in let gen_decr_clause (def : Pure.fun_decl) = !Config.extract_decreases_clauses && PureUtils.FunLoopIdSet.mem @@ -1087,8 +1085,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : let is_global = fwd_def.Pure.is_global_decl_body in if is_global then ctx else - Extract.extract_fun_decl_register_names ctx keep_fwd gen_decr_clause - defs) + Extract.extract_fun_decl_register_names ctx trans.keep_fwd + gen_decr_clause trans) ctx (A.FunDeclId.Map.values trans_funs) in diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index 9fd27c59..f31dc458 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -33,7 +33,18 @@ type trans_ctx = { type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list -type pure_fun_translation = { fwd : fun_and_loops; backs : fun_and_loops list } + +type pure_fun_translation = { + keep_fwd : bool; + (** Should we extract the forward function? + + If the forward function returns `()` and there is exactly one + backward function, we may merge the forward into the backward + function and thus don't extract the forward function)? + *) + fwd : fun_and_loops; + backs : fun_and_loops list; +} let trans_ctx_to_type_formatter (ctx : trans_ctx) (type_params : Pure.type_var list) -- cgit v1.2.3 From e090e09725e3fd5c7f2a92813955ce2d81560227 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 19:44:39 +0200 Subject: Do more cleanup --- compiler/Extract.ml | 8 +++++--- compiler/ExtractBase.ml | 6 +++--- compiler/Translate.ml | 4 +--- 3 files changed, 9 insertions(+), 9 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 5c0a08ad..204fee04 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2326,7 +2326,7 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) (** Compute the names for all the pure functions generated from a rust function (forward function and backward functions). *) -let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) +let extract_fun_decl_register_names (ctx : extraction_ctx) (has_decreases_clause : fun_decl -> bool) (def : pure_fun_translation) : extraction_ctx = let { f = fwd; loops = loop_fwds } = def.fwd in @@ -2344,7 +2344,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) else ctx in let ctx = List.fold_left register_decreases ctx (fwd :: loop_fwds) in - let register_fun ctx f = ctx_add_fun_decl (keep_fwd, def) f ctx in + let register_fun ctx f = ctx_add_fun_decl def f ctx in let register_funs ctx fl = List.fold_left register_fun ctx fl in (* Register the forward functions' names *) let ctx = register_funs ctx (fwd :: loop_fwds) in @@ -3971,7 +3971,9 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) (* TODO: for the methods, we need to add fields for the forward/backward functions *) raise (Failure "TODO"); List.fold_left - (fun ctx (name, id) -> ctx_add_trait_method trait_decl name ctx) + (fun ctx (name, id) -> + (* We add one field per required forward/backward function *) + ctx_add_trait_method trait_decl name ctx) ctx required_methods (** Similar to {!extract_type_decl_register_names} *) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 885467c2..17f5b693 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1185,8 +1185,8 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : let ctx = ctx_add is_opaque body (name ^ "_body") ctx in ctx -let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) - (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = +let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) + (ctx : extraction_ctx) : extraction_ctx = (* Sanity check: the function should not be a global body - those are handled * separately *) assert (not def.is_global_decl_body); @@ -1197,7 +1197,7 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) in let sg = llbc_def.signature in let num_rgs = List.length sg.regions_hierarchy in - let keep_fwd, { fwd = _; backs } = trans_group in + let { keep_fwd; fwd = _; backs } = trans_group in let num_backs = List.length backs in let rg_info = match def.back_id with diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 835edd46..a4041751 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -1084,9 +1084,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : * those are handled later *) let is_global = fwd_def.Pure.is_global_decl_body in if is_global then ctx - else - Extract.extract_fun_decl_register_names ctx trans.keep_fwd - gen_decr_clause trans) + else Extract.extract_fun_decl_register_names ctx gen_decr_clause trans) ctx (A.FunDeclId.Map.values trans_funs) in -- cgit v1.2.3 From fcd1fbe048b55a89bd8ed34afa8ed2295798d3ec Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 20:12:59 +0200 Subject: Make progress registering the trait decl method names --- compiler/Extract.ml | 50 +++++++++++++++++++++------------ compiler/ExtractBase.ml | 74 +++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 93 insertions(+), 31 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 204fee04..2a678a27 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2329,8 +2329,8 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) let extract_fun_decl_register_names (ctx : extraction_ctx) (has_decreases_clause : fun_decl -> bool) (def : pure_fun_translation) : extraction_ctx = - let { f = fwd; loops = loop_fwds } = def.fwd in - let back_ls = def.backs in + let fwd = def.fwd in + let backs = def.backs in (* Register the decrease clauses, if necessary *) let register_decreases ctx def = if has_decreases_clause def then @@ -2343,22 +2343,19 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) | Lean -> ctx_add_decreases_proof def ctx else ctx in - let ctx = List.fold_left register_decreases ctx (fwd :: loop_fwds) in + let ctx = List.fold_left register_decreases ctx (fwd.f :: fwd.loops) in let register_fun ctx f = ctx_add_fun_decl def f ctx in let register_funs ctx fl = List.fold_left register_fun ctx fl in - (* Register the forward functions' names *) - let ctx = register_funs ctx (fwd :: loop_fwds) in - (* Register the backward functions' names *) + (* Register the names of the forward functions *) let ctx = - List.fold_left - (fun ctx { f = back; loops = loop_backs } -> - let ctx = register_fun ctx back in - register_funs ctx loop_backs) - ctx back_ls + if def.keep_fwd then register_funs ctx (fwd.f :: fwd.loops) else ctx in - - (* Return *) - ctx + (* Register the names of the backward functions *) + List.fold_left + (fun ctx { f = back; loops = loop_backs } -> + let ctx = register_fun ctx back in + register_funs ctx loop_backs) + ctx backs (** Simply add the global name to the context. *) let extract_global_decl_register_names (ctx : extraction_ctx) @@ -3927,6 +3924,27 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break to insert lines between declarations *) F.pp_print_break fmt 0 0 +(** Register the names for one trait method item *) +let extract_trait_decl_method_register_names (ctx : extraction_ctx) + (trait_decl : trait_decl) (name : string) (id : fun_decl_id) : + extraction_ctx = + (* We add one field per required forward/backward function *) + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + + let register_fun ctx f = ctx_add_trait_method trait_decl name f ctx in + let register_funs ctx fl = List.fold_left register_fun ctx fl in + (* Register the names of the forward functions *) + let ctx = + if trans.keep_fwd then register_funs ctx (trans.fwd.f :: trans.fwd.loops) + else ctx + in + (* Register the names of the backward functions *) + List.fold_left + (fun ctx back -> + let ctx = register_fun ctx back.f in + register_funs ctx back.loops) + ctx trans.backs + (** Similar to {!extract_type_decl_register_names} *) let extract_trait_decl_register_names (ctx : extraction_ctx) (trait_decl : trait_decl) : extraction_ctx = @@ -3968,12 +3986,10 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) ctx types in (* Required methods *) - (* TODO: for the methods, we need to add fields for the forward/backward functions *) - raise (Failure "TODO"); List.fold_left (fun ctx (name, id) -> (* We add one field per required forward/backward function *) - ctx_add_trait_method trait_decl name ctx) + extract_trait_decl_method_register_names ctx trait_decl name id) ctx required_methods (** Similar to {!extract_type_decl_register_names} *) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 17f5b693..e4d1fb7b 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -417,7 +417,14 @@ type id = | TraitDeclId of TraitDeclId.id | TraitImplId of TraitImplId.id | LocalTraitClauseId of TraitClauseId.id - | TraitItemId of TraitDeclId.id * string (** A trait associated item *) + | TraitMethodId of + TraitDeclId.id * string * LoopId.id option * T.RegionGroupId.id option + (** Something peculiar with trait methods: because we have to take into + account forward/backward functions, we may need to generate fields + items per method. + *) + | TraitItemId of TraitDeclId.id * string + (** A trait associated item which is not a method *) | TraitParentClauseId of TraitDeclId.id * TraitClauseId.id | TraitItemClauseId of TraitDeclId.id * string * TraitClauseId.id | TraitSelfClauseId @@ -677,6 +684,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let global_decls = ctx.trans_ctx.global_context.global_decls in let fun_decls = ctx.trans_ctx.fun_context.fun_decls in let type_decls = ctx.trans_ctx.type_context.type_decls in + let trait_decls = ctx.trans_ctx.trait_decls_context.trait_decls in (* TODO: factorize the pretty-printing with what is in PrintPure *) let get_type_name (id : type_id) : string = match id with @@ -812,6 +820,24 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TraitItemId (id, name) -> "trait_item_id: decl_id:" ^ TraitDeclId.to_string id ^ ", type name: " ^ name + | TraitMethodId (trait_decl_id, fun_name, lp_id, rg_id) -> + let trait_name = + Print.fun_name_to_string + (A.TraitDeclId.Map.find trait_decl_id trait_decls).name + in + let lp_kind = + match lp_id with + | None -> "" + | Some lp_id -> "loop " ^ LoopId.to_string lp_id ^ ", " + in + + let fwd_back_kind = + match rg_id with + | None -> "forward" + | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id + in + "trait " ^ trait_name ^ " method name (" ^ lp_kind ^ fwd_back_kind ^ "): " + ^ fun_name | TraitSelfClauseId -> "trait_self_clause" (** We might not check for collisions for some specific ids (ex.: field names) *) @@ -1185,11 +1211,8 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : let ctx = ctx_add is_opaque body (name ^ "_body") ctx in ctx -let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) - (ctx : extraction_ctx) : extraction_ctx = - (* Sanity check: the function should not be a global body - those are handled - * separately *) - assert (not def.is_global_decl_body); +let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) + (ctx : extraction_ctx) : string = (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in let llbc_def = @@ -1211,12 +1234,22 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) in Some { id = rg_id; region_names } in + (* Add the function name *) + ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info + (keep_fwd, num_backs) + +let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) + (ctx : extraction_ctx) : extraction_ctx = + (* Sanity check: the function should not be a global body - those are handled + * separately *) + assert (not def.is_global_decl_body); + (* Lookup the LLBC def to compute the region group information *) + let def_id = def.def_id in + let { keep_fwd; fwd = _; backs } = trans_group in + let num_backs = List.length backs in let is_opaque = def.body = None in (* Add the function name *) - let def_name = - ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info - (keep_fwd, num_backs) - in + 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 ctx = ctx_add is_opaque (FunId (FromLlbc fun_id)) def_name ctx in (* Add the name info *) @@ -1251,11 +1284,24 @@ let ctx_add_trait_type (d : trait_decl) (item : string) (ctx : extraction_ctx) : let name = ctx.fmt.trait_type_name d item in ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx -let ctx_add_trait_method (d : trait_decl) (item : string) (ctx : extraction_ctx) - : extraction_ctx = +let ctx_add_trait_method (d : trait_decl) (item_name : string) (f : fun_decl) + (ctx : extraction_ctx) : extraction_ctx = + (* We do something special: we use the base name but remove everything + but the crate (because [get_name] removes it) and the last ident. + This allows us to reuse the [ctx_compute_fun_decl] function. + *) + let basename : name = + match (f.basename : name) with + | Ident crate :: name -> Ident crate :: [ Collections.List.last name ] + | _ -> raise (Failure "Unexpected") + in + let f = { f with basename } in + let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in + let name = ctx_compute_fun_name trans f ctx in let is_opaque = false in - let name = ctx.fmt.trait_method_name d item in - ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx + ctx_add is_opaque + (TraitMethodId (d.def_id, item_name, f.loop_id, f.back_id)) + name ctx let ctx_add_trait_parent_clause (d : trait_decl) (clause : trait_clause) (ctx : extraction_ctx) : extraction_ctx = -- cgit v1.2.3 From fd17736cbdb312578b2ea6de9a58febf83bd96c8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 20:41:42 +0200 Subject: Extract the trait decl methods --- compiler/Extract.ml | 66 +++++++++++++++++++++++++++++++++++-------------- compiler/ExtractBase.ml | 22 ++++++----------- 2 files changed, 54 insertions(+), 34 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 2a678a27..138619c4 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -3213,6 +3213,11 @@ let extract_fun_input_parameters_types (ctx : extraction_ctx) in List.iter extract_param def.signature.inputs +let extract_fun_inputs_output_parameters_types (ctx : extraction_ctx) + (fmt : F.formatter) (def : fun_decl) : unit = + extract_fun_input_parameters_types ctx fmt def; + extract_ty ctx fmt TypeDeclId.Set.empty false def.signature.output + let assert_backend_supports_decreases_clauses () = match !backend with | FStar | Lean -> () @@ -3931,19 +3936,10 @@ let extract_trait_decl_method_register_names (ctx : extraction_ctx) (* We add one field per required forward/backward function *) let trans = A.FunDeclId.Map.find id ctx.trans_funs in - let register_fun ctx f = ctx_add_trait_method trait_decl name f ctx in - let register_funs ctx fl = List.fold_left register_fun ctx fl in - (* Register the names of the forward functions *) - let ctx = - if trans.keep_fwd then register_funs ctx (trans.fwd.f :: trans.fwd.loops) - else ctx - in - (* Register the names of the backward functions *) - List.fold_left - (fun ctx back -> - let ctx = register_fun ctx back.f in - register_funs ctx back.loops) - ctx trans.backs + let register_fun ctx f = ctx_add_trait_method trait_decl name f.f ctx in + (* Register the names *) + let funs = if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs in + List.fold_left register_fun ctx funs (** Similar to {!extract_type_decl_register_names} *) let extract_trait_decl_register_names (ctx : extraction_ctx) @@ -4016,18 +4012,50 @@ let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ";"; F.pp_close_box fmt () +(** Small helper - TODO: move *) +let generic_params_drop_prefix (g1 : generic_params) (g2 : generic_params) : + generic_params = + let open Collections.List in + let types = drop (length g1.types) g2.types in + let const_generics = drop (length g1.const_generics) g2.const_generics in + let trait_clauses = drop (length g1.trait_clauses) g2.trait_clauses in + { types; const_generics; trait_clauses } + (** Small helper. Extract the items for a method in a trait decl. *) let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) - (decl : trait_decl) (name : string) (id : fun_decl_id) : unit = - let item_name = ctx_get_trait_const decl.def_id name ctx in + (decl : trait_decl) (item_name : string) (id : fun_decl_id) : unit = (* Lookup the definition *) - (* let def = - FunDeclId.Map.find ctx. - in *) - raise (Failure "TODO") + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + (* Extract the items *) + let funs = if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs in + let extract_method (f : fun_and_loops) = + let f = f.f in + let fun_name = ctx_get_trait_method decl.def_id item_name f.back_id ctx in + let ty () = + (* Extract the generics *) + (* We need to add the generics specific to the method, by removing those + which actually apply to the trait decl *) + let generics = + generic_params_drop_prefix decl.generics f.signature.generics + in + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params generics ctx + in + let use_forall = generics <> empty_generic_params in + let use_implicits = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall + use_implicits None None generics type_params cg_params trait_clauses; + if use_forall then F.pp_print_string fmt ","; + (* Extract the inputs and output *) + F.pp_print_space fmt (); + extract_fun_inputs_output_parameters_types ctx fmt f + in + extract_trait_decl_item ctx fmt fun_name ty + in + List.iter extract_method funs (** Extract a trait declaration *) let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index e4d1fb7b..435aa10c 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -417,8 +417,7 @@ type id = | TraitDeclId of TraitDeclId.id | TraitImplId of TraitImplId.id | LocalTraitClauseId of TraitClauseId.id - | TraitMethodId of - TraitDeclId.id * string * LoopId.id option * T.RegionGroupId.id option + | TraitMethodId of TraitDeclId.id * string * T.RegionGroupId.id option (** Something peculiar with trait methods: because we have to take into account forward/backward functions, we may need to generate fields items per method. @@ -820,23 +819,17 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TraitItemId (id, name) -> "trait_item_id: decl_id:" ^ TraitDeclId.to_string id ^ ", type name: " ^ name - | TraitMethodId (trait_decl_id, fun_name, lp_id, rg_id) -> + | TraitMethodId (trait_decl_id, fun_name, rg_id) -> let trait_name = Print.fun_name_to_string (A.TraitDeclId.Map.find trait_decl_id trait_decls).name in - let lp_kind = - match lp_id with - | None -> "" - | Some lp_id -> "loop " ^ LoopId.to_string lp_id ^ ", " - in - let fwd_back_kind = match rg_id with | None -> "forward" | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id in - "trait " ^ trait_name ^ " method name (" ^ lp_kind ^ fwd_back_kind ^ "): " + "trait " ^ trait_name ^ " method name (" ^ fwd_back_kind ^ "): " ^ fun_name | TraitSelfClauseId -> "trait_self_clause" @@ -960,8 +953,9 @@ let ctx_get_trait_type (id : trait_decl_id) (item_name : string) ctx_get_trait_item id item_name ctx let ctx_get_trait_method (id : trait_decl_id) (item_name : string) - (ctx : extraction_ctx) : string = - ctx_get_trait_item id item_name ctx + (rg_id : T.RegionGroupId.id option) (ctx : extraction_ctx) : string = + let with_opaque_pre = false in + ctx_get with_opaque_pre (TraitMethodId (id, item_name, rg_id)) ctx let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = @@ -1299,9 +1293,7 @@ let ctx_add_trait_method (d : trait_decl) (item_name : string) (f : fun_decl) let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in let name = ctx_compute_fun_name trans f ctx in let is_opaque = false in - ctx_add is_opaque - (TraitMethodId (d.def_id, item_name, f.loop_id, f.back_id)) - name ctx + ctx_add is_opaque (TraitMethodId (d.def_id, item_name, f.back_id)) name ctx let ctx_add_trait_parent_clause (d : trait_decl) (clause : trait_clause) (ctx : extraction_ctx) : extraction_ctx = -- cgit v1.2.3 From 25a741f1d79c537f5da4d21275eabdb1cc73ca89 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 3 Sep 2023 21:16:50 +0200 Subject: Implement extract_trait_impl --- compiler/Extract.ml | 166 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 160 insertions(+), 6 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 138619c4..8aee8c4f 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -4000,18 +4000,27 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) The type `ty` is to be understood in a very general sense. *) -let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) - (item_name : string) (ty : unit -> unit) : unit = +let extract_trait_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (separator : string) (ty : unit -> unit) : unit = F.pp_print_space fmt (); F.pp_open_vbox fmt ctx.indent_incr; F.pp_print_string fmt item_name; F.pp_print_space fmt (); - F.pp_print_string fmt ":"; + (* ":" or "=" *) + F.pp_print_string fmt separator; F.pp_print_space fmt (); ty (); F.pp_print_string fmt ";"; F.pp_close_box fmt () +let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (ty : unit -> unit) : unit = + extract_trait_item ctx fmt item_name ":" ty + +let extract_trait_impl_item (ctx : extraction_ctx) (fmt : F.formatter) + (item_name : string) (ty : unit -> unit) : unit = + extract_trait_item ctx fmt item_name "=" ty + (** Small helper - TODO: move *) let generic_params_drop_prefix (g1 : generic_params) (g2 : generic_params) : generic_params = @@ -4094,7 +4103,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) let use_forall = false in let as_implicits = false in extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits - None None decl.generics type_params cg_params trait_clauses; + None None generics type_params cg_params trait_clauses; F.pp_print_space fmt (); F.pp_print_string fmt "{"; @@ -4164,10 +4173,155 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 +(** Small helper. + + Extract the items for a method in a trait impl. + *) +let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) + (impl : trait_impl) (item_name : string) (id : fun_decl_id) + (impl_generics : string list * string list * string list) : unit = + let trait_decl_id = impl.impl_trait.trait_decl_id in + (* Lookup the definition *) + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + (* Extract the items *) + let funs = if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs in + let extract_method (f : fun_and_loops) = + let f = f.f in + let fun_name = ctx_get_trait_method trait_decl_id item_name f.back_id ctx in + let ty () = + (* Extract the generics - we need to quantify over the generics which + are specific to the method, and call it will all the generics + (trait impl + method generics) *) + let f_generics = + generic_params_drop_prefix impl.generics f.signature.generics + in + let ctx, f_tys, f_cgs, f_tcs = ctx_add_generic_params f_generics ctx in + let use_forall = f_generics <> empty_generic_params in + let use_implicits = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall + use_implicits None None 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 (); + let id = ctx_get_local_function false f.def_id None f.back_id ctx in + F.pp_print_string fmt id; + let all_generics = + let i_tys, i_cgs, i_tcs = impl_generics in + List.concat [ i_tys; f_tys; i_cgs; f_cgs; i_tcs; f_tcs ] + in + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + all_generics + in + extract_trait_impl_item ctx fmt fun_name ty + in + List.iter extract_method funs + (** Extract a trait implementation *) let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) - (trait_impl : trait_impl) : unit = - raise (Failure "TODO") + (impl : trait_impl) : unit = + (* Retrieve the impl name *) + let with_opaque_pre = false in + let impl_name = ctx_get_trait_impl with_opaque_pre impl.def_id ctx in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + extract_comment fmt [ "[" ^ Print.name_to_string impl.name ^ "]" ]; + F.pp_print_break fmt 0 0; + (* Open two boxes for the definition, so that whenever possible it gets printed on + * one line and indents are correct *) + F.pp_open_hvbox fmt 0; + F.pp_open_vbox fmt ctx.indent_incr; + + (* `let Trait (....) =` *) + (* Open the box for the name + generics *) + F.pp_open_vbox fmt ctx.indent_incr; + let qualif = + Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec None) + in + F.pp_print_string fmt qualif; + F.pp_print_space fmt (); + F.pp_print_string fmt impl_name; + + (* Print the generics *) + (* 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.generics ctx + in + let all_generics = (type_params, cg_params, trait_clauses) in + let use_forall = false in + let as_implicits = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits + None None impl.generics type_params cg_params trait_clauses; + + F.pp_print_space fmt (); + F.pp_print_string fmt "{"; + + (* Close the box for the name + generics *) + F.pp_close_box fmt (); + + (* + * Extract the items + *) + + (* The parent clauses - we retrieve those from the impl_ref *) + let trait_decl_id = impl.impl_trait.trait_decl_id in + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = ctx_get_trait_parent_clause trait_decl_id clause_id ctx in + let ty () = + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + impl.impl_trait.decl_generics.trait_refs; + + (* The constants *) + List.iter + (fun (name, (_, id)) -> + let item_name = ctx_get_trait_const trait_decl_id name ctx in + let ty () = F.pp_print_string fmt (ctx_get_global false id ctx) in + + extract_trait_impl_item ctx fmt item_name ty) + impl.consts; + + (* The types *) + List.iter + (fun (name, (trait_refs, ty)) -> + (* Extract the type *) + let item_name = ctx_get_trait_type trait_decl_id name ctx in + let ty () = extract_ty ctx fmt TypeDeclId.Set.empty false ty in + extract_trait_impl_item ctx fmt item_name ty; + (* Extract the clauses *) + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = + ctx_get_trait_item_clause trait_decl_id name clause_id ctx + in + let ty () = + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + trait_refs) + impl.types; + + (* The required methods *) + List.iter + (fun (name, id) -> + extract_trait_impl_method_items ctx fmt impl name id all_generics) + impl.required_methods; + + (* Close the brackets *) + F.pp_print_space fmt (); + F.pp_print_string fmt "}"; + + (* Close the two outer boxes for the definition *) + F.pp_close_box fmt (); + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). -- cgit v1.2.3 From 3151e373d64f9bce6146a44cd2d3cc64cac84cbf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 4 Sep 2023 00:59:39 +0200 Subject: Fix minor issues --- compiler/Driver.ml | 4 +++- compiler/SymbolicToPure.ml | 14 ++++++++++++-- 2 files changed, 15 insertions(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/Driver.ml b/compiler/Driver.ml index b646a53d..d88962db 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -17,7 +17,9 @@ let log = main_log let _ = (* Set up the logging - for now we use default values - TODO: use the * command-line arguments *) - (* By setting a level for the main_logger_handler, we filter everything *) + (* By setting a level for the main_logger_handler, we filter everything. + To have a good trace: one should switch between Info and Debug. + *) Easy_logging.Handlers.set_level main_logger_handler EL.Debug; main_log#set_level EL.Info; llbc_of_json_logger#set_level EL.Info; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 1a981de1..46eef953 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -242,6 +242,12 @@ let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types generics.const_generics +let ctx_egeneric_args_to_string (ctx : bs_ctx) (args : T.egeneric_args) : string + = + let fmt = bs_ctx_to_ctx_formatter ctx in + let fmt = Print.PC.ctx_to_etype_formatter fmt in + Print.PT.egeneric_args_to_string fmt args + let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let fmt = bs_ctx_to_ctx_formatter ctx in let fmt = Print.PC.ctx_to_rtype_formatter fmt in @@ -381,8 +387,8 @@ let bs_ctx_register_backward_call (abs : V.abs) (call_id : V.FunCallId.id) of types: sty, forward types, backward types, etc.) *) let rec translate_generic_args (translate_ty : 'r T.ty -> ty) (generics : 'r T.generic_args) : generic_args = - (* Can't translate types with regions for now *) - assert (generics.regions = []); + (* We ignore the regions: if they didn't cause trouble for the symbolic execution, + then everything's fine *) let types = List.map translate_ty generics.types in let const_generics = generics.const_generics in let trait_refs = @@ -1588,6 +1594,10 @@ and translate_return_with_loop (loop_id : V.LoopId.id) (is_continue : bool) and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : texpression = + log#ldebug + (lazy + ("translate_function_call:\n" + ^ ctx_egeneric_args_to_string ctx call.generics)); (* Translate the function call *) let generics = ctx_translate_fwd_generic_args ctx call.generics in let args = -- cgit v1.2.3 From e18160aa7a796989cc6ff7c953ee088023a3ea93 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 4 Sep 2023 01:09:22 +0200 Subject: Fix a minor issue in HOL4 --- compiler/Extract.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 8aee8c4f..de6c2fc8 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1239,7 +1239,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) | Assumed _ -> true | _ -> raise (Failure "Unreachable") in - if const_generics <> [] && print_tys then ( + if types <> [] && print_tys then ( let print_paren = List.length types > 1 in if print_paren then F.pp_print_string fmt "("; Collections.List.iter_link -- cgit v1.2.3 From 8b18c0da053e069b5a2d9fbf06f45eae2f05a029 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 7 Sep 2023 15:28:06 +0200 Subject: Map some globals like u32::MAX to standard definitions --- compiler/Driver.ml | 14 ------------- compiler/Extract.ml | 8 +++++++- compiler/ExtractAssumed.ml | 49 ++++++++++++++++++++++++++++++++++++++++++++++ compiler/ExtractBase.ml | 22 ++++++++++++++++----- compiler/LlbcAstUtils.ml | 20 +++++++++++++++++++ compiler/Translate.ml | 36 +++++++++++++++++----------------- compiler/dune | 1 + 7 files changed, 112 insertions(+), 38 deletions(-) create mode 100644 compiler/ExtractAssumed.ml (limited to 'compiler') diff --git a/compiler/Driver.ml b/compiler/Driver.ml index d88962db..0fde1d74 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -222,20 +222,6 @@ let () = in if has_loops then log#lwarning (lazy "Support for loops is experimental"); - (* If we target Lean, we request the crates to be split into several files - whenever there are opaque functions *) - if - !backend = Lean - && A.FunDeclId.Map.exists - (fun _ (d : A.fun_decl) -> d.body = None) - m.functions - && not !split_files - then ( - log#error - "For Lean, we request the -split-file option whenever using opaque \ - functions"; - fail ()); - (* We don't support mutually recursive definitions with decreases clauses in Lean *) if !backend = Lean && !extract_decreases_clauses diff --git a/compiler/Extract.ml b/compiler/Extract.ml index de6c2fc8..74540787 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -8,6 +8,7 @@ open Pure open PureUtils open TranslateCore open ExtractBase +open ExtractAssumed open StringUtils open Config module F = Format @@ -3852,8 +3853,13 @@ let extract_global_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (* Print the type *) F.pp_open_hovbox fmt 0; extract_ty ctx fmt TypeDeclId.Set.empty false ty; + (* Close the definition *) + F.pp_print_string fmt ")"; + F.pp_close_box fmt (); + (* Close the definition box *) F.pp_close_box fmt (); - (* Close the definition boxe *) F.pp_close_box fmt () + (* Add a line *) + F.pp_print_space fmt () (** Extract a global declaration. diff --git a/compiler/ExtractAssumed.ml b/compiler/ExtractAssumed.ml new file mode 100644 index 00000000..bbcedb2b --- /dev/null +++ b/compiler/ExtractAssumed.ml @@ -0,0 +1,49 @@ +(** This file declares external identifiers that we catch to map them to + definitions coming from the standard libraries in our backends. *) + +open Utils +open StringUtils +open Names + +type simple_name = string list [@@deriving show, ord] + +let name_to_simple_name (s : name) : simple_name = + (* We simply ignore the disambiguators *) + List.filter_map (function Ident id -> Some id | Disambiguator _ -> None) s + +(** Small helper which cuts a string at the occurrences of "::" *) +let string_to_simple_name (s : string) : simple_name = + (* No function to split by using string separator?? *) + let name = String.split_on_char ':' s in + List.filter (fun s -> s <> "") name + +module SimpleNameOrd = struct + type t = simple_name + + let compare = compare_simple_name + let to_string = show_simple_name + let pp_t = pp_simple_name + let show_t = show_simple_name +end + +module SimpleNameMap = Collections.MakeMap (SimpleNameOrd) + +let assumed_globals : (string * string) list = + [ + ("core::num::usize::MAX", "usize_max"); + ("core::num::u8::MAX", "u8_max"); + ("core::num::u16::MAX", "u16_max"); + ("core::num::u32::MAX", "u32_max"); + ("core::num::u64::MAX", "u64_max"); + ("core::num::u128::MAX", "u128_max"); + ("core::num::isize::MAX", "isize_max"); + ("core::num::i8::MAX", "i8_max"); + ("core::num::i16::MAX", "i16_max"); + ("core::num::i32::MAX", "i32_max"); + ("core::num::i64::MAX", "i64_max"); + ("core::num::i128::MAX", "i128_max"); + ] + +let assumed_globals_map : string SimpleNameMap.t = + SimpleNameMap.of_list + (List.map (fun (x, y) -> (string_to_simple_name x, y)) assumed_globals) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 435aa10c..9c9e08a5 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -5,6 +5,7 @@ open TranslateCore module C = Contexts module RegionVarId = T.RegionVarId module F = Format +open ExtractAssumed (** The local logger *) let log = L.pure_to_extract_log @@ -1198,12 +1199,23 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = (* TODO: update once the body id can be an option *) let is_opaque = false in - let name = ctx.fmt.global_name def.name in let decl = GlobalId def.def_id in - let body = FunId (FromLlbc (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 + + (* Check if the global corresponds to an assumed global that we should map + to a custom definition in our standard library (for instance, happens + with "core::num::usize::MAX") *) + let sname = name_to_simple_name def.name in + match SimpleNameMap.find_opt sname assumed_globals_map with + | Some name -> + (* Yes: register the custom binding *) + ctx_add is_opaque decl name 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 ctx = ctx_add is_opaque decl (name ^ "_c") ctx in + let ctx = ctx_add is_opaque body (name ^ "_body") ctx in + ctx let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) (ctx : extraction_ctx) : string = diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 1111c297..8c8bbabe 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -12,3 +12,23 @@ let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : match fun_id with | Regular id -> (FunDeclId.Map.find id fun_decls).name | Assumed aid -> Assumed.get_assumed_name aid + +(** Return the opaque declarations found in the crate. + + Remark: the list of functions also contains the list of opaque global bodies. + *) +let crate_get_opaque_decls (k : crate) : T.type_decl list * fun_decl list = + let open ExtractAssumed in + let is_opaque_fun (d : fun_decl) : bool = + let sname = name_to_simple_name d.name in + d.body = None && not (SimpleNameMap.mem sname assumed_globals_map) + in + let is_opaque_type (d : T.type_decl) : bool = d.kind = T.Opaque in + (* Note that by checking the function bodies we also the globals *) + ( List.filter is_opaque_type (T.TypeDeclId.Map.values k.types), + List.filter is_opaque_fun (FunDeclId.Map.values k.functions) ) + +(** Return true if the crate contains opaque declarations, ignoring the assumed + definitions. *) +let crate_has_opaque_decls (k : crate) : bool = + crate_get_opaque_decls k <> ([], []) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index a4041751..90066163 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -430,19 +430,9 @@ type gen_config = { } (** Returns the pair: (has opaque type decls, has opaque fun decls) *) -let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = - let has_opaque_types = - Pure.TypeDeclId.Map.exists - (fun _ (d : Pure.type_decl) -> - match d.kind with Opaque -> true | _ -> false) - ctx.trans_types - in - let has_opaque_funs = - A.FunDeclId.Map.exists - (fun _ (trans : pure_fun_translation) -> Option.is_none trans.fwd.f.body) - ctx.trans_funs - in - (has_opaque_types, has_opaque_funs) +let crate_has_opaque_decls (ctx : gen_ctx) : bool * bool = + let types, funs = LlbcAstUtils.crate_get_opaque_decls ctx.crate in + (types <> [], funs <> []) (** Export a type declaration. @@ -557,11 +547,20 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) let body = trans.fwd.f in let is_opaque = Option.is_none body.Pure.body in - if + (* Check if we extract the global *) + let extract = config.extract_globals && (((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque)) - then + in + (* Check if it is an assumed global - if yes, we ignore it because we + map the definition to one in the standard library *) + let open ExtractAssumed in + let sname = name_to_simple_name global.name in + let extract = + extract && SimpleNameMap.find_opt sname assumed_globals_map = None + in + if extract then (* We don't wrap global declaration groups between calls to functions [{start, end}_global_decl_group] (which don't exist): global declaration groups are always singletons, so the [extract_global_decl] function @@ -828,7 +827,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) config.extract_opaque && config.extract_fun_decls && !Config.wrap_opaque_in_sig && - let _, opaque_funs = module_has_opaque_decls ctx in + let _, opaque_funs = crate_has_opaque_decls ctx in opaque_funs in if wrap_in_sig then ( @@ -1233,7 +1232,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (* Check if there are opaque types and functions - in which case we need * to split *) - let has_opaque_types, has_opaque_funs = module_has_opaque_decls ctx in + let has_opaque_types, has_opaque_funs = crate_has_opaque_decls ctx in let has_opaque_types = has_opaque_types || !Config.use_state in (* Extract the types *) @@ -1302,7 +1301,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in extract_file template_clauses_config ctx file_info); - (* Extract the opaque functions, if needed *) + (* Extract the opaque declarations, if needed *) let opaque_funs_module = if has_opaque_funs then ( (* In the case of Lean we generate a template file *) @@ -1330,6 +1329,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_fun_decls = true; + extract_globals = true; extract_transparent = false; extract_opaque = true; interface = true; diff --git a/compiler/dune b/compiler/dune index db099c3c..2f5a0a44 100644 --- a/compiler/dune +++ b/compiler/dune @@ -22,6 +22,7 @@ Expressions ExpressionsUtils Extract + ExtractAssumed ExtractBase FunsAnalysis Identifiers -- cgit v1.2.3 From 1181aecddbcb3232c21b191fbde59c2e9596846a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 7 Sep 2023 16:02:43 +0200 Subject: Fix some issues --- compiler/Extract.ml | 1 - compiler/ExtractAssumed.ml | 40 ++++++++++++++++++++++++++-------------- 2 files changed, 26 insertions(+), 15 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 74540787..8baa3c88 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -8,7 +8,6 @@ open Pure open PureUtils open TranslateCore open ExtractBase -open ExtractAssumed open StringUtils open Config module F = Format diff --git a/compiler/ExtractAssumed.ml b/compiler/ExtractAssumed.ml index bbcedb2b..7f094b24 100644 --- a/compiler/ExtractAssumed.ml +++ b/compiler/ExtractAssumed.ml @@ -1,8 +1,6 @@ (** This file declares external identifiers that we catch to map them to definitions coming from the standard libraries in our backends. *) -open Utils -open StringUtils open Names type simple_name = string list [@@deriving show, ord] @@ -30,18 +28,32 @@ module SimpleNameMap = Collections.MakeMap (SimpleNameOrd) let assumed_globals : (string * string) list = [ - ("core::num::usize::MAX", "usize_max"); - ("core::num::u8::MAX", "u8_max"); - ("core::num::u16::MAX", "u16_max"); - ("core::num::u32::MAX", "u32_max"); - ("core::num::u64::MAX", "u64_max"); - ("core::num::u128::MAX", "u128_max"); - ("core::num::isize::MAX", "isize_max"); - ("core::num::i8::MAX", "i8_max"); - ("core::num::i16::MAX", "i16_max"); - ("core::num::i32::MAX", "i32_max"); - ("core::num::i64::MAX", "i64_max"); - ("core::num::i128::MAX", "i128_max"); + (* Min *) + ("core::num::usize::MIN", "core_usize_min"); + ("core::num::u8::MIN", "core_u8_min"); + ("core::num::u16::MIN", "core_u16_min"); + ("core::num::u32::MIN", "core_u32_min"); + ("core::num::u64::MIN", "core_u64_min"); + ("core::num::u128::MIN", "core_u128_min"); + ("core::num::isize::MIN", "core_isize_min"); + ("core::num::i8::MIN", "core_i8_min"); + ("core::num::i16::MIN", "core_i16_min"); + ("core::num::i32::MIN", "core_i32_min"); + ("core::num::i64::MIN", "core_i64_min"); + ("core::num::i128::MIN", "core_i128_min"); + (* Max *) + ("core::num::usize::MAX", "core_usize_max"); + ("core::num::u8::MAX", "core_u8_max"); + ("core::num::u16::MAX", "core_u16_max"); + ("core::num::u32::MAX", "core_u32_max"); + ("core::num::u64::MAX", "core_u64_max"); + ("core::num::u128::MAX", "core_u128_max"); + ("core::num::isize::MAX", "core_isize_max"); + ("core::num::i8::MAX", "core_i8_max"); + ("core::num::i16::MAX", "core_i16_max"); + ("core::num::i32::MAX", "core_i32_max"); + ("core::num::i64::MAX", "core_i64_max"); + ("core::num::i128::MAX", "core_i128_max"); ] let assumed_globals_map : string SimpleNameMap.t = -- cgit v1.2.3 From 8233c5a4918864166f877c9fcea19b4250185583 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 10 Sep 2023 20:29:18 +0200 Subject: Implement handling of trait method function calls --- compiler/InterpreterStatements.ml | 181 ++++++++++++++++++++++++-------------- 1 file changed, 115 insertions(+), 66 deletions(-) (limited to 'compiler') diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 3a483b80..5791a359 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -582,8 +582,10 @@ 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) (generics : T.egeneric_args) - (args : E.operand list) (dest : E.place) : cm_fun = + (fid : A.assumed_fun_id) (call : A.call) : cm_fun = + let generics = call.generics in + let args = call.args in + let dest = call.dest in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) assert (generics.const_generics = []); @@ -906,9 +908,16 @@ 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 generics = TypesUtils.mk_empty_generic_args in - (eval_transparent_function_call_concrete config global.body_id generics [] - dest) + let call = + { + A.func = A.FunId (A.Regular global.body_id); + generics = TypesUtils.mk_empty_generic_args; + trait_and_method_generic_args = None; + args = []; + dest; + } + in + (eval_transparent_function_call_concrete config global.body_id call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be @@ -1057,18 +1066,38 @@ and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = - this is an assumed function, in which case there is a special treatment - this is a trait method *) + match config.mode with + | C.ConcreteMode -> eval_function_call_concrete config call + | C.SymbolicMode -> eval_function_call_symbolic config call + +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) -> - eval_transparent_function_call config fid call.generics call.args - call.dest + eval_transparent_function_call_concrete config fid call cf ctx | A.FunId (A.Assumed fid) -> - eval_assumed_function_call config fid call.generics call.args call.dest - | A.TraitMethod _ -> raise (Failure "Unimplemented") + (* 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") + +and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun + = + match call.func with + | 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 (** 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) (generics : T.egeneric_args) (args : E.operand list) - (dest : E.place) : st_cm_fun = + (fid : A.FunDeclId.id) (call : A.call) : st_cm_fun = + let generics = call.A.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 in concrete mode yet *) assert (generics.const_generics = []); @@ -1149,23 +1178,73 @@ and eval_transparent_function_call_concrete (config : C.config) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (config : C.config) - (fid : A.FunDeclId.id) (generics : T.egeneric_args) (args : E.operand list) - (dest : E.place) : st_cm_fun = +and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) + : st_cm_fun = fun cf ctx -> - (* Retrieve the (correctly instantiated) signature *) - let def = C.ctx_lookup_fun_decl ctx fid in - let sg = def.A.signature in - (* Instantiate the signature and introduce fresh abstraction and region ids - * while doing so *) - (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let inst_sg = instantiate_fun_sig ctx generics tr_self sg in + (* Instantiate the signature and introduce fresh abstractions and region ids while doing so *) + let def, inst_sg = + match call.func with + | A.FunId (A.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 + in + (def, inst_sg) + | A.FunId (A.Assumed _) -> + (* Unreachable: must be a transparent function *) + raise (Failure "Unreachable") + | A.TraitMethod (trait_ref, method_name) -> ( + (* 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 + (* 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 *) + match trait_ref.trait_id with + | TraitImpl impl_id -> + (* Lookup the trait impl *) + let trait_impl = C.ctx_lookup_trait_impl ctx impl_id in + let _, method_id = + List.find + (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) + | _ -> + (* 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 *) + let _, method_id = + List.find + (fun (s, _) -> s = method_name) + trait_decl.required_methods + in + let method_def = C.ctx_lookup_fun_decl ctx method_id in + (* Instantiate *) + let tr_self = T.TraitRef trait_ref in + let tr_self = + TypesUtils.etrait_instance_id_no_regions_to_gr_trait_instance_id + tr_self + in + let inst_sg = + instantiate_fun_sig ctx generics tr_self method_def.A.signature + in + (method_def, inst_sg)) + in (* Sanity check *) - assert (List.length args = List.length def.A.signature.inputs); + assert (List.length call.args = List.length def.A.signature.inputs); (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.Regular fid) inst_sg - generics args dest cf ctx + eval_function_call_symbolic_from_inst_sig config call.func inst_sg + call.generics call.args call.dest cf ctx (** Evaluate a function call in symbolic mode by using the function signature. @@ -1173,9 +1252,12 @@ and eval_transparent_function_call_symbolic (config : C.config) calls in symbolic mode: only their signatures matter. *) and eval_function_call_symbolic_from_inst_sig (config : C.config) - (fid : A.fun_id) (inst_sg : A.inst_fun_sig) (generics : T.egeneric_args) - (args : E.operand list) (dest : E.place) : st_cm_fun = + (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 = 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 @@ -1304,9 +1386,11 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (** Evaluate a non-local function call in symbolic mode *) and eval_assumed_function_call_symbolic (config : C.config) - (fid : A.assumed_fun_id) (generics : T.egeneric_args) - (args : E.operand list) (dest : E.place) : st_cm_fun = + (fid : A.assumed_fun_id) (call : A.call) : st_cm_fun = fun cf ctx -> + let generics = call.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 *) assert ( @@ -1342,43 +1426,8 @@ and eval_assumed_function_call_symbolic (config : C.config) in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (A.Assumed fid) inst_sig - generics args dest cf ctx - -(** Evaluate a non-local (i.e, assumed) function call such as [Box::deref] - (auxiliary helper for [eval_statement]) *) -and eval_assumed_function_call (config : C.config) (fid : A.assumed_fun_id) - (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : - st_cm_fun = - fun cf ctx -> - (* Debug *) - log#ldebug - (lazy - (let generics = PCtx.egeneric_args_to_string ctx generics in - let args = - "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" - in - let dest = place_to_string ctx dest in - "eval_assumed_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- generics: " ^ generics ^ "\n- args: " ^ args ^ "\n- dest: " ^ dest)); - - match config.mode with - | C.ConcreteMode -> - eval_assumed_function_call_concrete config fid generics args dest - (cf Unit) ctx - | C.SymbolicMode -> - eval_assumed_function_call_symbolic config fid generics args dest cf ctx - -(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for - [eval_statement]) *) -and eval_transparent_function_call (config : C.config) (fid : A.FunDeclId.id) - (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : - st_cm_fun = - match config.mode with - | ConcreteMode -> - eval_transparent_function_call_concrete config fid generics args dest - | SymbolicMode -> - eval_transparent_function_call_symbolic config fid generics args dest + eval_function_call_symbolic_from_inst_sig config (A.FunId (A.Assumed fid)) + inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = -- cgit v1.2.3 From c6b88a2e54b7697262ad3677ad7500471c68e332 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 10 Sep 2023 21:07:06 +0200 Subject: Add support for the trait associated constants --- compiler/Extract.ml | 13 ++++++++++++- compiler/InterpreterBorrows.ml | 2 +- compiler/InterpreterExpressions.ml | 40 ++++++++++++++++++++++++++++++++++---- compiler/InterpreterUtils.ml | 2 +- compiler/PrintPure.ml | 8 +++++++- compiler/Pure.ml | 4 +++- compiler/PureTypeCheck.ml | 1 + compiler/ReorderDecls.ml | 4 +++- compiler/SymbolicAst.ml | 8 +++++++- compiler/SymbolicToPure.ml | 12 ++++++++++-- compiler/Values.ml | 2 ++ 11 files changed, 83 insertions(+), 13 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 8baa3c88..d000c447 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2544,7 +2544,18 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) | AdtCons adt_cons_id -> extract_adt_cons ctx fmt inside adt_cons_id qualif.generics args | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.generics args) + extract_field_projector ctx fmt inside app proj qualif.generics args + | TraitConst (trait_ref, generics, const_name) -> + let use_brackets = generics <> empty_generic_args in + if use_brackets then F.pp_print_string fmt "("; + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref; + extract_generic_args ctx fmt TypeDeclId.Set.empty generics; + let name = + ctx_get_trait_const trait_ref.trait_decl_ref.trait_decl_id + const_name ctx + in + if use_brackets then F.pp_print_string fmt ")"; + F.pp_print_string fmt ("." ^ name)) | _ -> (* "Regular" expression *) (* Open parentheses *) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index f908d060..e97795a1 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -453,7 +453,7 @@ let give_back_symbolic_value (_config : C.config) -> () | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate - | ConstGeneric -> + | ConstGeneric | TraitConst -> raise (Failure "Unreachable")); (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 51f6ff05..29826233 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -271,9 +271,41 @@ 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) -> - (* TODO *) - raise (Failure "Unimplemented") + | E.TraitConst (trait_ref, generics, const_name) -> ( + assert (generics = TypesUtils.mk_empty_generic_args); + match trait_ref.trait_id with + | T.TraitImpl _ -> + (* This shouldn't happen: if we refer to a concrete implementation, we + should directly refer to the top-level constant *) + raise (Failure "Unreachable") + | _ -> ( + (* We refer to a constant defined in a local clause: simply + introduce a fresh symbolic value *) + let ctx0 = ctx in + (* Lookup the trait declaration to retrieve the type of the symbolic value *) + let trait_decl = + C.ctx_lookup_trait_decl ctx + trait_ref.trait_decl_ref.trait_decl_id + in + let _, (ty, _) = + List.find (fun (name, _) -> name = const_name) trait_decl.consts + in + (* Introduce a fresh symbolic value *) + let v = mk_fresh_symbolic_typed_value_from_ety V.TraitConst ty in + (* Continue the evaluation *) + let e = cf v ctx in + (* We have to wrap the generated expression *) + match e with + | None -> None + | Some e -> + Some + (SymbolicAst.IntroSymbolic + ( ctx0, + None, + value_as_symbolic v.value, + SymbolicAst.TraitConstValue + (trait_ref, generics, const_name), + e )))) | E.CVar vid -> ( let ctx0 = ctx in (* Lookup the const generic value *) @@ -283,7 +315,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) let ctx, v = copy_value allow_adt_copy config ctx cv in (* Continue *) let e = cf v ctx in - (* We have to wrap the expression to introduce *) + (* We have to wrap the generated expression *) match e with | None -> None | Some e -> diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 1513465c..0986c53b 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -256,7 +256,7 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) else () | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack | V.SynthRetGivenBack | V.Global | V.LoopGivenBack | V.Aggregate - | V.ConstGeneric -> + | V.ConstGeneric | V.TraitConst -> () end in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index fc39074d..c7f59ec9 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -733,6 +733,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) match app.e with | Qualif qualif -> (* Qualifier case *) + let ty_fmt = ast_to_type_formatter fmt in (* Convert the qualifier identifier *) let qualif_s = match qualif.id with @@ -751,9 +752,14 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) let field_s = adt_field_to_string value_fmt adt_id field_id in (* Adopting an F*-like syntax *) ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s + | TraitConst (trait_ref, generics, const_name) -> + let trait_ref = trait_ref_to_string ty_fmt true trait_ref in + let generics_s = generic_args_to_string ty_fmt generics in + if generics <> empty_generic_args then + "(" ^ trait_ref ^ generics_s ^ ")." ^ const_name + else trait_ref ^ "." ^ const_name in (* Convert the type instantiation *) - let ty_fmt = ast_to_type_formatter fmt in let generics = generic_args_to_strings ty_fmt true qualif.generics in (* *) (qualif_s, generics) diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 6c9f41f1..81060c43 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -567,9 +567,11 @@ type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] type qualif_id = | FunOrOp of fun_or_op_id (** A function or an operation *) - | Global of GlobalDeclId.id + | Global of global_decl_id | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) | Proj of projection (** Field projector *) + | TraitConst of trait_ref * generic_args * string + (** A trait associated constant *) [@@deriving show] (** An instantiated qualifier. diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 27736ecb..b80ff72f 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -142,6 +142,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = match qualif.id with | FunOrOp _ -> () (* TODO *) | Global _ -> () (* TODO *) + | TraitConst _ -> () (* TODO *) | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) diff --git a/compiler/ReorderDecls.ml b/compiler/ReorderDecls.ml index fc4744bc..db646a87 100644 --- a/compiler/ReorderDecls.ml +++ b/compiler/ReorderDecls.ml @@ -38,7 +38,9 @@ let compute_body_fun_deps (e : texpression) : FunIdSet.t = method! visit_qualif _ id = match id.id with - | FunOrOp (Unop _ | Binop _) | Global _ | AdtCons _ | Proj _ -> () + | FunOrOp (Unop _ | Binop _) + | Global _ | AdtCons _ | Proj _ | TraitConst _ -> + () | FunOrOp (Fun fid) -> ( match fid with | Pure _ -> () diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 0f107897..b170ebe5 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -120,6 +120,9 @@ class ['self] iter_expression_base = method visit_symbolic_expansion : 'env -> V.symbolic_expansion -> unit = fun _ _ -> () + + method visit_etrait_ref : 'env -> T.etrait_ref -> unit = fun _ _ -> () + method visit_egeneric_args : 'env -> T.egeneric_args -> unit = fun _ _ -> () end (** **Rem.:** here, {!expression} is not at all equivalent to the expressions @@ -174,7 +177,8 @@ type expression = This is used for instance when reorganizing the environment to compute fixed points: we duplicate some shared symbolic values to destructure the shared values, in order to make the environment a bit more general - (while losing precision of course). + (while losing precision of course). We also use it to introduce symbolic + values when evaluating constant generics, or trait constants. The context is the evaluation context from before introducing the new value. It has the same purpose as for the {!Return} case. @@ -256,6 +260,8 @@ and value_aggregate = | ConstGenericValue of T.const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) + | TraitConstValue of T.etrait_ref * T.egeneric_args * string + (** A trait constant value *) [@@deriving show, visitors diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 46eef953..3312e22d 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2411,8 +2411,9 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (* Translate the next expression *) let next_e = translate_expression e ctx in - (* Translate the value: there are two cases, depending on whether this - is a "regular" let-binding or an array aggregate. + (* Translate the value: there are several cases, depending on whether this + is a "regular" let-binding, an array aggregate, a const generic or + a trait associated constant. *) let v = match v with @@ -2428,6 +2429,13 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) in { e = StructUpdate su; ty = var.ty } | ConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } + | TraitConstValue (trait_ref, generics, const_name) -> + let type_infos = ctx.type_context.type_infos in + let trait_ref = translate_fwd_trait_ref type_infos trait_ref in + let generics = translate_fwd_generic_args type_infos generics in + let qualif_id = TraitConst (trait_ref, generics, const_name) in + let qualif = { id = qualif_id; generics = empty_generic_args } in + { e = Qualif qualif; ty = var.ty } in (* Make the let-binding *) diff --git a/compiler/Values.ml b/compiler/Values.ml index 58737557..de27e7a9 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -54,6 +54,8 @@ type sv_kind = (** A symbolic value we introduce in place of an aggregate value *) | ConstGeneric (** A symbolic value we introduce when using a const generic as a value *) + | TraitConst + (** A symbolic value we introduce when evaluating a trait associated constant *) [@@deriving show, ord] (** Ancestor for {!symbolic_value} iter visitor *) -- cgit v1.2.3 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') 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.2.3 From 78a2731924aa13989998c6be4a5a6865ce5098aa Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 13 Sep 2023 07:33:30 +0200 Subject: Make minor modifications --- compiler/Contexts.ml | 12 ++++++++++++ compiler/InterpreterStatements.ml | 8 ++++++-- compiler/InterpreterUtils.ml | 6 +++++- compiler/Print.ml | 22 +++++++++++++++------- compiler/SymbolicToPure.ml | 37 ------------------------------------- 5 files changed, 38 insertions(+), 47 deletions(-) (limited to 'compiler') diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 9d22a643..df77959e 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -333,9 +333,21 @@ type eval_ctx = { } [@@deriving show] +let lookup_type_var_opt (ctx : eval_ctx) (vid : TypeVarId.id) : type_var option + = + if TypeVarId.to_int vid < List.length ctx.type_vars then + Some (TypeVarId.nth ctx.type_vars vid) + else None + let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = TypeVarId.nth ctx.type_vars vid +let lookup_const_generic_var_opt (ctx : eval_ctx) (vid : ConstGenericVarId.id) : + const_generic_var option = + if ConstGenericVarId.to_int vid < List.length ctx.const_generic_vars then + Some (ConstGenericVarId.nth ctx.const_generic_vars vid) + else None + let lookup_const_generic_var (ctx : eval_ctx) (vid : ConstGenericVarId.id) : const_generic_var = ConstGenericVarId.nth ctx.const_generic_vars vid diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 1ea16e58..97fb80f4 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1198,7 +1198,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) log#ldebug (lazy ("trait method call:\n- call: " ^ call_to_string ctx call - ^ "\n- method name: " ^ method_name ^ "\n- generics:\n" + ^ "\n- method name: " ^ method_name ^ "\n- call.generics:\n" ^ egeneric_args_to_string ctx call.generics ^ "\n- trait and method generics:\n" ^ egeneric_args_to_string ctx @@ -1273,7 +1273,10 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("provided method call:" ^ "\n- method name: " ^ method_name ^ "\n- generics:\n" - ^ egeneric_args_to_string ctx generics)); + ^ egeneric_args_to_string ctx generics + ^ "\n- parent params info: " + ^ Print.option_to_string A.show_params_info + method_def.signature.parent_params_info)); let tr_self = T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) in @@ -1303,6 +1306,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (List.append trait_decl.required_methods provided) in let method_def = C.ctx_lookup_fun_decl ctx method_id in + log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); (* Instantiate *) let tr_self = T.TraitRef trait_ref in let tr_self = diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 8a7e8c52..8525be29 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -39,8 +39,12 @@ 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 fun_decl_to_string = PA.fun_decl_to_string let call_to_string = PA.call_to_string -let trait_impl_to_string = PA.trait_impl_to_string + +let trait_impl_to_string ctx = + PA.trait_impl_to_string { ctx with type_vars = []; const_generic_vars = [] } + let statement_to_string ctx = PA.statement_to_string ctx "" " " let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " let env_elem_to_string ctx = PA.env_elem_to_string ctx "" " " diff --git a/compiler/Print.ml b/compiler/Print.ml index 55aa0c53..92743bc1 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -479,19 +479,23 @@ module Contexts = struct PV.value_to_rtype_formatter fmt let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - (* We shouldn't use rvar_to_string *) - let rvar_to_string _r = - raise (Failure "Unexpected use of rvar_to_string") + let rvar_to_string r = + (* In theory we shouldn't use rvar_to_string, but it can happen + when printing definitions for instance... *) + T.RegionVarId.to_string r in let r_to_string r = PT.region_id_to_string r in let type_var_id_to_string vid = - let v = C.lookup_type_var ctx vid in - v.name + (* The context may be invalid *) + match C.lookup_type_var_opt ctx vid with + | None -> T.TypeVarId.to_string vid + | Some v -> v.name in let const_generic_var_id_to_string vid = - let v = C.lookup_const_generic_var ctx vid in - v.name + match C.lookup_const_generic_var_opt ctx vid with + | None -> T.ConstGenericVarId.to_string vid + | Some v -> v.name in let type_decl_id_to_string def_id = let def = C.ctx_lookup_type_decl ctx def_id in @@ -702,6 +706,10 @@ module EvalCtxLlbcAst = struct let fmt = PC.eval_ctx_to_ast_formatter ctx in PA.call_to_string fmt "" call + let fun_decl_to_string (ctx : C.eval_ctx) (f : A.fun_decl) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.fun_decl_to_string fmt "" " " f + let 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/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 1da0521d..4c5b99c3 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -346,43 +346,6 @@ let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) let id = (A.Regular def_id, back_id) in (RegularFunIdNotLoopMap.find id ctx.fun_context.fun_sigs).sg -let bs_ctx_register_forward_call (call_id : V.FunCallId.id) (forward : S.call) - (args : texpression list) (ctx : bs_ctx) : bs_ctx = - let calls = ctx.calls in - assert (not (V.FunCallId.Map.mem call_id calls)); - let info = - { forward; forward_inputs = args; backwards = T.RegionGroupId.Map.empty } - in - let calls = V.FunCallId.Map.add call_id info calls in - { ctx with calls } - -(** [back_args]: the *additional* list of inputs received by the backward function *) -let bs_ctx_register_backward_call (abs : V.abs) (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, _) -> 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) - (* Some generic translation functions (we need to translate different "flavours" of types: sty, forward types, backward types, etc.) *) let rec translate_generic_args (translate_ty : 'r T.ty -> ty) -- cgit v1.2.3 From d556b2439ad858fbbf612f433d25363a8f4a7c83 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 13 Sep 2023 18:43:23 +0200 Subject: Fix more issues --- compiler/AssociatedTypes.ml | 90 ++++++++++++++++++++++++++++++++++++++++++--- compiler/Config.ml | 8 ++++ compiler/Print.ml | 22 +++++++++++ compiler/SymbolicToPure.ml | 77 +++++++++++++++++++++----------------- 4 files changed, 157 insertions(+), 40 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index c4a9538d..bce0fb11 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -15,6 +15,7 @@ module C = Contexts module Subst = Substitute module L = Logging module UF = UnionFind +module PA = Print.EvalCtxLlbcAst (** The local logger *) let log = L.associated_types_log @@ -111,6 +112,10 @@ type 'r norm_ctx = { get_ty_repr : 'r C.trait_type_ref -> 'r T.ty option; convert_ety : T.ety -> 'r T.ty; convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; + ty_to_string : 'r T.ty -> string; + trait_ref_to_string : 'r T.trait_ref -> string; + trait_instance_id_to_string : 'r T.trait_instance_id -> string; + pp_r : Format.formatter -> 'r -> unit; } (** Normalize a type by simplyfying the references to trait associated types @@ -118,6 +123,7 @@ type 'r norm_ctx = { enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. *) let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = fun ctx ty -> + log#ldebug (lazy ("ctx_normalize_ty: " ^ ctx.ty_to_string ty)); match ty with | T.Adt (id, generics) -> Adt (id, ctx_normalize_generic_args ctx generics) | TypeVar _ | Literal _ | Never -> ty @@ -125,19 +131,56 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = let ty = ctx_normalize_ty ctx ty in T.Ref (r, ty, rkind) | TraitType (trait_ref, generics, type_name) -> ( + log#ldebug + (lazy + ("ctx_normalize_ty: trait type: " ^ ctx.ty_to_string ty + ^ "\n- trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref: " + ^ T.show_trait_ref ctx.pp_r trait_ref)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = ctx_normalize_trait_ref ctx trait_ref in let generics = ctx_normalize_generic_args ctx generics in let ty : 'r T.ty = match trait_ref.trait_id with - | T.TraitRef { T.trait_id = T.TraitImpl impl_id; generics; _ } -> + | T.TraitRef + { T.trait_id = T.TraitImpl impl_id; generics = ref_generics; _ } -> + assert (ref_generics = TypesUtils.mk_empty_generic_args); + log#ldebug + (lazy + ("ctx_normalize_ty: trait type: trait ref: " + ^ ctx.ty_to_string ty)); (* Lookup the implementation *) let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* Lookup the type *) let ty = snd (List.assoc type_name trait_impl.types) in (* Annoying: convert etype to an stype - TODO: hwo to avoid that? *) let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in - (* Substitute - annoying: we can't use *) + (* Substitute *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = + Subst.make_subst_from_generics_no_regions trait_impl.generics + generics tr_self + in + let ty = Subst.ty_substitute subst ty in + (* Reconvert *) + let ty : 'r T.ty = ctx.convert_ety (Subst.erase_regions ty) in + (* Normalize *) + ctx_normalize_ty ctx ty + | T.TraitImpl impl_id -> + (* This happens. This doesn't come from the substituations + performed by Aeneas (the [TraitImpl] would be wrapped in a + [TraitRef] but from non-normalized traits translated from + the Rustc AST. + TODO: factor out with the branch above. + *) + (* Lookup the implementation *) + let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in + (* Lookup the type *) + let ty = snd (List.assoc type_name trait_impl.types) in + (* Annoying: convert etype to an stype - TODO: hwo to avoid that? *) + let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in + (* Substitute *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = Subst.make_subst_from_generics_no_regions trait_impl.generics @@ -149,6 +192,13 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = (* Normalize *) ctx_normalize_ty ctx ty | _ -> + log#ldebug + (lazy + ("ctx_normalize_ty: trait type: not a trait ref: " + ^ ctx.ty_to_string ty ^ "\n- trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref: " + ^ T.show_trait_ref ctx.pp_r trait_ref)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); T.TraitType (trait_ref, generics, type_name) @@ -307,11 +357,31 @@ and ctx_normalize_generic_args (ctx : 'r norm_ctx) and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : 'r T.trait_ref = + log#ldebug + (lazy + ("ctx_normalize_trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref:\n" + ^ T.show_trait_ref ctx.pp_r trait_ref)); let { T.trait_id; generics; trait_decl_ref } = trait_ref in - let trait_id, _ = ctx_normalize_trait_instance_id ctx trait_id in - let generics = ctx_normalize_generic_args ctx generics in - let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in - { T.trait_id; generics; trait_decl_ref } + (* Check if the id is an impl, otherwise normalize it *) + let trait_id, norm_trait_ref = ctx_normalize_trait_instance_id ctx trait_id in + match norm_trait_ref with + | None -> + log#ldebug + (lazy + ("ctx_normalize_trait_ref: no norm: " + ^ ctx.trait_instance_id_to_string trait_id)); + let generics = ctx_normalize_generic_args ctx generics in + let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in + { T.trait_id; generics; trait_decl_ref } + | Some trait_ref -> + log#ldebug + (lazy + ("ctx_normalize_trait_ref: normalized to: " + ^ ctx.trait_ref_to_string trait_ref)); + assert (generics = TypesUtils.mk_empty_generic_args); + trait_ref (* Not sure this one is really necessary *) and ctx_normalize_trait_decl_ref (ctx : 'r norm_ctx) @@ -335,6 +405,10 @@ let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = get_ty_repr; convert_ety = TypesUtils.ety_no_regions_to_rty; convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; + ty_to_string = PA.rty_to_string ctx; + trait_ref_to_string = PA.rtrait_ref_to_string ctx; + trait_instance_id_to_string = PA.rtrait_instance_id_to_string ctx; + pp_r = T.pp_region T.pp_region_id; } let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = @@ -344,6 +418,10 @@ let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = get_ty_repr; convert_ety = (fun x -> x); convert_etrait_ref = (fun x -> x); + ty_to_string = PA.ety_to_string ctx; + trait_ref_to_string = PA.etrait_ref_to_string ctx; + trait_instance_id_to_string = PA.etrait_instance_id_to_string ctx; + pp_r = T.pp_erased_region; } let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = diff --git a/compiler/Config.ml b/compiler/Config.ml index ccbb4c75..508746d9 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -331,3 +331,11 @@ let record_fields_short_names = ref false and to account for type constraints (like [fn f(...) where T::bar = usize]). *) let parameterize_trait_types = ref false + +(** For sanity check: type check the generated pure code (activates checks in + several places). + + TODO: deactivated for now because we need to implement the normalization of + trait associated types in the pure code. + *) +let type_check_pure_code = ref false diff --git a/compiler/Print.ml b/compiler/Print.ml index 92743bc1..93a1f970 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -651,6 +651,28 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_rtype_formatter fmt in PT.rty_to_string fmt t + 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 + PT.etrait_ref_to_string fmt x + + let rtrait_ref_to_string (ctx : C.eval_ctx) (x : T.rtrait_ref) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rtrait_ref_to_string fmt x + + let etrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.etrait_instance_id) + : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_etype_formatter fmt in + PT.etrait_instance_id_to_string fmt x + + let rtrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.rtrait_instance_id) + : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_rtype_formatter fmt in + PT.rtrait_instance_id_to_string fmt x + let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 4c5b99c3..2e0e9862 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -687,8 +687,9 @@ let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = () let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = - let ctx = mk_type_check_ctx ctx in - PureTypeCheck.check_texpression ctx e + if !Config.type_check_pure_code then + 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 = @@ -1817,9 +1818,11 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) (* Group the two lists *) let variables_values = List.combine given_back_variables consumed_values in (* Sanity check: the two lists match (same types) *) - List.iter - (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) - variables_values; + (* TODO: normalize the types *) + if !Config.type_check_pure_code then + List.iter + (fun (var, v) -> assert ((var : var).ty = (v : texpression).ty)) + variables_values; (* Translate the next expression *) let next_e = translate_expression e ctx in (* Generate the assignemnts *) @@ -1892,31 +1895,35 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) | Some nstate -> mk_simpl_tuple_pattern [ nstate; output ] in (* Sanity check: there is the proper number of inputs and outputs, and they have the proper type *) - let _ = - let inst_sg = get_instantiated_fun_sig fun_id (Some rg_id) generics ctx in - log#ldebug - (lazy - ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" - ^ string_of_int (List.length inputs) - ^ "): " - ^ String.concat ", " (List.map (texpression_to_string ctx) inputs) - ^ "\n- inst_sg.inputs (" - ^ string_of_int (List.length inst_sg.inputs) - ^ "): " - ^ String.concat ", " (List.map (ty_to_string ctx) inst_sg.inputs))); - List.iter - (fun (x, ty) -> assert ((x : texpression).ty = ty)) - (List.combine inputs inst_sg.inputs); - log#ldebug - (lazy - ("\n- outputs: " - ^ string_of_int (List.length outputs) - ^ "\n- expected outputs: " - ^ string_of_int (List.length inst_sg.doutputs))); - List.iter - (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) - (List.combine outputs inst_sg.doutputs) - in + (if (* TODO: normalize the types *) !Config.type_check_pure_code then + match fun_id with + | A.FunId fun_id -> + let inst_sg = + get_instantiated_fun_sig fun_id (Some rg_id) generics ctx + in + log#ldebug + (lazy + ("\n- fun_id: " ^ A.show_fun_id fun_id ^ "\n- inputs (" + ^ string_of_int (List.length inputs) + ^ "): " + ^ String.concat ", " (List.map (texpression_to_string ctx) inputs) + ^ "\n- inst_sg.inputs (" + ^ string_of_int (List.length inst_sg.inputs) + ^ "): " + ^ String.concat ", " (List.map (ty_to_string ctx) inst_sg.inputs))); + List.iter + (fun (x, ty) -> assert ((x : texpression).ty = ty)) + (List.combine inputs inst_sg.inputs); + log#ldebug + (lazy + ("\n- outputs: " + ^ string_of_int (List.length outputs) + ^ "\n- expected outputs: " + ^ string_of_int (List.length inst_sg.doutputs))); + List.iter + (fun (x, ty) -> assert ((x : typed_pattern).ty = ty)) + (List.combine outputs inst_sg.doutputs) + | _ -> (* TODO: trait methods *) ()); (* Retrieve the function id, and register the function call in the context * if necessary *) let ctx, func = @@ -2961,10 +2968,12 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = ^ "\n- signature.inputs: " ^ String.concat ", " (List.map (ty_to_string ctx) signature.inputs) )); - assert ( - List.for_all - (fun (var, ty) -> (var : var).ty = ty) - (List.combine inputs signature.inputs)); + (* TODO: we need to normalize the types *) + if !Config.type_check_pure_code then + assert ( + List.for_all + (fun (var, ty) -> (var : var).ty = ty) + (List.combine inputs signature.inputs)); Some { inputs; inputs_lvs; body } in -- cgit v1.2.3 From 60aa9ff5b31e47ecc2ac2dff55ee06582af62806 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 13 Sep 2023 23:39:13 +0200 Subject: Fix some issues --- compiler/AssociatedTypes.ml | 4 +-- compiler/Contexts.ml | 13 ++++++++ compiler/Interpreter.ml | 64 ++++++++++++++++++++++++++++++--------- compiler/InterpreterStatements.ml | 7 +++++ compiler/InterpreterUtils.ml | 2 ++ compiler/Logging.ml | 3 ++ compiler/Print.ml | 4 +++ 7 files changed, 81 insertions(+), 16 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index bce0fb11..92cd464e 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -136,7 +136,7 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = ("ctx_normalize_ty: trait type: " ^ ctx.ty_to_string ty ^ "\n- trait_ref: " ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref: " + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref ctx.pp_r trait_ref)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = ctx_normalize_trait_ref ctx trait_ref in @@ -197,7 +197,7 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = ("ctx_normalize_ty: trait type: not a trait ref: " ^ ctx.ty_to_string ty ^ "\n- trait_ref: " ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref: " + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref ctx.pp_r trait_ref)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index df77959e..65760d94 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -5,6 +5,7 @@ open LlbcAst module V = Values open ValuesUtils open Identifiers +module L = Logging (** The [Id] module for dummy variables. @@ -17,6 +18,9 @@ IdGen () type dummy_var_id = DummyVarId.id [@@deriving show, ord] +(** The local logger *) +let log = L.contexts_log + (** Some global counters. Note that those counters were initially stored in {!eval_ctx} values, @@ -449,6 +453,15 @@ let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = *) let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx = + log#ldebug + (lazy + ("push_vars:\n" + ^ String.concat "\n" + (List.map + (fun (var, value) -> + (* We can unfortunately not use Print because it depends on Contexts... *) + show_var var ^ " -> " ^ V.show_typed_value value) + vars))); assert ( List.for_all (fun (var, (value : typed_value)) -> var.var_ty = value.ty) diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index b5e9fcb9..4ce6dae8 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -64,15 +64,39 @@ let initialize_eval_context (ctx : C.decls_ctx) C.ended_regions = T.RegionId.Set.empty; } -(** Instantiate a function signature for a symbolic execution *) -let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (fdef : A.fun_decl) : +(** Small helper. + + Normalize an instantiated function signature provided we used this signature + to compute a normalization map (for the associated types) and that we added + it in the context. + *) +let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : A.inst_fun_sig = + let { A.regions_hierarchy = _; trait_type_constraints = _; inputs; output } = + sg + in + let norm = AssociatedTypes.ctx_normalize_rty ctx in + let inputs = List.map norm inputs in + let output = norm output in + { sg with A.inputs; output } + +(** Instantiate a function signature for a symbolic execution. + + We return a new context because we compute and add the type normalization + map in the same step. + + **WARNING**: this doesn't normalize the types. This step has to be done + separately. Remark: we need to normalize essentially because of the where + clauses (we are not considering a function call, so we don't need to + normalize because a trait clause was instantiated with a specific trait ref). + *) +let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (fdef : A.fun_decl) : + C.eval_ctx * A.inst_fun_sig = let sg = fdef.signature in let tr_self = match fdef.kind with | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ - | TraitMethodDecl _ | TraitMethodProvided _ -> - raise (Failure "Unimplemented") + | TraitMethodDecl _ | TraitMethodProvided _ -> T.Self in let generics = let { T.regions; types; const_generics; trait_clauses } = sg.generics in @@ -98,12 +122,27 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (fdef : A.fun_decl) : let { T.trait_id = trait_decl_id; generics; _ } = c in let generics = Subst.generic_args_substitute subst generics in let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in - { T.trait_id = T.Clause c.clause_id; generics; trait_decl_ref }) + (* Note that because we directly refer to the clause, we give it + empty generics *) + { + T.trait_id = T.Clause c.clause_id; + generics = TypesUtils.mk_empty_generic_args; + trait_decl_ref; + }) trait_clauses in { T.regions; types; const_generics; trait_refs } in - instantiate_fun_sig ctx generics tr_self sg + let inst_sg = instantiate_fun_sig ctx generics tr_self sg in + (* Compute the normalization maps *) + let ctx = + AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx + inst_sg.trait_type_constraints + in + (* Normalize the signature *) + let inst_sg = normalize_inst_fun_sig ctx inst_sg in + (* Return *) + (ctx, inst_sg) (** Initialize an evaluation context to execute a function. @@ -140,13 +179,10 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) initialize_eval_context ctx region_groups sg.generics.types sg.generics.const_generics in - (* Instantiate the signature *) - let inst_sg = symbolic_instantiate_fun_sig ctx fdef in - (* Compute the normalization maps *) - let ctx = - AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx - inst_sg.trait_type_constraints - in + (* Instantiate the signature. This updates the context because we compute + at the same time the normalization map for the associated types. + *) + let ctx, inst_sg = symbolic_instantiate_fun_sig ctx fdef in (* Create fresh symbolic values for the inputs *) let input_svs = List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs @@ -221,7 +257,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return * an instantiation of the signature, so that we use fresh * region ids for the return abstractions. *) let sg = fdef.signature in - let ret_inst_sg = symbolic_instantiate_fun_sig ctx fdef in + let _, ret_inst_sg = symbolic_instantiate_fun_sig ctx fdef in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) let pop_return_value = is_regular_return in diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 97fb80f4..88e20a92 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -664,6 +664,13 @@ let eval_assumed_function_call_concrete (config : C.config) let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + log#ldebug + (lazy + ("instantiate_fun_sig:" ^ "\n- generics: " + ^ egeneric_args_to_string ctx generics + ^ "\n- tr_self: " + ^ rtrait_instance_id_to_string ctx tr_self + ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 8525be29..6fde8d68 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -39,6 +39,8 @@ let typed_avalue_to_string = PA.typed_avalue_to_string let place_to_string = PA.place_to_string let operand_to_string = PA.operand_to_string let egeneric_args_to_string = PA.egeneric_args_to_string +let rtrait_instance_id_to_string = PA.rtrait_instance_id_to_string +let fun_sig_to_string = PA.fun_sig_to_string let fun_decl_to_string = PA.fun_decl_to_string let call_to_string = PA.call_to_string diff --git a/compiler/Logging.ml b/compiler/Logging.ml index d0f5b0c5..59abbfc7 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -9,6 +9,9 @@ let pre_passes_log = L.get_logger "MainLogger.PrePasses" (** Logger for Translate *) let translate_log = L.get_logger "MainLogger.Translate" +(** Logger for Contexts *) +let contexts_log = L.get_logger "MainLogger.Contexts" + (** Logger for PureUtils *) let pure_utils_log = L.get_logger "MainLogger.PureUtils" diff --git a/compiler/Print.ml b/compiler/Print.ml index 93a1f970..522d9fdd 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -732,6 +732,10 @@ module EvalCtxLlbcAst = struct let fmt = PC.eval_ctx_to_ast_formatter ctx in PA.fun_decl_to_string fmt "" " " f + let fun_sig_to_string (ctx : C.eval_ctx) (x : A.fun_sig) : string = + let fmt = PC.eval_ctx_to_ast_formatter ctx in + PA.fun_sig_to_string fmt "" " " x + let 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 -- cgit v1.2.3 From 378bfbd1be69ee54cfe7fad97ca3b09d0f80f62b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 14 Sep 2023 00:24:29 +0200 Subject: Fix some issues with the name collisions --- compiler/ExtractBase.ml | 32 +++++++++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 438a3475..6789b5b8 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -840,7 +840,8 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = match id with - | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ -> + | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ + | TraitMethodId _ -> !Config.record_fields_short_names | _ -> false @@ -1285,19 +1286,29 @@ let ctx_add_trait_const (d : trait_decl) (item : string) (ctx : extraction_ctx) : extraction_ctx = let is_opaque = false in let name = ctx.fmt.trait_const_name d item in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name d ^ name + in ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx let ctx_add_trait_type (d : trait_decl) (item : string) (ctx : extraction_ctx) : extraction_ctx = let is_opaque = false in let name = ctx.fmt.trait_type_name d item in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name d ^ name + in ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx let ctx_add_trait_method (d : trait_decl) (item_name : string) (f : fun_decl) (ctx : extraction_ctx) : extraction_ctx = (* We do something special: we use the base name but remove everything - but the crate (because [get_name] removes it) and the last ident. - This allows us to reuse the [ctx_compute_fun_decl] function. + but the crate (because [get_name] removes it) and the last ident. + This allows us to reuse the [ctx_compute_fun_decl] function. *) let basename : name = match (f.basename : name) with @@ -1307,6 +1318,11 @@ let ctx_add_trait_method (d : trait_decl) (item_name : string) (f : fun_decl) let f = { f with basename } in let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in let name = ctx_compute_fun_name trans f ctx in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name d ^ name + in let is_opaque = false in ctx_add is_opaque (TraitMethodId (d.def_id, item_name, f.back_id)) name ctx @@ -1314,12 +1330,22 @@ let ctx_add_trait_parent_clause (d : trait_decl) (clause : trait_clause) (ctx : extraction_ctx) : extraction_ctx = let is_opaque = false in let name = ctx.fmt.trait_parent_clause_name d clause in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name d ^ name + in ctx_add is_opaque (TraitParentClauseId (d.def_id, clause.clause_id)) name ctx let ctx_add_trait_type_clause (d : trait_decl) (item : string) (clause : trait_clause) (ctx : extraction_ctx) : extraction_ctx = let is_opaque = false in let name = ctx.fmt.trait_type_clause_name d item clause in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name d ^ name + in ctx_add is_opaque (TraitItemClauseId (d.def_id, item, clause.clause_id)) name ctx -- cgit v1.2.3 From e8aa3804ef0134631cc16b257775ad8f98690c29 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 14 Sep 2023 00:42:46 +0200 Subject: Make progress on the extraction --- compiler/Config.ml | 4 ++++ compiler/Extract.ml | 10 +++++++++- compiler/ExtractBase.ml | 16 +++++++++++----- 3 files changed, 24 insertions(+), 6 deletions(-) (limited to 'compiler') diff --git a/compiler/Config.ml b/compiler/Config.ml index 508746d9..62f6c300 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -339,3 +339,7 @@ let parameterize_trait_types = ref false trait associated types in the pure code. *) let type_check_pure_code = ref false + +(** Shall we fail hard if there is an issue at code-generation time? + We may not want in case outputting a code with holes helps debugging *) +let extract_fail_hard = ref false diff --git a/compiler/Extract.ml b/compiler/Extract.ml index fe007d31..864d513f 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -529,7 +529,15 @@ let type_decl_kind_to_qualif (kind : decl_kind) *) Some "with" | (Assumed | Declared), None -> Some "Axiom" - | _ -> raise (Failure "Unexpected")) + | SingleNonRec, None -> + (* This is for traits *) + Some "Record" + | _ -> + raise + (Failure + ("Unexpected: (" ^ show_decl_kind kind ^ ", " + ^ Print.option_to_string show_type_decl_kind type_kind + ^ ")"))) | Lean -> ( match kind with | SingleNonRec -> diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 6789b5b8..612cf359 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -78,6 +78,7 @@ type decl_kind = F*: [val x : Type0] Coq: [Axiom x : Type.] *) +[@@deriving show] (** Return [true] if the declaration is the last from its group of declarations. @@ -112,7 +113,7 @@ let decl_is_first_from_group (kind : decl_kind) : bool = let decl_is_not_last_from_group (kind : decl_kind) : bool = not (decl_is_last_from_group kind) -type type_decl_kind = Enum | Struct +type type_decl_kind = Enum | Struct [@@deriving show] (* TODO: this should be a module we give to a functor! *) @@ -533,7 +534,8 @@ let names_map_check_collision (id_to_string : id -> string) (id : id) | None -> () (* Ok *) | Some clash -> (* There is a clash: print a nice debugging message for the user *) - report_name_collision id_to_string clash id name + if !Config.extract_fail_hard then + report_name_collision id_to_string clash id name let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) (name : string) (nm : names_map) : names_map = @@ -707,9 +709,12 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name | FunId (Assumed aid) -> A.show_assumed_fun_id aid - | TraitMethod _ -> + | TraitMethod (_, method_name, _) -> (* Shouldn't happen *) - raise (Failure "Unexpected") + if !Config.extract_fail_hard then raise (Failure "Unexpected") + else ( + log#serror ("Unexpected trait method: " ^ method_name); + method_name) in let lp_kind = @@ -899,7 +904,8 @@ let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = if with_opaque_pre && is_opaque then ctx.fmt.opaque_pre () ^ s else s | None -> log#serror ("Could not find: " ^ id_to_string id ctx); - raise Not_found + if !Config.extract_fail_hard then raise (Failure "Not found") + else "(ERROR: \"" ^ id_to_string id ctx ^ "\")" let ctx_get_global (with_opaque_pre : bool) (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = -- cgit v1.2.3 From ee9de5ae43928fbd07d19200e6211168ed7552ab Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sat, 16 Sep 2023 21:41:44 +0200 Subject: Fix issues with name collisions --- compiler/Extract.ml | 28 +++++++++++++++++++++------- compiler/ExtractBase.ml | 24 ++++++++++++++++++------ 2 files changed, 39 insertions(+), 13 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 864d513f..60455cd9 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -655,6 +655,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | _ -> raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) in + let flatten_name (name : string list) : string = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" name + | Lean -> String.concat "." name + in let get_type_name = get_name in let type_name_to_camel_case name = let name = get_type_name name in @@ -708,9 +713,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let get_fun_name fname = let fname = get_name fname in (* TODO: don't convert to snake case for Coq, HOL4, F* *) - match !backend with - | FStar | Coq | HOL4 -> String.concat "_" (List.map to_snake_case fname) - | Lean -> String.concat "." fname + flatten_name fname in let global_name (name : global_name) : string = (* Converting to snake case also lowercases the letters (in Rust, global @@ -732,8 +735,18 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) type_name_to_snake_case trait_decl.name in - let trait_impl_name (trait_impl : trait_impl) : string = - get_fun_name trait_impl.name + let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : + string = + (* TODO: provisional: we concatenate the trait impl name (which is its type) + with the trait decl name *) + let inst_keyword = + match !backend with + | HOL4 | FStar | Coq -> "_instance" + | Lean -> "Instance" + in + flatten_name + (get_type_name trait_impl.name + @ [ trait_decl_name trait_decl ^ inst_keyword ]) in let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) @@ -4017,8 +4030,9 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) (trait_impl : trait_impl) : extraction_ctx = (* For now we do not support overriding provided methods *) assert (trait_impl.provided_methods = []); - (* Everything is actually taken care of by {!extract_trait_decl_register_names} *) - ctx + (* Everything is taken care of by {!extract_trait_decl_register_names} *but* + the name of the implementation itself *) + ctx_add_trait_impl trait_impl ctx (** Small helper. diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 612cf359..1996d38f 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -245,7 +245,7 @@ type formatter = { - loop identifier, if this is for a loop *) trait_decl_name : trait_decl -> string; - trait_impl_name : trait_impl -> string; + trait_impl_name : trait_decl -> trait_impl -> string; trait_parent_clause_name : trait_decl -> trait_clause -> string; trait_const_name : trait_decl -> string -> string; trait_type_name : trait_decl -> string -> string; @@ -523,7 +523,8 @@ 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 log#serror err; - raise (Failure err) + (* If we fail hard on errors, raise an exception *) + if !Config.extract_fail_hard then raise (Failure err) let names_map_get_id_from_name (name : string) (nm : names_map) : id option = StringMap.find_opt name nm.name_to_id @@ -534,15 +535,21 @@ let names_map_check_collision (id_to_string : id -> string) (id : id) | None -> () (* Ok *) | Some clash -> (* There is a clash: print a nice debugging message for the user *) - if !Config.extract_fail_hard then - report_name_collision id_to_string clash id name + report_name_collision id_to_string clash id name let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) (name : string) (nm : names_map) : names_map = (* Check if there is a clash *) names_map_check_collision id_to_string id name nm; (* Sanity check *) - assert (not (StringSet.mem name nm.names_set)); + 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 + log#serror err; + (* If we fail hard on errors, raise an exception *) + if !Config.extract_fail_hard then raise (Failure err)); (* Insert *) let id_to_name = IdMap.add id name nm.id_to_name in let name_to_id = StringMap.add name id nm.name_to_id in @@ -1284,8 +1291,13 @@ let ctx_add_trait_decl (d : trait_decl) (ctx : extraction_ctx) : extraction_ctx let ctx_add_trait_impl (d : trait_impl) (ctx : extraction_ctx) : extraction_ctx = + (* We need to lookup the trait decl that is implemented by the trait impl *) + let decl = + Pure.TraitDeclId.Map.find d.impl_trait.trait_decl_id ctx.trans_trait_decls + in + (* Compute the name *) let is_opaque = false in - let name = ctx.fmt.trait_impl_name d in + let name = ctx.fmt.trait_impl_name decl d in ctx_add is_opaque (TraitImplId d.def_id) name ctx let ctx_add_trait_const (d : trait_decl) (item : string) (ctx : extraction_ctx) -- cgit v1.2.3 From e6e749d47f05a6d48625c305b6af132440382efb Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sat, 16 Sep 2023 21:54:48 +0200 Subject: Fix more issues --- compiler/Extract.ml | 13 ++++++------- compiler/ExtractBase.ml | 2 +- 2 files changed, 7 insertions(+), 8 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 60455cd9..ecfb47c7 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -732,21 +732,20 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) in let trait_decl_name (trait_decl : trait_decl) : string = - type_name_to_snake_case trait_decl.name + type_name trait_decl.name in let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : string = (* TODO: provisional: we concatenate the trait impl name (which is its type) with the trait decl name *) - let inst_keyword = + let trait_decl = + let name = trait_decl.name in match !backend with - | HOL4 | FStar | Coq -> "_instance" - | Lean -> "Instance" + | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_instance" + | Lean -> String.concat "" (get_type_name name) ^ "Instance" in - flatten_name - (get_type_name trait_impl.name - @ [ trait_decl_name trait_decl ^ inst_keyword ]) + flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 1996d38f..28928325 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1339,7 +1339,7 @@ let ctx_add_trait_method (d : trait_decl) (item_name : string) (f : fun_decl) (* Add a prefix if necessary *) let name = if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name d ^ name + else ctx.fmt.trait_decl_name d ^ "_" ^ name in let is_opaque = false in ctx_add is_opaque (TraitMethodId (d.def_id, item_name, f.back_id)) name ctx -- cgit v1.2.3 From 515d95d786fed13c300b9e0d7619711ee6aaf971 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sat, 16 Sep 2023 22:50:19 +0200 Subject: Add a strict_names_map in the extraction_ctx --- compiler/ExtractBase.ml | 55 ++++++++++++++++++++++++++++++++++--------------- compiler/Translate.ml | 14 +++++++++++++ 2 files changed, 52 insertions(+), 17 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 28928325..15acc492 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -467,6 +467,8 @@ type id = (** Used for stored various strings like keywords, definitions which should always be in context, etc. and which can't be linked to one of the above. + + TODO: rename to "keyword" *) [@@deriving show, ord] @@ -512,6 +514,14 @@ type names_map = { *) } +let empty_names_map : names_map = + { + id_to_name = IdMap.empty; + name_to_id = StringMap.empty; + names_set = StringSet.empty; + opaque_ids = IdSet.empty; + } + (** Small helper to report name collision *) let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) (name : string) : unit = @@ -645,6 +655,15 @@ type extraction_ctx = { unsafe_names_map : unsafe_names_map; (** The map for id to names, where we allow name collisions (ex.: we might allow record field name collisions). *) + strict_names_map : names_map; + (** This map is a sub-map of [names_map]. For the ids in this map we also + forbid collisions with names in the [unsafe_names_map]. + + We do so for keywords for instance, but also for types (in a dependently + typed language, we might have an issue if the field of a record has, say, + the name "u32", and another field of the same record refers to "u32" + (for instance in its type). + *) fmt : formatter; indent_incr : int; (** The indent increment we insert whenever we need to indent more *) @@ -849,6 +868,11 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = ^ fun_name | TraitSelfClauseId -> "trait_self_clause" +(** Return [true] if we are strict on collisions for this id (i.e., we forbid + collisions even with the ids in the unsafe names map) *) +let strict_collisions (id : id) : bool = + match id with UnknownId | TypeId _ -> true | _ -> false + (** We might not check for collisions for some specific ids (ex.: field names) *) let allow_collisions (id : id) : bool = match id with @@ -866,9 +890,9 @@ let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) We notably use it for field names: some backends like Lean can use the type information to disambiguate field projections. - Remark: what we do is actually subtle. Taking the example of fields: - - we allow fields from different ADT definitions to collide - - we do *not* allow field names to collide with other names + Remark: we still need to check that those "unsafe" ids don't collide with + the ids that we mark as "strict on collision". + For instance, we don't allow naming a field "let". We enforce this by not checking collision between ids for which we permit collisions (ex.: between fields), but still checking collisions between those ids and the @@ -876,29 +900,26 @@ let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) *) if allow_collisions id then ( assert (not is_opaque); - (* Check with the other ids *) - names_map_check_collision id_to_string id name ctx.names_map; + (* Check with the ids which are considered to be strict on collisions *) + names_map_check_collision id_to_string id name ctx.strict_names_map; { ctx with unsafe_names_map = unsafe_names_map_add id name ctx.unsafe_names_map; }) else - (* Remark: we don't check that there are no collisions with the unsafe ids. - Importantly, we don't want some safe ids like keywords to clash with - unsafe ids like fields names. For this, we leverage the fact that we register - keywords *first*, then unsafe ids (meaning the clash will be detected with - the check in the other branch of the if ... then ... else ..., and we do - have to check for all possible collisions, which may be slightly too - restrictive). - - TODO: this is a bit hacky, we might want to improve the way we detect - clashes by being more precise. Overall, there is only an issue with - field names which are allowed to clash with each other. + (* Remark: if we are strict on collisions: + - we add the id to the strict collisions map + - we check that the id doesn't collide with the unsafe map *) + let strict_names_map = + if strict_collisions id then + names_map_add id_to_string is_opaque id name ctx.strict_names_map + else ctx.strict_names_map + in let names_map = names_map_add id_to_string is_opaque id name ctx.names_map in - { ctx with names_map } + { ctx with strict_names_map; names_map } (** [with_opaque_pre]: if [true] and the definition is opaque, add the opaque prefix *) let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 90066163..ebb0de0e 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -986,6 +986,19 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : mk_formatter_and_names_map trans_ctx crate.name variant_concatenate_type_name in + let strict_names_map = + let open ExtractBase in + let ids = + List.filter + (fun (id, _) -> strict_collisions id) + (IdMap.bindings names_map.id_to_name) + in + let is_opaque = false in + List.fold_left + (* id_to_string: we shouldn't need to use it *) + (fun m (id, n) -> names_map_add show_id is_opaque id n m) + empty_names_map ids + in (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) @@ -1041,6 +1054,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : trans_ctx; names_map; unsafe_names_map = { id_to_name = ExtractBase.IdMap.empty }; + strict_names_map; fmt; indent_incr = 2; use_opaque_pre = !Config.split_files; -- cgit v1.2.3 From 8e86ab71527de2d997b6454dc61ab80d52bfdc56 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sat, 16 Sep 2023 23:36:29 +0200 Subject: Fix issues with name registration/lookup --- compiler/Extract.ml | 28 ++++++++++++++++-- compiler/ExtractBase.ml | 77 +++++++++++++++++++++++++++++++++++-------------- 2 files changed, 81 insertions(+), 24 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ecfb47c7..aef37a86 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2618,7 +2618,31 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the function name *) let with_opaque_pre = ctx.use_opaque_pre in - let fun_name = ctx_get_function with_opaque_pre fun_id ctx in + (* For the function name: the id is not the same depending on whether + we call a trait method and a "regular" function (remark: trait + method *implementations* are considered as regular functions here; + only calls to method of traits which are parameterized in a where + clause have a special treatment. + + Remark: the reason why trait method declarations have a special + treatment is that, as traits are extracted to records, we may + allow collisions between trait item names and some other names, + while we do not allow collisions between function names. + + Remark: calls to trait methods when the implementation is known + (i.e., when we do not use a trait parameter) are desugared to regular + function calls. + *) + let fun_name = + match fun_id with + | FromLlbc + (TraitMethod (trait_ref, method_name, _fun_decl_id), lp_id, rg_id) + -> + assert (lp_id = None); + ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id + method_name rg_id ctx + | _ -> ctx_get_function with_opaque_pre fun_id ctx + in F.pp_print_string fmt fun_name; (* Sanity check: HOL4 doesn't support const generics *) assert (generics.const_generics = [] || !backend <> HOL4); @@ -3974,7 +3998,7 @@ let extract_trait_decl_method_register_names (ctx : extraction_ctx) let register_fun ctx f = ctx_add_trait_method trait_decl name f.f ctx in (* Register the names *) - let funs = if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs in + let funs = trans.fwd :: trans.backs in List.fold_left register_fun ctx funs (** Similar to {!extract_type_decl_register_names} *) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 15acc492..4238d9af 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -713,6 +713,12 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let fun_decls = ctx.trans_ctx.fun_context.fun_decls in let type_decls = ctx.trans_ctx.type_context.type_decls in let trait_decls = ctx.trans_ctx.trait_decls_context.trait_decls in + let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = + let trait_name = + Print.fun_name_to_string (A.TraitDeclId.Map.find id trait_decls).name + in + "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" + in (* TODO: factorize the pretty-printing with what is in PrintPure *) let get_type_name (id : type_id) : string = match id with @@ -735,12 +741,13 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name | FunId (Assumed aid) -> A.show_assumed_fun_id aid - | TraitMethod (_, method_name, _) -> + | TraitMethod (trait_ref, method_name, _) -> (* Shouldn't happen *) if !Config.extract_fail_hard then raise (Failure "Unexpected") - else ( - log#serror ("Unexpected trait method: " ^ method_name); - method_name) + else + "Trait method: decl: " + ^ TraitDeclId.to_string trait_ref.trait_decl_ref.trait_decl_id + ^ ", method_name: " ^ method_name in let lp_kind = @@ -800,8 +807,16 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = if variant_id = option_some_id then "@option::Some" else if variant_id = option_none_id then "@option::None" else raise (Failure "Unreachable") - | Assumed (State | Vec | Fuel | Array | Slice | Str | Range) -> - raise (Failure "Unreachable") + | Assumed Fuel -> + if variant_id = fuel_zero_id then "@fuel::0" + else if variant_id = fuel_succ_id then "@fuel::Succ" + else raise (Failure "Unreachable") + | Assumed (State | Vec | Array | Slice | Str | Range) -> + raise + (Failure + ("Unreachable: variant id (" + ^ VariantId.to_string variant_id + ^ ") for " ^ show_type_id id)) | AdtId id -> ( let def = TypeDeclId.Map.find id type_decls in match def.kind with @@ -844,28 +859,22 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | LocalTraitClauseId id -> "local_trait_clause_id: " ^ TraitClauseId.to_string id | TraitParentClauseId (id, clause_id) -> - "trait_parent_clause_id: decl_id:" ^ TraitDeclId.to_string id - ^ ", clause_id: " + "trait_parent_clause_id: " ^ trait_decl_id_to_string id ^ ", clause_id: " ^ TraitClauseId.to_string clause_id | TraitItemClauseId (id, item_name, clause_id) -> - "trait_item_clause_id: decl_id:" ^ TraitDeclId.to_string id - ^ ", item name: " ^ item_name ^ ", clause_id: " + "trait_item_clause_id: " ^ trait_decl_id_to_string id ^ ", item name: " + ^ item_name ^ ", clause_id: " ^ TraitClauseId.to_string clause_id | TraitItemId (id, name) -> - "trait_item_id: decl_id:" ^ TraitDeclId.to_string id ^ ", type name: " - ^ name + "trait_item_id: " ^ trait_decl_id_to_string id ^ ", type name: " ^ name | TraitMethodId (trait_decl_id, fun_name, rg_id) -> - let trait_name = - Print.fun_name_to_string - (A.TraitDeclId.Map.find trait_decl_id trait_decls).name - in let fwd_back_kind = match rg_id with | None -> "forward" | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id in - "trait " ^ trait_name ^ " method name (" ^ fwd_back_kind ^ "): " - ^ fun_name + trait_decl_id_to_string trait_decl_id + ^ ", method name (" ^ fwd_back_kind ^ "): " ^ fun_name | TraitSelfClauseId -> "trait_self_clause" (** Return [true] if we are strict on collisions for this id (i.e., we forbid @@ -924,15 +933,39 @@ let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) (** [with_opaque_pre]: if [true] and the definition is opaque, add the opaque prefix *) let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = (* We do not use the same name map if we allow/disallow collisions *) - if allow_collisions id then IdMap.find id ctx.unsafe_names_map.id_to_name + let map_to_string (m : string IdMap.t) : string = + "[\n" + ^ String.concat "," + (List.map + (fun (id, n) -> "\n " ^ id_to_string id ctx ^ " -> " ^ n) + (IdMap.bindings m)) + ^ "\n]" + in + if allow_collisions id then ( + let m = ctx.unsafe_names_map.id_to_name in + match IdMap.find_opt id m with + | Some s -> s + | None -> + let err = + "Could not find: " ^ id_to_string id ctx ^ "\nNames map:\n" + ^ map_to_string m + in + log#serror err; + if !Config.extract_fail_hard then raise (Failure err) + else "(ERROR: \"" ^ id_to_string id ctx ^ "\")") else - match IdMap.find_opt id ctx.names_map.id_to_name with + let m = ctx.names_map.id_to_name in + match IdMap.find_opt id m with | Some s -> let is_opaque = IdSet.mem id ctx.names_map.opaque_ids in if with_opaque_pre && is_opaque then ctx.fmt.opaque_pre () ^ s else s | None -> - log#serror ("Could not find: " ^ id_to_string id ctx); - if !Config.extract_fail_hard then raise (Failure "Not found") + let err = + "Could not find: " ^ id_to_string id ctx ^ "\nNames map:\n" + ^ map_to_string m + in + log#serror err; + if !Config.extract_fail_hard then raise (Failure err) else "(ERROR: \"" ^ id_to_string id ctx ^ "\")" let ctx_get_global (with_opaque_pre : bool) (id : A.GlobalDeclId.id) -- cgit v1.2.3 From d2724812981075ab7edc9cf7fb3915908024410a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 00:30:32 +0200 Subject: Fix several issues with the extraction --- compiler/Extract.ml | 164 +++++++++++++++++++++++++++++------------------- compiler/ExtractBase.ml | 3 +- 2 files changed, 100 insertions(+), 67 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index aef37a86..01bd5d38 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -681,15 +681,20 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) in let field_name (def_name : name) (field_id : FieldId.id) (field_name : string option) : string = - let field_name = + let field_name_s = match field_name with | Some field_name -> field_name - | None -> FieldId.to_string field_id + | None -> + (* TODO: extract structs with no field names to tuples *) + FieldId.to_string field_id in - if !Config.record_fields_short_names then field_name + if !Config.record_fields_short_names then + if field_name = None then (* TODO: this is a bit ugly *) + "_" ^ field_name_s + else field_name_s else let def_name = type_name_to_snake_case def_name ^ "_" in - def_name ^ field_name + def_name ^ field_name_s in let variant_name (def_name : name) (variant : string) : string = match !backend with @@ -894,7 +899,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let trait_clause_basename (_varset : StringSet.t) (_clause : trait_clause) : string = (* TODO: actually use the clause to derive the name *) - "cl" + "inst" in let trait_self_clause_basename = "self_clause" in let append_index (basename : string) (i : int) : string = @@ -1330,6 +1335,17 @@ and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) extract_generic_args ctx fmt no_params_tys tr.generics; if use_brackets then F.pp_print_string fmt ")" +and extract_trait_decl_ref (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 is_opaque = false in + let name = ctx_get_trait_decl is_opaque tr.trait_decl_id ctx in + if use_brackets then F.pp_print_string fmt "("; + F.pp_print_string fmt name; + extract_generic_args ctx fmt no_params_tys tr.decl_generics; + if use_brackets then F.pp_print_string fmt ")" + and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (generics : generic_args) : unit = let { types; const_generics; trait_refs } = generics in @@ -1734,8 +1750,9 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) method and need to insert a trait self clause (see {!TraitSelfClauseId}). *) let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (use_forall : bool) (as_implicits : bool) - (space : bool ref option) (trait_decl : trait_decl option) + (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) + ?(use_forall_use_sep = true) ?(as_implicits : bool = false) + ?(space : bool ref option = None) ?(trait_decl : trait_decl option = None) (generics : generic_params) (type_params : string list) (cg_params : string list) (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in @@ -1757,9 +1774,10 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) (* Print the type/const generic parameters *) if all_params <> [] then ( if use_forall then ( + if use_forall_use_sep then ( + insert_req_space (); + F.pp_print_string fmt ":"); insert_req_space (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); F.pp_print_string fmt "forall"); (* Small helper - we may need to split the parameters *) let print_generics (type_params : string list) @@ -1917,9 +1935,8 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) support trait clauses *) assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); (* Print the generic parameters *) - let as_implicits = false in - extract_generic_params ctx_body fmt type_decl_group use_forall as_implicits - None None def.generics type_params cg_params trait_clauses; + extract_generic_params 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 (); @@ -2149,11 +2166,9 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in F.pp_print_string fmt field_name; (* Print the generics *) - let use_forall = false in let as_implicits = true in - extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall - as_implicits None None decl.generics type_params cg_params - trait_clauses; + extract_generic_params 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 "("; @@ -3220,11 +3235,9 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (* Print the generics *) (* Open a box for the generics *) F.pp_open_hovbox fmt 0; - let use_forall = false in - let as_implicits = false in - extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits - (Some space) trait_decl def.signature.generics type_params cg_params - trait_clauses; + (let space = Some space in + extract_generic_params 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 *) @@ -4064,14 +4077,13 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) let extract_trait_item (ctx : extraction_ctx) (fmt : F.formatter) (item_name : string) (separator : string) (ty : unit -> unit) : unit = F.pp_print_space fmt (); - F.pp_open_vbox fmt ctx.indent_incr; + F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt item_name; F.pp_print_space fmt (); (* ":" or "=" *) F.pp_print_string fmt separator; - F.pp_print_space fmt (); ty (); - F.pp_print_string fmt ";"; + (match !Config.backend with Lean -> () | _ -> F.pp_print_string fmt ";"); F.pp_close_box fmt () let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) @@ -4080,7 +4092,8 @@ let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) let extract_trait_impl_item (ctx : extraction_ctx) (fmt : F.formatter) (item_name : string) (ty : unit -> unit) : unit = - extract_trait_item ctx fmt item_name "=" ty + let assign = match !Config.backend with Lean -> ":=" | _ -> "=" in + extract_trait_item ctx fmt item_name assign ty (** Small helper - TODO: move *) let generic_params_drop_prefix (g1 : generic_params) (g2 : generic_params) : @@ -4115,9 +4128,9 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) ctx_add_generic_params generics ctx in let use_forall = generics <> empty_generic_params in - let use_implicits = false in - extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall - use_implicits None None generics type_params cg_params trait_clauses; + let use_forall_use_sep = false in + extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall + ~use_forall_use_sep generics type_params cg_params trait_clauses; if use_forall then F.pp_print_string fmt ","; (* Extract the inputs and output *) F.pp_print_space fmt (); @@ -4136,23 +4149,29 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) - extract_comment fmt [ "[" ^ Print.name_to_string decl.name ^ "]" ]; + extract_comment fmt + [ "Trait declaration: [" ^ Print.name_to_string decl.name ^ "]" ]; F.pp_print_break fmt 0 0; - (* Open two boxes for the definition, so that whenever possible it gets printed on - * one line and indents are correct *) - F.pp_open_hvbox fmt 0; - F.pp_open_vbox fmt ctx.indent_incr; + (* Open two outer boxes for the definition, so that whenever possible it gets printed on + one line and indents are correct. + + There is just an exception with Lean: in this backend, line breaks are important + for the parsing, so we always open a vertical box. + *) + if !Config.backend = Lean then F.pp_open_vbox fmt ctx.indent_incr + else ( + F.pp_open_hvbox fmt 0; + F.pp_open_hvbox fmt ctx.indent_incr); (* `struct Trait (....) =` *) (* Open the box for the name + generics *) - F.pp_open_vbox fmt ctx.indent_incr; + F.pp_open_hovbox fmt ctx.indent_incr; let qualif = Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec (Some Struct)) in F.pp_print_string fmt qualif; F.pp_print_space fmt (); F.pp_print_string fmt decl_name; - (* Print the generics *) (* We ignore the trait clauses, which we extract as *fields* *) let generics = { decl.generics with trait_clauses = [] } in @@ -4161,13 +4180,13 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) let ctx, type_params, cg_params, trait_clauses = ctx_add_generic_params generics ctx in - let use_forall = false in - let as_implicits = false in - extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits - None None generics type_params cg_params trait_clauses; + extract_generic_params ctx fmt TypeDeclId.Set.empty generics type_params + cg_params trait_clauses; F.pp_print_space fmt (); - F.pp_print_string fmt "{"; + (match !backend with + | Lean -> F.pp_print_string fmt "where" + | _ -> F.pp_print_string fmt "{"); (* Close the box for the name + generics *) F.pp_close_box fmt (); @@ -4225,11 +4244,14 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) decl.required_methods; (* Close the brackets *) - F.pp_print_space fmt (); - F.pp_print_string fmt "}"; + (match !Config.backend with + | Lean -> () + | _ -> + F.pp_print_space fmt (); + F.pp_print_string fmt "}"); - (* Close the two outer boxes for the definition *) - F.pp_close_box fmt (); + (* Close the outer boxes for the definition *) + if !Config.backend <> Lean then F.pp_close_box fmt (); F.pp_close_box fmt (); (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 @@ -4258,9 +4280,8 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) in let ctx, f_tys, f_cgs, f_tcs = ctx_add_generic_params f_generics ctx in let use_forall = f_generics <> empty_generic_params in - let use_implicits = false in - extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall - use_implicits None None f_generics f_tys f_cgs f_tcs; + extract_generic_params 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 (); @@ -4289,19 +4310,27 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) - extract_comment fmt [ "[" ^ Print.name_to_string impl.name ^ "]" ]; + extract_comment fmt + [ "Trait implementation: [" ^ Print.name_to_string impl.name ^ "]" ]; F.pp_print_break fmt 0 0; - (* Open two boxes for the definition, so that whenever possible it gets printed on - * one line and indents are correct *) - F.pp_open_hvbox fmt 0; - F.pp_open_vbox fmt ctx.indent_incr; - (* `let Trait (....) =` *) + (* Open two outer boxes for the definition, so that whenever possible it gets printed on + one line and indents are correct. + + There is just an exception with Lean: in this backend, line breaks are important + for the parsing, so we always open a vertical box. + *) + if !Config.backend = Lean then ( + F.pp_open_vbox fmt 0; + F.pp_open_vbox fmt ctx.indent_incr) + else ( + F.pp_open_hvbox fmt 0; + F.pp_open_hvbox fmt ctx.indent_incr); + + (* `let (....) : Trait ... =` *) (* Open the box for the name + generics *) - F.pp_open_vbox fmt ctx.indent_incr; - let qualif = - Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec None) - in + F.pp_open_hovbox fmt ctx.indent_incr; + let qualif = Option.get (ctx.fmt.fun_decl_kind_to_qualif SingleNonRec) in F.pp_print_string fmt qualif; F.pp_print_space fmt (); F.pp_print_string fmt impl_name; @@ -4313,13 +4342,18 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) ctx_add_generic_params impl.generics ctx in let all_generics = (type_params, cg_params, trait_clauses) in - let use_forall = false in - let as_implicits = false in - extract_generic_params ctx fmt TypeDeclId.Set.empty use_forall as_implicits - None None impl.generics type_params cg_params trait_clauses; + extract_generic_params 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 ctx fmt TypeDeclId.Set.empty false impl.impl_trait; F.pp_print_space fmt (); - F.pp_print_string fmt "{"; + if !Config.backend = Lean then F.pp_print_string fmt ":= {" + else F.pp_print_string fmt "= {"; (* Close the box for the name + generics *) F.pp_close_box fmt (); @@ -4374,12 +4408,10 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) extract_trait_impl_method_items ctx fmt impl name id all_generics) impl.required_methods; - (* Close the brackets *) + (* Close the outer boxes for the definition, as well as the brackets *) + F.pp_close_box fmt (); F.pp_print_space fmt (); F.pp_print_string fmt "}"; - - (* Close the two outer boxes for the definition *) - F.pp_close_box fmt (); F.pp_close_box fmt (); (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 4238d9af..a81ec052 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -952,7 +952,8 @@ let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = in log#serror err; if !Config.extract_fail_hard then raise (Failure err) - else "(ERROR: \"" ^ id_to_string id ctx ^ "\")") + else + "(%%%ERROR: unknown identifier\": " ^ id_to_string id ctx ^ "\"%%%)") else let m = ctx.names_map.id_to_name in match IdMap.find_opt id m with -- cgit v1.2.3 From 952c4c964e33eeb6956d84efce3ef1b7575f311f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 00:56:51 +0200 Subject: Fix more issues with the extraction --- compiler/LlbcAstUtils.ml | 17 +++++++++++++---- compiler/Translate.ml | 40 +++++++++++++++++++++++++++++++++------- 2 files changed, 46 insertions(+), 11 deletions(-) (limited to 'compiler') diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 8c8bbabe..a982af30 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -15,13 +15,22 @@ let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : (** Return the opaque declarations found in the crate. + [filter_assumed]: if [true], do not consider as opaque the external definitions + that we will map to definitions from the standard library. + Remark: the list of functions also contains the list of opaque global bodies. *) -let crate_get_opaque_decls (k : crate) : T.type_decl list * fun_decl list = +let crate_get_opaque_decls (k : crate) (filter_assumed : bool) : + T.type_decl list * fun_decl list = let open ExtractAssumed in let is_opaque_fun (d : fun_decl) : bool = let sname = name_to_simple_name d.name in - d.body = None && not (SimpleNameMap.mem sname assumed_globals_map) + d.body = None + (* Something to pay attention to: we must ignore trait method *declarations* + (which don't have a body but must not be considered as opaque) *) + && (match d.kind with TraitMethodDecl _ -> false | _ -> true) + && ((not filter_assumed) + || not (SimpleNameMap.mem sname assumed_globals_map)) in let is_opaque_type (d : T.type_decl) : bool = d.kind = T.Opaque in (* Note that by checking the function bodies we also the globals *) @@ -30,5 +39,5 @@ let crate_get_opaque_decls (k : crate) : T.type_decl list * fun_decl list = (** Return true if the crate contains opaque declarations, ignoring the assumed definitions. *) -let crate_has_opaque_decls (k : crate) : bool = - crate_get_opaque_decls k <> ([], []) +let crate_has_opaque_decls (k : crate) (filter_assumed : bool) : bool = + crate_get_opaque_decls k filter_assumed <> ([], []) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index ebb0de0e..4a4affea 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -403,6 +403,8 @@ type gen_config = { extract_decreases_clauses : bool; extract_template_decreases_clauses : bool; extract_fun_decls : bool; + extract_trait_decls : bool; + extract_trait_impls : bool; extract_transparent : bool; (** If [true], extract the transparent declarations, otherwise ignore. *) extract_opaque : bool; @@ -429,9 +431,22 @@ type gen_config = { test_trans_unit_functions : bool; } -(** Returns the pair: (has opaque type decls, has opaque fun decls) *) -let crate_has_opaque_decls (ctx : gen_ctx) : bool * bool = - let types, funs = LlbcAstUtils.crate_get_opaque_decls ctx.crate in +(** Returns the pair: (has opaque type decls, has opaque fun decls). + + [filter_assumed]: if [true], do not consider as opaque the external definitions + that we will map to definitions from the standard library. + *) +let crate_has_opaque_decls (ctx : gen_ctx) (filter_assumed : bool) : bool * bool + = + let types, funs = + LlbcAstUtils.crate_get_opaque_decls ctx.crate filter_assumed + in + log#ldebug + (lazy + ("Opaque decls:" ^ "\n- types:\n" + ^ String.concat ",\n" (List.map T.show_type_decl types) + ^ "\n- functions:\n" + ^ String.concat ",\n" (List.map A.show_fun_decl funs))); (types <> [], funs <> []) (** Export a type declaration. @@ -800,8 +815,12 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) (* Translate *) export_functions_group pure_funs | Global id -> export_global id - | TraitDecl id -> export_trait_decl id - | TraitImpl id -> export_trait_impl id + | TraitDecl id -> + if config.extract_trait_decls && config.extract_transparent then + export_trait_decl id + | TraitImpl id -> + if config.extract_trait_impls && config.extract_transparent then + export_trait_impl id in (* If we need to export the state type: we try to export it after we defined @@ -827,7 +846,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) config.extract_opaque && config.extract_fun_decls && !Config.wrap_opaque_in_sig && - let _, opaque_funs = crate_has_opaque_decls ctx in + let _, opaque_funs = crate_has_opaque_decls ctx true in opaque_funs in if wrap_in_sig then ( @@ -1235,6 +1254,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : extract_decreases_clauses = !Config.extract_decreases_clauses; extract_template_decreases_clauses = false; extract_fun_decls = false; + extract_trait_decls = false; + extract_trait_impls = false; extract_transparent = true; extract_opaque = false; extract_state_type = false; @@ -1246,7 +1267,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (* Check if there are opaque types and functions - in which case we need * to split *) - let has_opaque_types, has_opaque_funs = crate_has_opaque_decls ctx in + let has_opaque_types, has_opaque_funs = crate_has_opaque_decls ctx true in let has_opaque_types = has_opaque_types || !Config.use_state in (* Extract the types *) @@ -1267,6 +1288,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_types = true; + extract_trait_decls = true; extract_opaque = true; extract_state_type = !Config.use_state; interface = has_opaque_types; @@ -1343,6 +1365,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_fun_decls = true; + extract_trait_impls = true; extract_globals = true; extract_transparent = false; extract_opaque = true; @@ -1376,6 +1399,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { base_gen_config with extract_fun_decls = true; + extract_trait_impls = true; extract_globals = true; test_trans_unit_functions = !Config.test_trans_unit_functions; } @@ -1411,6 +1435,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : extract_template_decreases_clauses = !Config.extract_template_decreases_clauses; extract_fun_decls = true; + extract_trait_decls = true; + extract_trait_impls = true; extract_transparent = true; extract_opaque = true; extract_state_type = !Config.use_state; -- cgit v1.2.3 From d69871473f49cb465c638609ce03b0e9013b73e3 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 01:04:38 +0200 Subject: Fix some formatting issues --- compiler/Extract.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 01bd5d38..1fb34af0 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -4368,6 +4368,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (fun clause_id trait_ref -> let item_name = ctx_get_trait_parent_clause trait_decl_id clause_id ctx in let ty () = + F.pp_print_space fmt (); extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref in extract_trait_impl_item ctx fmt item_name ty) @@ -4377,7 +4378,10 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) List.iter (fun (name, (_, id)) -> let item_name = ctx_get_trait_const trait_decl_id name ctx in - let ty () = F.pp_print_string fmt (ctx_get_global false id ctx) in + let ty () = + F.pp_print_space fmt (); + F.pp_print_string fmt (ctx_get_global false id ctx) + in extract_trait_impl_item ctx fmt item_name ty) impl.consts; @@ -4387,7 +4391,10 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (fun (name, (trait_refs, ty)) -> (* Extract the type *) let item_name = ctx_get_trait_type trait_decl_id name ctx in - let ty () = extract_ty ctx fmt TypeDeclId.Set.empty false ty in + let ty () = + F.pp_print_space fmt (); + extract_ty ctx fmt TypeDeclId.Set.empty false ty + in extract_trait_impl_item ctx fmt item_name ty; (* Extract the clauses *) TraitClauseId.iteri @@ -4396,6 +4403,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) ctx_get_trait_item_clause trait_decl_id name clause_id ctx in let ty () = + F.pp_print_space fmt (); extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref in extract_trait_impl_item ctx fmt item_name ty) -- cgit v1.2.3 From 9bfbfcc5aa3a05aafa2b7b5014256b30a878f0a2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 01:20:17 +0200 Subject: Fix some issues with calls to trait methods --- compiler/Extract.ml | 23 ++++++++++++++--------- compiler/InterpreterStatements.ml | 9 +++++++-- 2 files changed, 21 insertions(+), 11 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 1fb34af0..7da5610e 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1734,7 +1734,9 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) F.pp_print_string fmt "("; let self_clause = ctx_get_trait_self_clause ctx in F.pp_print_string fmt self_clause; + F.pp_print_space fmt (); F.pp_print_string fmt ":"; + F.pp_print_space fmt (); let with_opaque_pre = false in let trait_id = ctx_get_trait_decl with_opaque_pre trait_decl.def_id ctx in F.pp_print_string fmt trait_id; @@ -2648,17 +2650,20 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (i.e., when we do not use a trait parameter) are desugared to regular function calls. *) - let fun_name = - match fun_id with - | FromLlbc - (TraitMethod (trait_ref, method_name, _fun_decl_id), lp_id, rg_id) - -> - assert (lp_id = None); + (match fun_id with + | FromLlbc + (TraitMethod (trait_ref, method_name, _fun_decl_id), lp_id, rg_id) -> + assert (lp_id = None); + extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref; + let fun_name = ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id method_name rg_id ctx - | _ -> ctx_get_function with_opaque_pre fun_id ctx - in - F.pp_print_string fmt fun_name; + in + F.pp_print_string fmt ("." ^ fun_name) + | _ -> + let fun_name = ctx_get_function with_opaque_pre fun_id ctx in + F.pp_print_string fmt fun_name); + (* Sanity check: HOL4 doesn't support const generics *) assert (generics.const_generics = [] || !backend <> HOL4); (* Print the generics *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 88e20a92..b00aca7e 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1201,7 +1201,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) | 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, method_decl_id) -> ( log#ldebug (lazy ("trait method call:\n- call: " ^ call_to_string ctx call @@ -1230,6 +1230,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) in match method_id with | Some (_, id) -> + (* This is a required method *) let method_def = C.ctx_lookup_fun_decl ctx id in (* Instantiate *) let tr_self = @@ -1239,7 +1240,11 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) instantiate_fun_sig ctx generics tr_self method_def.A.signature in - (call.func, method_def, None, inst_sg) + (* Also update the function identifier: we want to forget + the fact that we called a trait method, and treat it as + a regular function acll. *) + let func = A.FunId (A.Regular method_decl_id) in + (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) *) -- cgit v1.2.3 From 245a19a962c2fbd546c90c4ff16767a03af591e9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 01:22:45 +0200 Subject: Fix a minor issue --- compiler/InterpreterStatements.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'compiler') diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index b00aca7e..d67d57db 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1201,7 +1201,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) | A.FunId (A.Assumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") - | A.TraitMethod (trait_ref, method_name, method_decl_id) -> ( + | A.TraitMethod (trait_ref, method_name, _) -> ( log#ldebug (lazy ("trait method call:\n- call: " ^ call_to_string ctx call @@ -1243,7 +1243,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (* Also update the function identifier: we want to forget the fact that we called a trait method, and treat it as a regular function acll. *) - let func = A.FunId (A.Regular method_decl_id) in + let func = A.FunId (A.Regular id) in (func, method_def, None, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* -- cgit v1.2.3 From f2928eaa854688b679f7e504c036866ee7664fe5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 03:17:51 +0200 Subject: Update the handling of calls to trait impl methods --- compiler/InterpreterStatements.ml | 75 ++++++++++++++++++++++++++++++++++----- 1 file changed, 67 insertions(+), 8 deletions(-) (limited to 'compiler') diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index d67d57db..2a5c8952 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1188,8 +1188,64 @@ and eval_transparent_function_call_concrete (config : C.config) 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 func, def, self_trait_ref, inst_sg = + (* Instantiate the signature and introduce fresh abstractions and region ids while doing so. + + We perform some manipulations when instantiating the signature. + In particular, we have a special treatment of trait method calls when + the trait ref is a known impl. + + For instance: + {[ + trait HasValue { + fn has_value(&self) -> bool; + } + + impl HasValue for Option { + fn has_value(&self) { + match self { + None => false, + Some(_) => true, + } + } + } + + fn option_has_value(x: &Option) -> bool { + x.has_value() + } + ]} + + The generated code looks like this: + {[ + structure HasValue (T : Type) = { + has_value : T -> result bool + } + + let OptionHasValueImpl.has_value (T : Type) (self : T) : result bool = + match self with + | None => false + | Some _ => true + + let OptionHasValueInstance (T : Type) : HasValue (Option T) = { + has_value = OptionHasValueInstance.has_value + } + ]} + + In [option_has_value], we don't want to refer to the [has_value] method + of the instance of [HasValue] for [Option]. We want to refer directly + to the function which implements [has_value] for [Option]. + That is, instead of generating this: + {[ + let option_has_value (T : Type) (x : Option T) : result bool = + (OptionHasValueInstance T).has_value x + ]} + + We want to generate this: + {[ + let option_has_value (T : Type) (x : Option T) : result bool = + OptionHasValueImpl.has_value T x + ]} + *) + let func, generics, 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 @@ -1197,7 +1253,7 @@ 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 - (call.func, def, None, inst_sg) + (call.func, call.generics, def, None, inst_sg) | A.FunId (A.Assumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") @@ -1242,9 +1298,12 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) in (* Also update the function identifier: we want to forget the fact that we called a trait method, and treat it as - a regular function acll. *) + a regular function call to the top-level function + 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 - (func, method_def, None, inst_sg) + (func, generics, 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) *) @@ -1299,7 +1358,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (* 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)) + (func, generics, method_def, Some trait_ref, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = @@ -1328,13 +1387,13 @@ 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, method_def, None, inst_sg)) + (call.func, generics, 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 func inst_sg self_trait_ref - call.generics call.args call.dest cf ctx + generics call.args call.dest cf ctx (** Evaluate a function call in symbolic mode by using the function signature. -- cgit v1.2.3 From 296f97bb6a768ffd85f35db2762f2db4f7a357ad Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 04:43:01 +0200 Subject: Make progress on correctly extracting trait method calls --- compiler/Extract.ml | 110 +++++++++++++++++++++++++++++--------- compiler/InterpreterStatements.ml | 33 +++++++----- compiler/PureUtils.ml | 17 ++++++ 3 files changed, 121 insertions(+), 39 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 7da5610e..e841082b 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1760,13 +1760,11 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) assert (cg_params = [] || !backend <> HOL4); - let left_bracket () = - if as_implicits then F.pp_print_string fmt "{" - else F.pp_print_string fmt "(" + let left_bracket (implicit : bool) = + if implicit then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" in - let right_bracket () = - if as_implicits then F.pp_print_string fmt "}" - else F.pp_print_string fmt ")" + let right_bracket (implicit : bool) = + if implicit then F.pp_print_string fmt "}" else F.pp_print_string fmt ")" in let insert_req_space () = match space with @@ -1782,7 +1780,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) insert_req_space (); F.pp_print_string fmt "forall"); (* Small helper - we may need to split the parameters *) - let print_generics (type_params : string list) + let print_generics (as_implicits : bool) (type_params : string list) (const_generics : const_generic_var list) (trait_clauses : trait_clause list) : unit = (* Note that in HOL4 we don't print the type parameters. *) @@ -1791,7 +1789,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) if type_params <> [] then ( insert_req_space (); (* ( *) - left_bracket (); + left_bracket as_implicits; List.iter (fun s -> F.pp_print_string fmt s; @@ -1801,13 +1799,13 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt (type_keyword ()); (* ) *) - right_bracket ()); + right_bracket as_implicits); (* Print the const generic parameters *) List.iter (fun (var : const_generic_var) -> insert_req_space (); (* ( *) - left_bracket (); + left_bracket as_implicits; let n = ctx_get_const_generic_var var.index ctx in F.pp_print_string fmt n; F.pp_print_space fmt (); @@ -1815,14 +1813,14 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); extract_literal_type ctx fmt var.ty; (* ) *) - right_bracket ()) + right_bracket as_implicits) const_generics); (* Print the trait clauses *) List.iter (fun (clause : trait_clause) -> insert_req_space (); (* ( *) - left_bracket (); + left_bracket as_implicits; let n = ctx_get_local_trait_clause clause.clause_id ctx in F.pp_print_string fmt n; F.pp_print_space fmt (); @@ -1830,7 +1828,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); extract_trait_clause_type ctx fmt no_params_tys clause; (* ) *) - right_bracket ()) + right_bracket as_implicits) trait_clauses in (* If we extract the generics for a provided method for a trait declaration @@ -1841,7 +1839,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) *) match trait_decl with | None -> - print_generics type_params generics.const_generics + print_generics as_implicits type_params generics.const_generics generics.trait_clauses | Some trait_decl -> (* Split the generics between the generics specific to the trait decl @@ -1858,8 +1856,10 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) split_at generics.trait_clauses (length trait_decl.generics.trait_clauses) in - (* Extract the trait decl generics *) - print_generics dtype_params dcgs dtrait_clauses; + (* Extract the trait decl generics - note that we can always deduce + those parameters from the trait self clause: for this reason + they are always implicit *) + print_generics true dtype_params dcgs dtrait_clauses; (* Extract the trait self clause *) let params = concat @@ -1876,7 +1876,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) in extract_trait_self_clause insert_req_space ctx fmt trait_decl params; (* Extract the method generics *) - print_generics mtype_params mcgs mtrait_clauses) + print_generics as_implicits mtype_params mcgs mtrait_clauses) (** Extract a type declaration. @@ -2646,20 +2646,78 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) allow collisions between trait item names and some other names, while we do not allow collisions between function names. - Remark: calls to trait methods when the implementation is known - (i.e., when we do not use a trait parameter) are desugared to regular - function calls. + # Impl trait refs: + ================== + When the trait ref refers to an impl, in + [InterpreterStatement.eval_transparent_function_call_symbolic] we + replace the call to the trait impl method to a call to the function + which implements the trait method (that is, we "forget" that we + called a trait method, and treat it as a regular function call). + + # Provided trait methods: + ========================= + Calls to provided trait methods also have a special treatment. + For now, we do not allow overriding provided trait methods (methods + for which a default implementation is provided in the trait declaration). + Whenever we translate a provided trait method, we translate it once as + a function which takes a trait ref as input. We have to handle this + case below. + + With an example, if in Rust we write: + {[ + fn Foo { + fn f(&self) -> u32; // Required + fn ret_true(&self) -> bool { true } // Provided + } + ]} + + We generate: + {[ + structure Foo (Self : Type) = { + f : Self -> result u32 + } + + let ret_true (Self : Type) (self_clause : Foo Self) (self : Self) : result bool = + true + ]} *) (match fun_id with | FromLlbc (TraitMethod (trait_ref, method_name, _fun_decl_id), lp_id, rg_id) -> - assert (lp_id = None); - extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref; - let fun_name = - ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id - method_name rg_id ctx + (* We have to check whether the trait method is required or provided *) + let trait_decl_id = trait_ref.trait_decl_ref.trait_decl_id in + let trait_decl = + TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls in - F.pp_print_string fmt ("." ^ fun_name) + let method_id = + PureUtils.trait_decl_get_method trait_decl method_name + in + + if not method_id.is_provided then ( + (* Required method *) + assert (lp_id = None); + extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref; + let fun_name = + ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id + method_name rg_id ctx + in + F.pp_print_string fmt ("." ^ fun_name)) + else + (* 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) + in + let fun_name = ctx_get_function with_opaque_pre fun_id ctx in + F.pp_print_string fmt fun_name; + + (* Note that we do not need to print the generics for the trait + declaration: they are always implicit as they can be deduced + from the trait self clause. + + Print the trait ref (to instantate the self clause) *) + F.pp_print_space fmt (); + extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref | _ -> let fun_name = ctx_get_function with_opaque_pre fun_id ctx in F.pp_print_string fmt fun_name); diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 2a5c8952..f54c5dbd 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1191,6 +1191,9 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (* Instantiate the signature and introduce fresh abstractions and region ids while doing so. We perform some manipulations when instantiating the signature. + + # Trait impl calls + ================== In particular, we have a special treatment of trait method calls when the trait ref is a known impl. @@ -1216,11 +1219,11 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) The generated code looks like this: {[ - structure HasValue (T : Type) = { - has_value : T -> result bool + structure HasValue (Self : Type) = { + has_value : Self -> result bool } - let OptionHasValueImpl.has_value (T : Type) (self : T) : result bool = + let OptionHasValueImpl.has_value (Self : Type) (self : Self) : result bool = match self with | None => false | Some _ => true @@ -1244,6 +1247,13 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let option_has_value (T : Type) (x : Option T) : result bool = OptionHasValueImpl.has_value T x ]} + + # Provided trait methods + ======================== + Calls to provided trait methods also have a special treatment because + for now we forbid overriding provided trait methods in the trait implementations, + 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 func, generics, def, self_trait_ref, inst_sg = match call.func with @@ -1319,7 +1329,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) 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 + (* For the instantiation we have to do something peculiar because the method was defined for the trait declaration. We have to group: - the parameters given to the trait decl reference @@ -1336,15 +1346,15 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) } ]} *) - let generics = + let all_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 + ^ "\n- all_generics:\n" + ^ egeneric_args_to_string ctx all_generics ^ "\n- parent params info: " ^ Print.option_to_string A.show_params_info method_def.signature.parent_params_info)); @@ -1352,13 +1362,10 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) in let inst_sg = - instantiate_fun_sig ctx generics tr_self + instantiate_fun_sig ctx all_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, generics, method_def, Some trait_ref, inst_sg)) + (call.func, call.generics, method_def, Some trait_ref, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = @@ -1387,7 +1394,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, generics, method_def, None, inst_sg)) + (call.func, call.generics, method_def, None, inst_sg)) in (* Sanity check *) assert (List.length call.args = List.length def.A.signature.inputs); diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 1357793b..4e44f252 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -625,3 +625,20 @@ let rec typed_pattern_to_texpression (pat : typed_pattern) : texpression option Some (mk_apps cons fields_values).e in match e_opt with None -> None | Some e -> Some { e; ty = pat.ty } + +type trait_decl_method_decl_id = { is_provided : bool; id : fun_decl_id } + +let trait_decl_get_method (trait_decl : trait_decl) (method_name : string) : + trait_decl_method_decl_id = + (* First look in the required methods *) + let method_id = + List.find_opt (fun (s, _) -> s = method_name) trait_decl.required_methods + in + match method_id with + | Some (_, id) -> { is_provided = false; id } + | None -> + (* Must be a provided method *) + let _, id = + List.find (fun (s, _) -> s = method_name) trait_decl.provided_methods + in + { is_provided = true; id = Option.get id } -- cgit v1.2.3 From 47bc2ba74c90c1a29a081b8950022f74408f037e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 05:15:18 +0200 Subject: Merge trans_ctx and decls_ctx --- compiler/Contexts.ml | 6 +++- compiler/Extract.ml | 8 ++--- compiler/ExtractBase.ml | 12 +++---- compiler/Interpreter.ml | 12 ++++--- compiler/PureMicroPasses.ml | 11 +++---- compiler/Translate.ml | 79 ++++++++++----------------------------------- compiler/TranslateCore.ml | 45 +++++++------------------- 7 files changed, 53 insertions(+), 120 deletions(-) (limited to 'compiler') diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 65760d94..a5bc7dc0 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -255,7 +255,11 @@ type type_context = { } [@@deriving show] -type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] +type fun_context = { + fun_decls : fun_decl FunDeclId.Map.t; + fun_infos : FunsAnalysis.fun_info FunDeclId.Map.t; +} +[@@deriving show] type global_context = { global_decls : global_decl GlobalDeclId.Map.t } [@@deriving show] diff --git a/compiler/Extract.ml b/compiler/Extract.ml index e841082b..596fa013 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -856,9 +856,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Assumed Range -> "r" | Assumed State -> ConstStrings.state_basename | AdtId adt_id -> - let def = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls - in + 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 * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" *) @@ -3115,9 +3113,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) let extract_as_unit = match (!backend, supd.struct_id) with | HOL4, AdtId adt_id -> - let d = - TypeDeclId.Map.find adt_id ctx.trans_ctx.type_context.type_decls - in + let d = TypeDeclId.Map.find adt_id ctx.trans_ctx.type_ctx.type_decls in d.kind = Struct [] | _ -> false in diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index a81ec052..1586e6ed 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -709,10 +709,10 @@ type extraction_ctx = { instance). *) let id_to_string (id : id) (ctx : extraction_ctx) : string = - let global_decls = ctx.trans_ctx.global_context.global_decls in - let fun_decls = ctx.trans_ctx.fun_context.fun_decls in - let type_decls = ctx.trans_ctx.type_context.type_decls in - let trait_decls = ctx.trans_ctx.trait_decls_context.trait_decls in + let global_decls = ctx.trans_ctx.global_ctx.global_decls in + let fun_decls = ctx.trans_ctx.fun_ctx.fun_decls in + let type_decls = ctx.trans_ctx.type_ctx.type_decls in + let trait_decls = ctx.trans_ctx.trait_decls_ctx.trait_decls in let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = let trait_name = Print.fun_name_to_string (A.TraitDeclId.Map.find id trait_decls).name @@ -1293,9 +1293,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) (ctx : extraction_ctx) : string = (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in - let llbc_def = - A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls - in + let llbc_def = A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_ctx.fun_decls in let sg = llbc_def.signature in let num_rgs = List.length sg.regions_hierarchy in let { keep_fwd; fwd = _; backs } = trans_group in diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 4ce6dae8..752d6f2f 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -26,7 +26,10 @@ let compute_contexts (m : A.crate) : C.decls_ctx = TypesAnalysis.analyze_type_declarations type_decls type_decls_list in let type_ctx = { C.type_decls_groups; type_decls; type_infos } in - let fun_ctx = { C.fun_decls } in + let fun_infos = + FunsAnalysis.analyze_module m fun_decls global_decls !Config.use_state + in + let fun_ctx = { C.fun_decls; fun_infos } in let global_ctx = { C.global_decls } in let trait_decls_ctx = { C.trait_decls } in let trait_impls_ctx = { C.trait_impls } in @@ -567,7 +570,8 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment. *) - let test_unit_function (crate : A.crate) (fid : A.FunDeclId.id) : unit = + let test_unit_function (crate : A.crate) (decls_ctx : C.decls_ctx) + (fid : A.FunDeclId.id) : unit = (* Retrieve the function declaration *) let fdef = A.FunDeclId.Map.find fid crate.functions in let body = Option.get fdef.body in @@ -581,7 +585,6 @@ module Test = struct assert (body.A.arg_count = 0); (* Create the evaluation context *) - let decls_ctx = compute_contexts crate in let ctx = initialize_eval_context decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) @@ -620,8 +623,9 @@ module Test = struct (fun _ -> fun_decl_is_transparent_unit) crate.functions in + let decls_ctx = compute_contexts crate in let test_unit_fun _ (def : A.fun_decl) : unit = - test_unit_function crate def.A.def_id + test_unit_function crate decls_ctx def.A.def_id in A.FunDeclId.Map.iter test_unit_fun unit_funs end diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 53148dbb..2130d5c2 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -586,9 +586,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = generics = _; } -> (* Lookup the def *) - let decl = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls - in + let decl = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in (* Check that there are as many arguments as there are fields - note that the def should have a body (otherwise we couldn't use the constructor) *) @@ -597,8 +595,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = (* Check if the definition is recursive *) let is_rec = match - TypeDeclId.Map.find adt_id - ctx.type_context.type_decls_groups + TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls_groups with | NonRec _ -> false | Rec _ -> true @@ -796,7 +793,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) | 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 + LlbcAstUtils.lookup_fun_sig id0 ctx.fun_ctx.fun_decls in (* Compute the set of ancestors of the function in call1 *) let call1_ancestors = @@ -1094,7 +1091,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = (* This is a struct *) (* Retrieve the definiton, to find how many fields there are *) let adt_decl = - TypeDeclId.Map.find adt_id ctx.type_context.type_decls + TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in let fields = match adt_decl.kind with diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 4a4affea..13e339ea 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -29,34 +29,12 @@ let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : A.fun_decl) ("translate_function_to_symbolics: " ^ Print.fun_name_to_string fdef.A.name)); - let { - type_context; - fun_context; - global_context; - trait_decls_context; - trait_impls_context; - } = - trans_ctx - in - let fun_context = { C.fun_decls = fun_context.fun_decls } in - - (* TODO: we should merge trans_ctx and decls_ctx *) - let decls_ctx : C.decls_ctx = - { - C.type_ctx = type_context; - fun_ctx = fun_context; - global_ctx = global_context; - trait_decls_ctx = trait_decls_context; - trait_impls_ctx = trait_impls_context; - } - in - match fdef.body with | None -> None | Some _ -> (* Evaluate *) let synthesize = true in - let inputs, symb = evaluate_function_symbolic synthesize decls_ctx fdef in + let inputs, symb = evaluate_function_symbolic synthesize trans_ctx fdef in Some (inputs, Option.get symb) (** Translate a function, by generating its forward and backward translations. @@ -74,15 +52,6 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (lazy ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); - let { - type_context; - fun_context; - global_context; - trait_decls_context; - trait_impls_context; - } = - trans_ctx - in let def_id = fdef.def_id in (* Compute the symbolic ASTs, if the function is transparent *) @@ -107,25 +76,25 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (List.filter_map (fun (tid, g) -> match g with Charon.GAst.NonRec _ -> None | Rec _ -> Some tid) - (T.TypeDeclId.Map.bindings trans_ctx.type_context.type_decls_groups)) + (T.TypeDeclId.Map.bindings trans_ctx.type_ctx.type_decls_groups)) in let type_context = { - SymbolicToPure.type_infos = type_context.type_infos; - llbc_type_decls = type_context.type_decls; + SymbolicToPure.type_infos = trans_ctx.type_ctx.type_infos; + llbc_type_decls = trans_ctx.type_ctx.type_decls; type_decls = pure_type_decls; recursive_decls = recursive_type_decls; } in let fun_context = { - SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; + SymbolicToPure.llbc_fun_decls = trans_ctx.fun_ctx.fun_decls; fun_sigs; - fun_infos = fun_context.fun_infos; + fun_infos = trans_ctx.fun_ctx.fun_infos; } in let global_context = - { SymbolicToPure.llbc_global_decls = global_context.global_decls } + { SymbolicToPure.llbc_global_decls = trans_ctx.global_ctx.global_decls } in (* Compute the set of loops, and find better ids for them (starting at 0). @@ -173,8 +142,8 @@ let translate_function_to_pure (trans_ctx : trans_ctx) type_context; fun_context; global_context; - trait_decls_ctx = trait_decls_context.trait_decls; - trait_impls_ctx = trait_impls_context.trait_impls; + trait_decls_ctx = trans_ctx.trait_decls_ctx.trait_decls; + trait_impls_ctx = trans_ctx.trait_impls_ctx.trait_impls; fun_decl = fdef; forward_inputs = []; (* Empty for now *) @@ -311,22 +280,8 @@ let translate_crate_to_pure (crate : A.crate) : (* Debug *) log#ldebug (lazy "translate_crate_to_pure"); - (* Compute the type and function contexts *) - let decls_ctx = compute_contexts crate in - let fun_infos = - FA.analyze_module crate decls_ctx.fun_ctx.C.fun_decls - decls_ctx.global_ctx.C.global_decls !Config.use_state - in - let fun_context = { fun_decls = decls_ctx.fun_ctx.fun_decls; fun_infos } in - let trans_ctx = - { - type_context = decls_ctx.type_ctx; - fun_context; - global_context = decls_ctx.global_ctx; - trait_decls_context = decls_ctx.trait_decls_ctx; - trait_impls_context = decls_ctx.trait_impls_ctx; - } - in + (* Compute the translation context *) + let trans_ctx = compute_contexts crate in (* Translate all the type definitions *) let type_decls = @@ -362,8 +317,8 @@ let translate_crate_to_pure (crate : A.crate) : in let sigs = List.append assumed_sigs local_sigs in let fun_sigs = - SymbolicToPure.translate_fun_signatures fun_context.fun_infos - decls_ctx.type_ctx.type_infos sigs + SymbolicToPure.translate_fun_signatures trans_ctx.fun_ctx.fun_infos + trans_ctx.type_ctx.type_infos sigs in (* Translate all the *transparent* functions *) @@ -374,18 +329,18 @@ let translate_crate_to_pure (crate : A.crate) : in (* Translate the trait declarations *) - let type_infos = trans_ctx.type_context.type_infos in + let type_infos = trans_ctx.type_ctx.type_infos in let trait_decls = List.map (SymbolicToPure.translate_trait_decl type_infos) - (T.TraitDeclId.Map.values trans_ctx.trait_decls_context.trait_decls) + (T.TraitDeclId.Map.values trans_ctx.trait_decls_ctx.trait_decls) in (* Translate the trait implementations *) let trait_impls = List.map (SymbolicToPure.translate_trait_impl type_infos) - (T.TraitImplId.Map.values trans_ctx.trait_impls_context.trait_impls) + (T.TraitImplId.Map.values trans_ctx.trait_impls_ctx.trait_impls) in (* Apply the micro-passes *) @@ -554,7 +509,7 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) *) let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (id : A.GlobalDeclId.id) : unit = - let global_decls = ctx.trans_ctx.global_context.global_decls in + let global_decls = ctx.trans_ctx.global_ctx.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in let trans = A.FunDeclId.Map.find global.body_id ctx.trans_funs in assert (trans.fwd.loops = []); diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index f31dc458..3427fd43 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -10,27 +10,7 @@ module FA = FunsAnalysis (** The local logger *) let log = L.translate_log -type type_context = C.type_context [@@deriving show] - -type fun_context = { - fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_infos : FA.fun_info A.FunDeclId.Map.t; -} -[@@deriving show] - -type trait_decls_context = C.trait_decls_context [@@deriving show] -type trait_impls_context = C.trait_impls_context [@@deriving show] -type global_context = C.global_context [@@deriving show] - -(* TODO: we should use Contexts.decls_ctx *) -type trans_ctx = { - type_context : type_context; - fun_context : fun_context; - global_context : global_context; - trait_decls_context : trait_decls_context; - trait_impls_context : trait_impls_context; -} - +type trans_ctx = C.decls_ctx [@@deriving show] type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list @@ -50,10 +30,10 @@ let trans_ctx_to_type_formatter (ctx : trans_ctx) (type_params : Pure.type_var list) (const_generic_params : Pure.const_generic_var list) : PrintPure.type_formatter = - let type_decls = ctx.type_context.type_decls in - let global_decls = ctx.global_context.global_decls in - let trait_decls = ctx.trait_decls_context.trait_decls in - let trait_impls = ctx.trait_impls_context.trait_impls in + let type_decls = ctx.type_ctx.type_decls in + let global_decls = ctx.global_ctx.global_decls in + let trait_decls = ctx.trait_decls_ctx.trait_decls in + let trait_impls = ctx.trait_impls_ctx.trait_impls in PrintPure.mk_type_formatter type_decls global_decls trait_decls trait_impls type_params const_generic_params @@ -66,17 +46,17 @@ let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = let type_id_to_string (ctx : trans_ctx) (id : Pure.TypeDeclId.id) : string = Print.fun_name_to_string - (Pure.TypeDeclId.Map.find id ctx.type_context.type_decls).name + (Pure.TypeDeclId.Map.find id ctx.type_ctx.type_decls).name let trans_ctx_to_ast_formatter (ctx : trans_ctx) (type_params : Pure.type_var list) (const_generic_params : Pure.const_generic_var list) : PrintPure.ast_formatter = - let type_decls = ctx.type_context.type_decls in - let fun_decls = ctx.fun_context.fun_decls in - let global_decls = ctx.global_context.global_decls in - let trait_decls = ctx.trait_decls_context.trait_decls in - let trait_impls = ctx.trait_impls_context.trait_impls in + let type_decls = ctx.type_ctx.type_decls in + let fun_decls = ctx.fun_ctx.fun_decls in + let global_decls = ctx.global_ctx.global_decls in + let trait_decls = ctx.trait_decls_ctx.trait_decls in + let trait_impls = ctx.trait_impls_ctx.trait_impls in PrintPure.mk_ast_formatter type_decls fun_decls global_decls trait_decls trait_impls type_params const_generic_params @@ -95,5 +75,4 @@ let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = PrintPure.fun_decl_to_string fmt def let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = - Print.fun_name_to_string - (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name + Print.fun_name_to_string (A.FunDeclId.Map.find id ctx.fun_ctx.fun_decls).name -- cgit v1.2.3 From 80728093c432ba15eace9d6ce1cc9e3c56a80ff7 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 05:37:56 +0200 Subject: Make minor modifications --- compiler/SymbolicToPure.ml | 19 ++++++++----------- compiler/Translate.ml | 5 +---- 2 files changed, 9 insertions(+), 15 deletions(-) (limited to 'compiler') diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 2e0e9862..be9b7261 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -826,10 +826,11 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) of the forward function) which we use as hints to generate pretty names in the extracted code. *) -let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (fun_id : A.fun_id) (type_infos : TA.type_infos) (sg : A.fun_sig) - (input_names : string option list) (bid : T.RegionGroupId.id option) : - fun_sig_named_outputs = +let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) + (sg : A.fun_sig) (input_names : string option list) + (bid : T.RegionGroupId.id option) : fun_sig_named_outputs = + let fun_infos = decls_ctx.fun_ctx.fun_infos in + let type_infos = decls_ctx.type_ctx.type_infos in (* Retrieve the list of parent backward functions *) let gid, parents = match bid with @@ -3021,8 +3022,7 @@ let translate_type_decls (type_decls : T.type_decl list) : type_decl list = - optional names for the outputs values (we derive them for the backward functions) *) -let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) - (type_infos : TA.type_infos) +let translate_fun_signatures (decls_ctx : C.decls_ctx) (functions : (A.fun_id * string option list * A.fun_sig) list) : fun_sig_named_outputs RegularFunIdNotLoopMap.t = (* For every function, translate the signatures of: @@ -3033,17 +3033,14 @@ let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) (sg : A.fun_sig) : (regular_fun_id_not_loop * fun_sig_named_outputs) list = (* The forward function *) - let fwd_sg = - translate_fun_sig fun_infos fun_id type_infos sg input_names None - in + let fwd_sg = translate_fun_sig decls_ctx fun_id sg input_names None in let fwd_id = (fun_id, None) in (* The backward functions *) let back_sgs = List.map (fun (rg : T.region_var_group) -> let tsg = - translate_fun_sig fun_infos fun_id type_infos sg input_names - (Some rg.id) + translate_fun_sig decls_ctx fun_id sg input_names (Some rg.id) in let id = (fun_id, Some rg.id) in (id, tsg)) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 13e339ea..e69abee1 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -316,10 +316,7 @@ let translate_crate_to_pure (crate : A.crate) : (A.FunDeclId.Map.values crate.functions) in let sigs = List.append assumed_sigs local_sigs in - let fun_sigs = - SymbolicToPure.translate_fun_signatures trans_ctx.fun_ctx.fun_infos - trans_ctx.type_ctx.type_infos sigs - in + let fun_sigs = SymbolicToPure.translate_fun_signatures trans_ctx sigs in (* Translate all the *transparent* functions *) let pure_translations = -- cgit v1.2.3 From 353a9627cf39290f2fe841a45e52726aa9fe6512 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 17 Sep 2023 06:58:17 +0200 Subject: Normalize the function signatures before translation to pure --- compiler/AssociatedTypes.ml | 149 ++++++++++++++++++++++++++--------- compiler/Contexts.ml | 20 +++++ compiler/Interpreter.ml | 47 +++-------- compiler/InterpreterLoopsJoinCtxs.ml | 3 + compiler/InterpreterStatements.ml | 61 -------------- compiler/InterpreterStatements.mli | 13 --- compiler/InterpreterUtils.ml | 105 ++++++++++++++++++++++++ compiler/Print.ml | 19 +++++ compiler/SymbolicToPure.ml | 27 +++++++ 9 files changed, 294 insertions(+), 150 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 92cd464e..992dade9 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -26,6 +26,7 @@ let trait_type_ref_substitute (subst : ('r, 'r1) Subst.subst) let trait_ref = Subst.trait_ref_substitute subst trait_ref in { C.trait_ref; type_name } +(* TODO: how not to duplicate below? *) module RTyOrd = struct type t = T.rty @@ -35,58 +36,114 @@ module RTyOrd = struct let show_t = T.show_rty end +module STyOrd = struct + type t = T.sty + + let compare = T.compare_sty + let to_string = T.show_sty + let pp_t = T.pp_sty + let show_t = T.show_sty +end + module RTyMap = Collections.MakeMap (RTyOrd) +module STyMap = Collections.MakeMap (STyOrd) + +(* TODO: is it possible not to have this? *) +module type TypeWrapper = sig + type t +end + +(* TODO: don't manage to get the syntax right so using a functor *) +module MakeNormalizer + (R : TypeWrapper) + (RTyMap : Collections.Map with type key = R.t T.region T.ty) + (M : Collections.Map with type key = R.t T.region C.trait_type_ref) = +struct + let compute_norm_trait_types_from_preds + (trait_type_constraints : R.t T.region T.trait_type_constraint list) : + R.t T.region T.ty M.t = + (* Compute a union-find structure by recursively exploring the predicates and clauses *) + let norm : R.t T.region T.ty UF.elem RTyMap.t ref = ref RTyMap.empty in + let get_ref (ty : R.t T.region T.ty) : R.t T.region T.ty UF.elem = + match RTyMap.find_opt ty !norm with + | Some r -> r + | None -> + let r = UF.make ty in + norm := RTyMap.add ty r !norm; + r + in + let add_trait_type_constraint (c : R.t T.region T.trait_type_constraint) = + let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in + let trait_ty_ref = get_ref trait_ty in + let ty_ref = get_ref c.ty in + let new_repr = UF.get ty_ref in + let merged = UF.union trait_ty_ref ty_ref in + (* Not sure the set operation is necessary, but I want to control which + representative is chosen *) + UF.set merged new_repr + in + (* Explore the local predicates *) + List.iter add_trait_type_constraint trait_type_constraints; + (* TODO: explore the local clauses *) + (* Compute the norm maps *) + let rbindings = + List.map (fun (k, v) -> (k, UF.get v)) (RTyMap.bindings !norm) + in + (* Filter the keys to keep only the trait type aliases *) + let rbindings = + List.filter_map + (fun (k, v) -> + match k with + | T.TraitType (trait_ref, generics, type_name) -> + assert (generics = TypesUtils.mk_empty_generic_args); + Some ({ C.trait_ref; type_name }, v) + | _ -> None) + rbindings + in + M.of_list rbindings +end + +(** Compute the representative classes of trait associated types, for normalization *) +let compute_norm_trait_stypes_from_preds + (trait_type_constraints : T.strait_type_constraint list) : + T.sty C.STraitTypeRefMap.t = + (* Compute the normalization map for the types with regions *) + let module R = struct + type t = T.region_var_id + end in + let module M = C.STraitTypeRefMap in + let module Norm = MakeNormalizer (R) (STyMap) (M) in + Norm.compute_norm_trait_types_from_preds trait_type_constraints (** Compute the representative classes of trait associated types, for normalization *) let compute_norm_trait_types_from_preds (trait_type_constraints : T.rtrait_type_constraint list) : T.ety C.ETraitTypeRefMap.t * T.rty C.RTraitTypeRefMap.t = - (* Compute a union-find structure by recursively exploring the predicates and clauses *) - let norm : T.rty UF.elem RTyMap.t ref = ref RTyMap.empty in - let get_ref (ty : T.rty) : T.rty UF.elem = - match RTyMap.find_opt ty !norm with - | Some r -> r - | None -> - let r = UF.make ty in - norm := RTyMap.add ty r !norm; - r - in - let add_trait_type_constraint (c : T.rtrait_type_constraint) = - let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in - let trait_ty_ref = get_ref trait_ty in - let ty_ref = get_ref c.ty in - let new_repr = UF.get ty_ref in - let merged = UF.union trait_ty_ref ty_ref in - (* Not sure the set operation is necessary, but I want to control which - representative is chosen *) - UF.set merged new_repr - in - (* Explore the local predicates *) - List.iter add_trait_type_constraint trait_type_constraints; - (* TODO: explore the local clauses *) - (* Compute the norm maps *) + (* Compute the normalization map for the types with regions *) + let module R = struct + type t = T.region_id + end in + let module M = C.RTraitTypeRefMap in + let module Norm = MakeNormalizer (R) (RTyMap) (M) in let rbindings = - List.map (fun (k, v) -> (k, UF.get v)) (RTyMap.bindings !norm) - in - (* Filter the keys to keep only the trait type aliases *) - let rbindings = - List.filter_map - (fun (k, v) -> - match k with - | T.TraitType (trait_ref, generics, type_name) -> - assert (generics = TypesUtils.mk_empty_generic_args); - Some ({ C.trait_ref; type_name }, v) - | _ -> None) - rbindings + Norm.compute_norm_trait_types_from_preds trait_type_constraints in + (* Compute the normalization map for the types with erased regions *) let ebindings = List.map (fun (k, v) -> ( trait_type_ref_substitute Subst.erase_regions_subst k, Subst.erase_regions v )) - rbindings + (M.bindings rbindings) in - (C.ETraitTypeRefMap.of_list ebindings, C.RTraitTypeRefMap.of_list rbindings) + (C.ETraitTypeRefMap.of_list ebindings, rbindings) + +let ctx_add_norm_trait_stypes_from_preds (ctx : C.eval_ctx) + (trait_type_constraints : T.strait_type_constraint list) : C.eval_ctx = + let norm_trait_stypes = + compute_norm_trait_stypes_from_preds trait_type_constraints + in + { ctx with C.norm_trait_stypes } let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) (trait_type_constraints : T.rtrait_type_constraint list) : C.eval_ctx = @@ -398,6 +455,19 @@ let ctx_normalize_trait_type_constraint (ctx : 'r norm_ctx) let ty = ctx_normalize_ty ctx ty in { T.trait_ref; generics; type_name; ty } +let mk_snorm_ctx (ctx : C.eval_ctx) : T.RegionVarId.id T.region norm_ctx = + let get_ty_repr x = C.STraitTypeRefMap.find_opt x ctx.norm_trait_stypes in + { + ctx; + get_ty_repr; + convert_ety = TypesUtils.ety_no_regions_to_sty; + convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; + ty_to_string = PA.sty_to_string ctx; + trait_ref_to_string = PA.strait_ref_to_string ctx; + trait_instance_id_to_string = PA.strait_instance_id_to_string ctx; + pp_r = T.pp_region T.pp_region_var_id; + } + let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = let get_ty_repr x = C.RTraitTypeRefMap.find_opt x ctx.norm_trait_rtypes in { @@ -424,6 +494,9 @@ let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = pp_r = T.pp_erased_region; } +let ctx_normalize_sty (ctx : C.eval_ctx) (ty : T.sty) : T.sty = + ctx_normalize_ty (mk_snorm_ctx ctx) ty + let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = ctx_normalize_ty (mk_rnorm_ctx ctx) ty diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index a5bc7dc0..dac64a9a 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -288,6 +288,9 @@ type etrait_type_ref = erased_region trait_type_ref [@@deriving show, ord] type rtrait_type_ref = Types.RegionId.id Types.region trait_type_ref [@@deriving show, ord] +type strait_type_ref = Types.RegionVarId.id Types.region trait_type_ref +[@@deriving show, ord] + (* TODO: correctly use the functors so as not to have a duplication below *) module ETraitTypeRefOrd = struct type t = etrait_type_ref @@ -307,8 +310,18 @@ module RTraitTypeRefOrd = struct let show_t = show_rtrait_type_ref end +module STraitTypeRefOrd = struct + type t = strait_type_ref + + let compare = compare_strait_type_ref + let to_string = show_strait_type_ref + let pp_t = pp_strait_type_ref + let show_t = show_strait_type_ref +end + module ETraitTypeRefMap = Collections.MakeMap (ETraitTypeRefOrd) module RTraitTypeRefMap = Collections.MakeMap (RTraitTypeRefOrd) +module STraitTypeRefMap = Collections.MakeMap (STraitTypeRefOrd) (** Evaluation context *) type eval_ctx = { @@ -336,6 +349,13 @@ type eval_ctx = { TODO: how not to duplicate? *) + norm_trait_stypes : sty STraitTypeRefMap.t; + (** We sometimes need to normalize types in non-instantiated signatures. + + Note that we either need to use the etypes/rtypes maps, or the stypes map. + This means that we either compute the maps for etypes and rtypes, or compute + the one for stypes (we don't always compute and carry all the maps). + *) env : env; ended_regions : RegionId.Set.t; } diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 752d6f2f..09f25ca1 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -35,38 +35,6 @@ let compute_contexts (m : A.crate) : C.decls_ctx = let trait_impls_ctx = { C.trait_impls } in { C.type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } -(** **WARNING**: this function doesn't compute the normalized types - (for the trait type aliases). This should be computed afterwards. - *) -let initialize_eval_context (ctx : C.decls_ctx) - (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) - (const_generic_vars : T.const_generic_var list) : C.eval_ctx = - C.reset_global_counters (); - let const_generic_vars_map = - T.ConstGenericVarId.Map.of_list - (List.map - (fun (cg : T.const_generic_var) -> - let ty = TypesUtils.ety_no_regions_to_rty (T.Literal cg.ty) in - let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in - (cg.index, cv)) - const_generic_vars) - in - { - C.type_context = ctx.type_ctx; - C.fun_context = ctx.fun_ctx; - C.global_context = ctx.global_ctx; - C.trait_decls_context = ctx.trait_decls_ctx; - C.trait_impls_context = ctx.trait_impls_ctx; - C.region_groups; - C.type_vars; - C.const_generic_vars; - C.const_generic_vars_map; - C.norm_trait_etypes = C.ETraitTypeRefMap.empty (* Empty for now *); - C.norm_trait_rtypes = C.RTraitTypeRefMap.empty (* Empty for now *); - C.env = [ C.Frame ]; - C.ended_regions = T.RegionId.Set.empty; - } - (** Small helper. Normalize an instantiated function signature provided we used this signature @@ -93,11 +61,10 @@ let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : clauses (we are not considering a function call, so we don't need to normalize because a trait clause was instantiated with a specific trait ref). *) -let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (fdef : A.fun_decl) : - C.eval_ctx * A.inst_fun_sig = - let sg = fdef.signature in +let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) + (kind : A.fun_kind) : C.eval_ctx * A.inst_fun_sig = let tr_self = - match fdef.kind with + match kind with | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ | TraitMethodDecl _ | TraitMethodProvided _ -> T.Self in @@ -185,7 +152,9 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) (* Instantiate the signature. This updates the context because we compute at the same time the normalization map for the associated types. *) - let ctx, inst_sg = symbolic_instantiate_fun_sig ctx fdef in + let ctx, inst_sg = + symbolic_instantiate_fun_sig ctx fdef.signature fdef.kind + in (* Create fresh symbolic values for the inputs *) let input_svs = List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs @@ -260,7 +229,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return * an instantiation of the signature, so that we use fresh * region ids for the return abstractions. *) let sg = fdef.signature in - let _, ret_inst_sg = symbolic_instantiate_fun_sig ctx fdef in + let _, ret_inst_sg = + symbolic_instantiate_fun_sig ctx fdef.signature fdef.kind + in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) let pop_return_value = is_regular_return in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index fa44e20e..6d3ecb18 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -562,6 +562,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) const_generic_vars_map; norm_trait_etypes; norm_trait_rtypes; + norm_trait_stypes; env = _; ended_regions = ended_regions0; } = @@ -579,6 +580,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) const_generic_vars_map = _; norm_trait_etypes = _; norm_trait_rtypes = _; + norm_trait_stypes = _; env = _; ended_regions = ended_regions1; } = @@ -598,6 +600,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) const_generic_vars_map; norm_trait_etypes; norm_trait_rtypes; + norm_trait_stypes; env; ended_regions; } diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index f54c5dbd..dc15c6ac 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -662,67 +662,6 @@ let eval_assumed_function_call_concrete (config : C.config) (* Compose and apply *) comp cf_eval_ops cf_eval_call -let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = - log#ldebug - (lazy - ("instantiate_fun_sig:" ^ "\n- generics: " - ^ egeneric_args_to_string ctx generics - ^ "\n- tr_self: " - ^ rtrait_instance_id_to_string ctx tr_self - ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); - (* Generate fresh abstraction ids and create a substitution from region - * group ids to abstraction ids *) - let rg_abs_ids_bindings = - List.map - (fun rg -> - let abs_id = C.fresh_abstraction_id () in - (rg.T.id, abs_id)) - sg.regions_hierarchy - in - let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = - List.fold_left - (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) - T.RegionGroupId.Map.empty rg_abs_ids_bindings - in - let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = - T.RegionGroupId.Map.find rg_id asubst_map - in - (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in - (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * {!rty} types (not {!ety}). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty generics.types in - let tsubst = Subst.make_type_subst_from_vars sg.generics.types rtype_params in - let cgsubst = - Subst.make_const_generic_subst_from_vars sg.generics.const_generics - generics.const_generics - in - (* TODO: something annoying with the trait ref subst: we need to use region - types, but the arguments use erased regions. For now we use the fact - that no regions should appear inside. In the future: we should merge - ety and rty. *) - let trait_refs = - List.map TypesUtils.etrait_ref_no_regions_to_gr_trait_ref - generics.trait_refs - in - let tr_subst = - Subst.make_trait_subst_from_clauses sg.generics.trait_clauses trait_refs - in - (* Substitute the signature *) - let inst_sig = - Assoc.ctx_subst_norm_signature ctx asubst rsubst tsubst cgsubst tr_subst - tr_self sg - in - (* Return *) - inst_sig - (** Helper Create abstractions (with no avalues, which have to be inserted afterwards) diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index 0a086fb2..e65758ae 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -25,19 +25,6 @@ open InterpreterExpressions *) val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun -(** Instantiate a function signature, introducing **fresh** abstraction ids and - region ids. This is mostly used in preparation of function calls, when - evaluating in symbolic mode of course. - - Note: there are no region parameters, because they should be erased. - *) -val instantiate_fun_sig : - C.eval_ctx -> - T.egeneric_args -> - T.rtrait_instance_id -> - LA.fun_sig -> - LA.inst_fun_sig - (** Helper. Create a list of abstractions from a list of regions groups, and insert diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 6fde8d68..7aaee6ff 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -10,6 +10,11 @@ open TypesUtils module PA = Print.EvalCtxLlbcAst open Cps +(* TODO: we should probably rename the file to ContextsUtils *) + +(** The local logger *) +let log = L.interpreter_log + (** Some utilities *) (** Auxiliary function - call a function which requires a continuation, @@ -413,3 +418,103 @@ let compute_contexts_ids (ctxl : C.eval_ctx list) : ids_sets * ids_to_values = (** Compute the sets of ids found in a context. *) let compute_context_ids (ctx : C.eval_ctx) : ids_sets * ids_to_values = compute_contexts_ids [ ctx ] + +(** **WARNING**: this function doesn't compute the normalized types + (for the trait type aliases). This should be computed afterwards. + *) +let initialize_eval_context (ctx : C.decls_ctx) + (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) + (const_generic_vars : T.const_generic_var list) : C.eval_ctx = + C.reset_global_counters (); + let const_generic_vars_map = + T.ConstGenericVarId.Map.of_list + (List.map + (fun (cg : T.const_generic_var) -> + let ty = TypesUtils.ety_no_regions_to_rty (T.Literal cg.ty) in + let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in + (cg.index, cv)) + const_generic_vars) + in + { + C.type_context = ctx.type_ctx; + C.fun_context = ctx.fun_ctx; + C.global_context = ctx.global_ctx; + C.trait_decls_context = ctx.trait_decls_ctx; + C.trait_impls_context = ctx.trait_impls_ctx; + C.region_groups; + C.type_vars; + C.const_generic_vars; + C.const_generic_vars_map; + C.norm_trait_etypes = C.ETraitTypeRefMap.empty (* Empty for now *); + C.norm_trait_rtypes = C.RTraitTypeRefMap.empty (* Empty for now *); + C.norm_trait_stypes = C.STraitTypeRefMap.empty (* Empty for now *); + C.env = [ C.Frame ]; + C.ended_regions = T.RegionId.Set.empty; + } + +(** Instantiate a function signature, introducing **fresh** abstraction ids and + region ids. This is mostly used in preparation of function calls (when + evaluating in symbolic mode). + + Note: there are no region parameters, because they should be erased. + *) +let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) + (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + log#ldebug + (lazy + ("instantiate_fun_sig:" ^ "\n- generics: " + ^ egeneric_args_to_string ctx generics + ^ "\n- tr_self: " + ^ rtrait_instance_id_to_string ctx tr_self + ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let rg_abs_ids_bindings = + List.map + (fun rg -> + let abs_id = C.fresh_abstraction_id () in + (rg.T.id, abs_id)) + sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) + T.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = + T.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * {!rty} types (not {!ety}). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty generics.types in + let tsubst = Subst.make_type_subst_from_vars sg.generics.types rtype_params in + let cgsubst = + Subst.make_const_generic_subst_from_vars sg.generics.const_generics + generics.const_generics + in + (* TODO: something annoying with the trait ref subst: we need to use region + types, but the arguments use erased regions. For now we use the fact + that no regions should appear inside. In the future: we should merge + ety and rty. *) + let trait_refs = + List.map TypesUtils.etrait_ref_no_regions_to_gr_trait_ref + generics.trait_refs + in + let tr_subst = + Subst.make_trait_subst_from_clauses sg.generics.trait_clauses trait_refs + in + (* Substitute the signature *) + let inst_sig = + AssociatedTypes.ctx_subst_norm_signature ctx asubst rsubst tsubst cgsubst + tr_subst tr_self sg + in + (* Return *) + inst_sig diff --git a/compiler/Print.ml b/compiler/Print.ml index 522d9fdd..5d5c16ee 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -478,6 +478,9 @@ module Contexts = struct let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = PV.value_to_rtype_formatter fmt + let ctx_to_stype_formatter (fmt : ctx_formatter) : PT.stype_formatter = + PV.value_to_stype_formatter fmt + let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = let rvar_to_string r = (* In theory we shouldn't use rvar_to_string, but it can happen @@ -651,6 +654,11 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_rtype_formatter fmt in PT.rty_to_string fmt t + let sty_to_string (ctx : C.eval_ctx) (t : T.sty) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.sty_to_string fmt t + let 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 @@ -661,6 +669,11 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_rtype_formatter fmt in PT.rtrait_ref_to_string fmt x + let strait_ref_to_string (ctx : C.eval_ctx) (x : T.strait_ref) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.strait_ref_to_string fmt x + let etrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.etrait_instance_id) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in @@ -673,6 +686,12 @@ module EvalCtxLlbcAst = struct let fmt = PC.ctx_to_rtype_formatter fmt in PT.rtrait_instance_id_to_string fmt x + let strait_instance_id_to_string (ctx : C.eval_ctx) (x : T.strait_instance_id) + : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + let fmt = PC.ctx_to_stype_formatter fmt in + PT.strait_instance_id_to_string fmt x + let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index be9b7261..429198ad 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -842,6 +842,33 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) (* 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 + (* 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 + is a known impl). *) + (* Create the context *) + let ctx = + let region_groups = + List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy + in + let ctx = + InterpreterUtils.initialize_eval_context decls_ctx region_groups + sg.generics.types sg.generics.const_generics + in + (* Compute the normalization map for the *sty* types and add it to the context *) + AssociatedTypes.ctx_add_norm_trait_stypes_from_preds ctx + sg.preds.trait_type_constraints + in + + (* Normalize the signature *) + let sg = + let ({ A.inputs; output; _ } : A.fun_sig) = sg in + let norm = AssociatedTypes.ctx_normalize_sty ctx in + let inputs = List.map norm inputs in + let output = norm output in + { sg with A.inputs; output } + in + (* List the inputs for: * - the fuel * - the forward function -- cgit v1.2.3 From b946902f8cb8b83c2ca93eceebe99dfbc985987d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 19 Sep 2023 18:07:13 +0200 Subject: Cleanup a bit --- compiler/Extract.ml | 4 ++-- compiler/InterpreterStatements.ml | 20 ++++++++++---------- 2 files changed, 12 insertions(+), 12 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 596fa013..19c3803b 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -747,8 +747,8 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let trait_decl = let name = trait_decl.name in match !backend with - | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_instance" - | Lean -> String.concat "" (get_type_name name) ^ "Instance" + | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_inst" + | Lean -> String.concat "" (get_type_name name) ^ "Inst" in flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index dc15c6ac..42073f0b 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1194,7 +1194,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) 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 func, generics, def, self_trait_ref, inst_sg = + let func, generics, def, inst_sg = match call.func with | A.FunId (A.Regular fid) -> let def = C.ctx_lookup_fun_decl ctx fid in @@ -1202,7 +1202,7 @@ 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 - (call.func, call.generics, def, None, inst_sg) + (call.func, call.generics, def, inst_sg) | A.FunId (A.Assumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") @@ -1252,7 +1252,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) we also need to update the generics. *) let func = A.FunId (A.Regular id) in - (func, generics, method_def, None, inst_sg) + (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) @@ -1304,7 +1304,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, Some trait_ref, inst_sg)) + (call.func, call.generics, method_def, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = @@ -1333,13 +1333,13 @@ 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, None, inst_sg)) + (call.func, call.generics, method_def, 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 func inst_sg self_trait_ref - generics call.args call.dest cf ctx + eval_function_call_symbolic_from_inst_sig config func inst_sg generics + call.args call.dest cf ctx (** Evaluate a function call in symbolic mode by using the function signature. @@ -1354,8 +1354,8 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) *) and eval_function_call_symbolic_from_inst_sig (config : C.config) (fid : A.fun_id_or_trait_method_ref) (inst_sg : A.inst_fun_sig) - (self_trait_ref : T.etrait_ref option) (generics : T.egeneric_args) - (args : E.operand list) (dest : E.place) : st_cm_fun = + (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : + st_cm_fun = fun cf ctx -> (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in @@ -1526,7 +1526,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 None generics args dest cf ctx + inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = -- cgit v1.2.3 From af78286d801b26bf7a70b8815619591d48245cb8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 6 Oct 2023 12:23:26 +0200 Subject: Slightly improve formatting of the generated code --- compiler/Extract.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 19c3803b..ce423acf 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -4272,6 +4272,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) let item_name = ctx_get_trait_const decl.def_id name ctx in let ty () = let inside = false in + F.pp_print_space fmt (); extract_ty ctx fmt TypeDeclId.Set.empty inside ty in extract_trait_decl_item ctx fmt item_name ty) @@ -4282,7 +4283,10 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (fun (name, (clauses, _)) -> (* Extract the type *) let item_name = ctx_get_trait_type decl.def_id name ctx in - let ty () = F.pp_print_string fmt (type_keyword ()) in + let ty () = + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()) + in extract_trait_decl_item ctx fmt item_name ty; (* Extract the clauses *) List.iter @@ -4291,6 +4295,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx in let ty () = + F.pp_print_space fmt (); extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) -- cgit v1.2.3 From 0f0e4be7dc746e2676db33f850bbeddf239eaec8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 13 Oct 2023 00:40:37 +0200 Subject: Add sup --- compiler/Assumed.ml | 15 +++++++++++++++ compiler/Driver.ml | 2 ++ compiler/Extract.ml | 4 +++- compiler/InterpreterStatements.ml | 2 +- compiler/PrintPure.ml | 1 + compiler/PureMicroPasses.ml | 2 +- 6 files changed, 23 insertions(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index e156c335..109175af 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -298,6 +298,19 @@ module Sig = struct let array_subslice_sig (is_mut : bool) = mk_array_slice_subslice_sig true is_mut + let array_repeat_sig = + let generics = + (* *) + mk_generic_params [] [ type_param_0 ] [ cg_param_0 ] + in + let regions_hierarchy = [] (* <> *) in + let inputs = [ tvar_0 (* T *) ] in + let output = + (* [T; N] *) + mk_array_ty tvar_0 cgvar_0 + in + mk_sig generics regions_hierarchy inputs output + let slice_subslice_sig (is_mut : bool) = mk_array_slice_subslice_sig false is_mut @@ -384,6 +397,8 @@ let assumed_infos : assumed_info list = Sig.array_subslice_sig true, true, to_name [ "@ArraySubsliceMut" ] ); + (* Array Repeat *) + (ArrayRepeat, Sig.array_repeat_sig, false, to_name [ "@ArrayRepeat" ]); (* Slice Index *) ( SliceIndexShared, Sig.slice_index_sig false, diff --git a/compiler/Driver.ml b/compiler/Driver.ml index 0fde1d74..8a30ead9 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -24,6 +24,8 @@ let _ = main_log#set_level EL.Info; llbc_of_json_logger#set_level EL.Info; pre_passes_log#set_level EL.Info; + associated_types_log#set_level EL.Info; + contexts_log#set_level EL.Info; interpreter_log#set_level EL.Info; statements_log#set_level EL.Info; loops_match_ctxs_log#set_level EL.Info; diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ce423acf..99ea14a4 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -338,6 +338,7 @@ let assumed_llbc_functions () : (ArraySubsliceShared, None, "array_subslice_shared"); (ArraySubsliceMut, None, "array_subslice_mut_fwd"); (ArraySubsliceMut, rg0, "array_subslice_mut_back"); + (ArrayRepeat, None, "array_repeat"); (SliceIndexShared, None, "slice_index_shared"); (SliceIndexMut, None, "slice_index_mut_fwd"); (SliceIndexMut, rg0, "slice_index_mut_back"); @@ -369,6 +370,7 @@ let assumed_llbc_functions () : (ArraySubsliceShared, None, "Array.subslice_shared"); (ArraySubsliceMut, None, "Array.subslice_mut"); (ArraySubsliceMut, rg0, "Array.subslice_mut_back"); + (ArrayRepeat, None, "Array.repeat"); (SliceIndexShared, None, "Slice.index_shared"); (SliceIndexMut, None, "Slice.index_mut"); (SliceIndexMut, rg0, "Slice.index_mut_back"); @@ -3212,7 +3214,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hvbox fmt ctx.indent_incr; let need_paren = inside in if need_paren then F.pp_print_string fmt "("; - (* Open the box for `Array.mk T N [` *) + (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) let cs = ctx_get_struct false (Assumed Array) ctx in diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 42073f0b..36bc3492 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -646,7 +646,7 @@ let eval_assumed_function_call_concrete (config : C.config) eval_vec_function_concrete config fid generics | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut | ArraySubsliceShared | ArraySubsliceMut - | SliceIndexShared | SliceIndexMut | SliceSubsliceShared + | ArrayRepeat | SliceIndexShared | SliceIndexMut | SliceSubsliceShared | SliceSubsliceMut | SliceLen -> raise (Failure "Unimplemented") in diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index d539dcf6..5fb5978b 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -610,6 +610,7 @@ let llbc_assumed_fun_id_to_string (fid : A.assumed_fun_id) : string = | ArrayToSliceMut -> "@ArrayToSliceMut" | ArraySubsliceShared -> "@ArraySubsliceShared" | ArraySubsliceMut -> "@ArraySubsliceMut" + | ArrayRepeat -> "@ArrayRepeat" | SliceLen -> "@SliceLen" | SliceIndexShared -> "@SliceIndexShared" | SliceIndexMut -> "@SliceIndexMut" diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 2130d5c2..cedc3559 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1563,7 +1563,7 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = | ArraySubsliceMut | SliceIndexShared | SliceIndexMut | SliceSubsliceShared | SliceSubsliceMut | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut - | SliceLen ), + | ArrayRepeat | SliceLen ), _ ) -> super#visit_texpression env e) | _ -> super#visit_texpression env e) -- cgit v1.2.3 From 0ba1c30f735f6e1cce771800d41042e6dc15e86f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 16 Oct 2023 10:10:40 +0200 Subject: Fix a small issue --- compiler/Driver.ml | 2 -- compiler/Interpreter.ml | 64 ++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 53 insertions(+), 13 deletions(-) (limited to 'compiler') diff --git a/compiler/Driver.ml b/compiler/Driver.ml index 8a30ead9..414b042d 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -168,8 +168,6 @@ let () = decompose_monadic_let_bindings := true; decompose_nested_let_patterns := true | Lean -> - (* The Lean backend is experimental: print a warning *) - log#lwarning (lazy "The Lean backend is experimental"); (* We don't support fuel for the Lean backend *) if !use_fuel then ( log#error "The Lean backend doesn't support the -use-fuel option"; diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 09f25ca1..24ff4808 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -84,22 +84,64 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) Subst.make_const_generic_subst_from_vars sg.generics.const_generics const_generics in - let tr_subst _ = raise (Failure "Unexpected local trait clause") in - let subst = { Subst.r_subst; ty_subst; cg_subst; tr_subst; tr_self } in - let trait_refs = - List.map - (fun (c : T.trait_clause) -> + (* TODO: some clauses may use the types of other clauses, so we may have to + reorder them. + + Example: + If in Rust we write: + {[ + pub fn use_get<'a, T: Get>(x: &'a mut T) -> u32 + where + T::Item: ToU32, + { + x.get().to_u32() + } + ]} + + In LLBC we get: + {[ + fn demo::use_get<'a, T>(@1: &'a mut (T)) -> u32 + where + [@TraitClause0]: demo::Get, + [@TraitClause1]: demo::ToU32<@TraitClause0::Item>, // HERE + { + ... // Omitted + } + ]} + *) + (* We will need to update the trait refs map while we perform the instantiations *) + let mk_tr_subst + (tr_map : T.erased_region T.trait_instance_id T.TraitClauseId.Map.t) + clause_id : T.erased_region T.trait_instance_id = + match T.TraitClauseId.Map.find_opt clause_id tr_map with + | Some tr -> tr + | None -> raise (Failure "Local trait clause not found") + in + let mk_subst tr_map = + let tr_subst = mk_tr_subst tr_map in + { Subst.r_subst; ty_subst; cg_subst; tr_subst; tr_self } + in + let _, trait_refs = + List.fold_left_map + (fun tr_map (c : T.trait_clause) -> + let subst = mk_subst tr_map in let { T.trait_id = trait_decl_id; generics; _ } = c in let generics = Subst.generic_args_substitute subst generics in let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in (* Note that because we directly refer to the clause, we give it empty generics *) - { - T.trait_id = T.Clause c.clause_id; - generics = TypesUtils.mk_empty_generic_args; - trait_decl_ref; - }) - trait_clauses + let trait_id = T.Clause c.clause_id in + let trait_ref = + { + T.trait_id; + generics = TypesUtils.mk_empty_generic_args; + trait_decl_ref; + } + in + (* Update the traits map *) + let tr_map = T.TraitClauseId.Map.add c.T.clause_id trait_id tr_map in + (tr_map, trait_ref)) + T.TraitClauseId.Map.empty trait_clauses in { T.regions; types; const_generics; trait_refs } in -- cgit v1.2.3 From cbb2d05e0db6bedf9d6844f29ee25b95429b994c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 16 Oct 2023 11:06:46 +0200 Subject: Improve formatting of scalars in Lean --- compiler/Extract.ml | 33 ++++++++++----------------------- 1 file changed, 10 insertions(+), 23 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 99ea14a4..b56d8c51 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -912,11 +912,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Scalar sv -> ( match !backend with | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) - | Coq | HOL4 -> + | Coq | HOL4 | Lean -> let print_brackets = inside && !backend = HOL4 in if print_brackets then F.pp_print_string fmt "("; (match !backend with - | Coq -> () + | Coq | Lean -> () | HOL4 -> F.pp_print_string fmt ("int_to_" ^ int_name sv.PV.int_ty); F.pp_print_space fmt () @@ -924,30 +924,17 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) (* We need to add parentheses if the value is negative *) if sv.PV.value >= Z.of_int 0 then F.pp_print_string fmt (Z.to_string sv.PV.value) - else F.pp_print_string fmt ("(" ^ Z.to_string sv.PV.value ^ ")"); + else + F.pp_print_string fmt + ("(" ^ Z.to_string sv.PV.value + ^ if !backend = Lean then ":Int" else "" ^ ")"); (match !backend with - | Coq -> F.pp_print_string fmt ("%" ^ int_name sv.PV.int_ty) + | Coq | Lean -> + let iname = String.lowercase_ascii (int_name sv.PV.int_ty) in + F.pp_print_string fmt ("%" ^ iname) | HOL4 -> () | _ -> raise (Failure "Unreachable")); - if print_brackets then F.pp_print_string fmt ")" - | Lean -> - F.pp_print_string fmt "("; - F.pp_print_string fmt (int_name sv.int_ty); - F.pp_print_string fmt ".ofInt "; - (* Something very annoying: negated values like `-3` are - ambiguous in Lean because of conversions, so we have to - be extremely explicit with negative numbers. - *) - if Z.lt sv.value Z.zero then ( - F.pp_print_string fmt "("; - F.pp_print_string fmt "-"; - F.pp_print_string fmt "("; - Z.pp_print fmt (Z.neg sv.value); - F.pp_print_string fmt ":Int"; - F.pp_print_string fmt ")"; - F.pp_print_string fmt ")") - else Z.pp_print fmt sv.value; - F.pp_print_string fmt ")") + if print_brackets then F.pp_print_string fmt ")") | Bool b -> let b = match !backend with -- cgit v1.2.3 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') 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.2.3 From c27c3052ec3f9a093b06a41f56b3a361cb65e950 Mon Sep 17 00:00:00 2001 From: Jonathan Protzenko Date: Sun, 22 Oct 2023 16:34:46 -0700 Subject: Add more support for numeric operations, xor, rotate --- compiler/Extract.ml | 11 +++++++---- compiler/FunsAnalysis.ml | 24 +++++++++++++++++++++--- 2 files changed, 28 insertions(+), 7 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ac81d6f3..b842aea1 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -3,7 +3,6 @@ the formatter everywhere... *) -open Utils open Pure open PureUtils open TranslateCore @@ -61,6 +60,11 @@ let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = | Le -> "le" | Ge -> "ge" | Gt -> "gt" + | BitXor -> "xor" + | BitAnd -> "and" + | BitOr -> "or" + | Shl -> "lsl" + | 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 *) @@ -498,14 +502,13 @@ let extract_binop (extract_expr : bool -> texpression -> unit) F.pp_print_string fmt binop; F.pp_print_space fmt (); extract_expr false arg1 - | _, (Lt | Le | Ge | Gt | Div | Rem | Add | Sub | Mul) -> + | _ -> let binop = named_binop_name binop int_ty in F.pp_print_string fmt binop; F.pp_print_space fmt (); extract_expr true arg0; F.pp_print_space fmt (); - extract_expr true arg1 - | _, (BitXor | BitAnd | BitOr | Shl | Shr) -> raise Unimplemented); + extract_expr true arg1); if inside then F.pp_print_string fmt ")" let type_decl_kind_to_qualif (kind : decl_kind) diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index f4406653..f8aa06dc 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -58,6 +58,24 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let can_diverge = ref false in let is_rec = ref false in + (* We have some specialized knowledge of some library functions; we don't + have any more custom treatment than this, and these functions can be modeled + suitably in Primitives.fst, rather than special-casing for them all the + way. *) + let module M = struct type opaque_info = { fallible: bool; stateful: bool } end in + let open M in + let opaque_info (f: fun_decl) = + match f.name with + | [ Ident "core"; Ident "num"; Ident "u32"; _; Ident "wrapping_add" ] + | [ Ident "core"; Ident "num"; Ident "u32"; _; Ident "rotate_left" ] -> + { fallible = false; stateful = false } + | _ -> + (* Opaque function: we consider they fail by default *) + { fallible = true; stateful = true } + in + + (* JP: Why not use a reduce visitor here with a tuple of the values to be + computed? *) let visit_fun (f : fun_decl) : unit = let obj = object (self) @@ -108,9 +126,9 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) assert ((not f.is_global_decl_body) || not !stateful); match f.body with | None -> - (* Opaque function: we consider they fail by default *) - obj#may_fail true; - stateful := (not f.is_global_decl_body) && use_state + let info = opaque_info f in + obj#may_fail info.fallible; + stateful := (not f.is_global_decl_body) && use_state && info.stateful | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; -- cgit v1.2.3 From 838cc86cb2efc8fb64a94a94b58b82d66844e7e4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 23 Oct 2023 13:47:39 +0200 Subject: Remove some assumed types and add more support for builtin definitions --- compiler/Assumed.ml | 254 +++++--------------- compiler/Extract.ml | 145 ++++++------ compiler/ExtractAssumed.ml | 61 ----- compiler/ExtractBase.ml | 73 +----- compiler/ExtractBuiltin.ml | 468 +++++++++++++++++++++++++++++++++++++ compiler/FunsAnalysis.ml | 2 +- compiler/InterpreterExpansion.ml | 15 +- compiler/InterpreterExpressions.ml | 100 +++----- compiler/InterpreterPaths.ml | 31 +-- compiler/InterpreterPaths.mli | 4 - compiler/InterpreterStatements.ml | 100 +------- compiler/Invariants.ml | 15 +- compiler/LlbcAstUtils.ml | 8 +- compiler/PrePasses.ml | 2 +- compiler/Print.ml | 11 - compiler/PrintPure.ml | 57 +---- compiler/Pure.ml | 12 +- compiler/PureMicroPasses.ml | 42 ++-- compiler/PureTypeCheck.ml | 13 +- compiler/Substitute.ml | 14 +- compiler/SymbolicToPure.ml | 31 +-- compiler/Translate.ml | 107 +++++---- compiler/TypesAnalysis.ml | 4 +- compiler/dune | 2 +- 24 files changed, 763 insertions(+), 808 deletions(-) delete mode 100644 compiler/ExtractAssumed.ml create mode 100644 compiler/ExtractBuiltin.ml (limited to 'compiler') diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index b1ec0660..94fb7a72 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -80,8 +80,6 @@ module Sig = struct let mk_slice_ty (ty : T.sty) : T.sty = Adt (Assumed Slice, mk_generic_args [] [ ty ] []) - let range_ty : T.sty = Adt (Assumed Range, mk_generic_args [] [ usize_ty ] []) - let mk_sig generics regions_hierarchy inputs output : A.fun_sig = let preds : T.predicates = { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } @@ -95,19 +93,6 @@ module Sig = struct output; } - (** [fn(&'a mut T, T) -> T] *) - let mem_replace_sig : A.fun_sig = - (* The signature fields *) - let regions = [ region_param_0 ] (* <'a> *) in - let regions_hierarchy = [ region_group_0 ] (* [{<'a>}] *) in - let types = [ type_param_0 ] (* *) in - let generics = mk_generic_params regions types [] in - let inputs = - [ mk_ref_ty rvar_0 tvar_0 true (* &'a mut T *); tvar_0 (* T *) ] - in - let output = tvar_0 (* T *) in - mk_sig generics regions_hierarchy inputs output - (** [fn(T) -> Box] *) let box_new_sig : A.fun_sig = let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in @@ -124,101 +109,6 @@ module Sig = struct let output = mk_unit_ty (* () *) in mk_sig generics regions_hierarchy inputs output - (** Helper for [Box::deref_shared] and [Box::deref_mut]. - Returns: - [fn<'a, T>(&'a (mut) Box) -> &'a (mut) T] - *) - let box_deref_gen_sig (is_mut : bool) : A.fun_sig = - let generics = - mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) - in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let inputs = - [ mk_ref_ty rvar_0 (mk_box_ty tvar_0) is_mut (* &'a (mut) Box *) ] - in - let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in - mk_sig generics regions_hierarchy inputs output - - (** [fn<'a, T>(&'a Box) -> &'a T] *) - let box_deref_shared_sig = box_deref_gen_sig false - - (** [fn<'a, T>(&'a mut Box) -> &'a mut T] *) - let box_deref_mut_sig = box_deref_gen_sig true - - (** [fn() -> Vec] *) - let vec_new_sig : A.fun_sig = - let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in - let regions_hierarchy = [] in - let inputs = [] in - let output = mk_vec_ty tvar_0 (* Vec *) in - mk_sig generics regions_hierarchy inputs output - - (** [fn(&'a mut Vec, T)] *) - let vec_push_sig : A.fun_sig = - let generics = - mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) - in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); - tvar_0 (* T *); - ] - in - let output = mk_unit_ty (* () *) in - mk_sig generics regions_hierarchy inputs output - - (** [fn(&'a mut Vec, usize, T)] *) - let vec_insert_sig : A.fun_sig = - let generics = - mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) - in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) true (* &'a mut Vec *); - mk_usize_ty (* usize *); - tvar_0 (* T *); - ] - in - let output = mk_unit_ty (* () *) in - mk_sig generics regions_hierarchy inputs output - - (** [fn(&'a Vec) -> usize] *) - let vec_len_sig : A.fun_sig = - let generics = - mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) - in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let inputs = - [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) false (* &'a Vec *) ] - in - let output = mk_usize_ty (* usize *) in - mk_sig generics regions_hierarchy inputs output - - (** Helper: - [fn(&'a (mut) Vec, usize) -> &'a (mut) T] - *) - let vec_index_gen_sig (is_mut : bool) : A.fun_sig = - let generics = - mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) - in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in - let inputs = - [ - mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec *); - mk_usize_ty (* usize *); - ] - in - let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in - mk_sig generics regions_hierarchy inputs output - - (** [fn(&'a Vec, usize) -> &'a T] *) - let vec_index_shared_sig : A.fun_sig = vec_index_gen_sig false - - (** [fn(&'a mut Vec, usize) -> &'a mut T] *) - let vec_index_mut_sig : A.fun_sig = vec_index_gen_sig true - (** Array/slice functions *) (** Small helper. @@ -281,23 +171,6 @@ module Sig = struct let cgs = [ cg_param_0 ] in mk_array_slice_borrow_sig cgs input_ty None output_ty is_mut - let mk_array_slice_subslice_sig (is_array : bool) (is_mut : bool) : A.fun_sig - = - (* Array *) - let input_ty id = - if is_array then mk_array_ty (T.TypeVar id) cgvar_0 - else mk_slice_ty (T.TypeVar id) - in - (* Range *) - let index_ty = range_ty in - (* Slice *) - let output_ty id = mk_slice_ty (T.TypeVar id) in - let cgs = if is_array then [ cg_param_0 ] else [] in - mk_array_slice_borrow_sig cgs input_ty (Some index_ty) output_ty is_mut - - let array_subslice_sig (is_mut : bool) = - mk_array_slice_subslice_sig true is_mut - let array_repeat_sig = let generics = (* *) @@ -311,9 +184,6 @@ module Sig = struct in mk_sig generics regions_hierarchy inputs output - let slice_subslice_sig (is_mut : bool) = - mk_array_slice_subslice_sig false is_mut - (** Helper: [fn(&'a [T]) -> usize] *) @@ -329,7 +199,25 @@ module Sig = struct mk_sig generics regions_hierarchy inputs output end -type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name +type raw_assumed_fun_info = + A.assumed_fun_id * A.fun_sig * bool * name * bool list option + +type assumed_fun_info = { + fun_id : A.assumed_fun_id; + fun_sig : A.fun_sig; + can_fail : bool; + name : name; + keep_types : bool list option; + (** We may want to filter some type arguments. + + For instance, all the `Vec` functions (and the `Vec` type itself) take + an `Allocator` type as argument, that we ignore. + *) +} + +let mk_assumed_fun_info (raw : raw_assumed_fun_info) : assumed_fun_info = + let fun_id, fun_sig, can_fail, name, keep_types = raw in + { fun_id; fun_sig; can_fail; name; keep_types } (** The list of assumed functions and all their information: - their signature @@ -342,96 +230,72 @@ type assumed_info = A.assumed_fun_id * A.fun_sig * bool * name a [usize], we have to make sure that vectors are bounded by the max usize. As a consequence, [Vec::push] is monadic. *) -let assumed_infos : assumed_info list = - let deref_pre = [ "core"; "ops"; "deref" ] in - let vec_pre = [ "alloc"; "vec"; "Vec" ] in - let index_pre = [ "core"; "ops"; "index" ] in +let raw_assumed_fun_infos : raw_assumed_fun_info list = [ - (Replace, Sig.mem_replace_sig, false, to_name [ "core"; "mem"; "replace" ]); - (BoxNew, Sig.box_new_sig, false, to_name [ "alloc"; "boxed"; "Box"; "new" ]); + ( BoxNew, + Sig.box_new_sig, + false, + to_name [ "alloc"; "boxed"; "Box"; "new" ], + Some [ true; false ] ); + (* BoxFree shouldn't be used *) ( BoxFree, Sig.box_free_sig, false, - to_name [ "alloc"; "boxed"; "Box"; "free" ] ); - ( BoxDeref, - Sig.box_deref_shared_sig, - false, - to_name (deref_pre @ [ "Deref"; "deref" ]) ); - ( BoxDerefMut, - Sig.box_deref_mut_sig, - false, - to_name (deref_pre @ [ "DerefMut"; "deref_mut" ]) ); - (VecNew, Sig.vec_new_sig, false, to_name (vec_pre @ [ "new" ])); - (VecPush, Sig.vec_push_sig, true, to_name (vec_pre @ [ "push" ])); - (VecInsert, Sig.vec_insert_sig, true, to_name (vec_pre @ [ "insert" ])); - (VecLen, Sig.vec_len_sig, false, to_name (vec_pre @ [ "len" ])); - ( VecIndex, - Sig.vec_index_shared_sig, - true, - to_name (index_pre @ [ "Index"; "index" ]) ); - ( VecIndexMut, - Sig.vec_index_mut_sig, - true, - to_name (index_pre @ [ "IndexMut"; "index_mut" ]) ); + to_name [ "alloc"; "boxed"; "Box"; "free" ], + Some [ true; false ] ); (* Array Index *) ( ArrayIndexShared, Sig.array_index_sig false, true, - to_name [ "@ArrayIndexShared" ] ); - (ArrayIndexMut, Sig.array_index_sig true, true, to_name [ "@ArrayIndexMut" ]); + to_name [ "@ArrayIndexShared" ], + None ); + ( ArrayIndexMut, + Sig.array_index_sig true, + true, + to_name [ "@ArrayIndexMut" ], + None ); (* Array to slice*) ( ArrayToSliceShared, Sig.array_to_slice_sig false, true, - to_name [ "@ArrayToSliceShared" ] ); + to_name [ "@ArrayToSliceShared" ], + None ); ( ArrayToSliceMut, Sig.array_to_slice_sig true, true, - to_name [ "@ArrayToSliceMut" ] ); - (* Array Subslice *) - ( ArraySubsliceShared, - Sig.array_subslice_sig false, - true, - to_name [ "@ArraySubsliceShared" ] ); - ( ArraySubsliceMut, - Sig.array_subslice_sig true, - true, - to_name [ "@ArraySubsliceMut" ] ); + to_name [ "@ArrayToSliceMut" ], + None ); (* Array Repeat *) - (ArrayRepeat, Sig.array_repeat_sig, false, to_name [ "@ArrayRepeat" ]); + (ArrayRepeat, Sig.array_repeat_sig, false, to_name [ "@ArrayRepeat" ], None); (* Slice Index *) ( SliceIndexShared, Sig.slice_index_sig false, true, - to_name [ "@SliceIndexShared" ] ); - (SliceIndexMut, Sig.slice_index_sig true, true, to_name [ "@SliceIndexMut" ]); - (* Slice Subslice *) - ( SliceSubsliceShared, - Sig.slice_subslice_sig false, + to_name [ "@SliceIndexShared" ], + None ); + ( SliceIndexMut, + Sig.slice_index_sig true, true, - to_name [ "@SliceSubsliceShared" ] ); - ( SliceSubsliceMut, - Sig.slice_subslice_sig true, - true, - to_name [ "@SliceSubsliceMut" ] ); - (SliceLen, Sig.slice_len_sig, false, to_name [ "@SliceLen" ]); + to_name [ "@SliceIndexMut" ], + None ); + (SliceLen, Sig.slice_len_sig, false, to_name [ "@SliceLen" ], None); ] -let get_assumed_info (id : A.assumed_fun_id) : assumed_info = - match List.find_opt (fun (id', _, _, _) -> id = id') assumed_infos with +let assumed_fun_infos : assumed_fun_info list = + List.map mk_assumed_fun_info raw_assumed_fun_infos + +let get_assumed_fun_info (id : A.assumed_fun_id) : assumed_fun_info = + match List.find_opt (fun x -> id = x.fun_id) assumed_fun_infos with | Some info -> info | None -> raise - (Failure ("get_assumed_info: not found: " ^ A.show_assumed_fun_id id)) + (Failure ("get_assumed_fun_info: not found: " ^ A.show_assumed_fun_id id)) -let get_assumed_sig (id : A.assumed_fun_id) : A.fun_sig = - let _, sg, _, _ = get_assumed_info id in - sg +let get_assumed_fun_sig (id : A.assumed_fun_id) : A.fun_sig = + (get_assumed_fun_info id).fun_sig -let get_assumed_name (id : A.assumed_fun_id) : fun_name = - let _, _, _, name = get_assumed_info id in - name +let get_assumed_fun_name (id : A.assumed_fun_id) : fun_name = + (get_assumed_fun_info id).name -let assumed_can_fail (id : A.assumed_fun_id) : bool = - let _, _, b, _ = get_assumed_info id in - b +let assumed_fun_can_fail (id : A.assumed_fun_id) : bool = + (get_assumed_fun_info id).can_fail diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 688f6ce3..30c4c27d 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -225,12 +225,9 @@ let assumed_adts () : (assumed_ty * string) list = (Result, "Result"); (Error, "Error"); (Fuel, "Nat"); - (Option, "Option"); - (Vec, "Vec"); (Array, "Array"); (Slice, "Slice"); (Str, "Str"); - (Range, "Range"); ] | Coq | FStar -> [ @@ -238,12 +235,9 @@ let assumed_adts () : (assumed_ty * string) list = (Result, "result"); (Error, "error"); (Fuel, "nat"); - (Option, "option"); - (Vec, "vec"); (Array, "array"); (Slice, "slice"); (Str, "str"); - (Range, "range"); ] | HOL4 -> [ @@ -251,20 +245,17 @@ let assumed_adts () : (assumed_ty * string) list = (Result, "result"); (Error, "error"); (Fuel, "num"); - (Option, "option"); - (Vec, "vec"); (Array, "array"); (Slice, "slice"); (Str, "str"); - (Range, "range"); ] let assumed_struct_constructors () : (assumed_ty * string) list = match !backend with - | Lean -> [ (Range, "Range.mk"); (Array, "Array.make") ] - | Coq -> [ (Range, "mk_range"); (Array, "mk_array") ] - | FStar -> [ (Range, "Mkrange"); (Array, "mk_array") ] - | HOL4 -> [ (Range, "mk_range"); (Array, "mk_array") ] + | Lean -> [ (Array, "Array.make") ] + | Coq -> [ (Array, "mk_array") ] + | FStar -> [ (Array, "mk_array") ] + | HOL4 -> [ (Array, "mk_array") ] let assumed_variants () : (assumed_ty * VariantId.id * string) list = match !backend with @@ -276,8 +267,6 @@ let assumed_variants () : (assumed_ty * VariantId.id * string) list = (Error, error_out_of_fuel_id, "OutOfFuel"); (* No Fuel::Zero on purpose *) (* No Fuel::Succ on purpose *) - (Option, option_some_id, "Some"); - (Option, option_none_id, "None"); ] | Coq -> [ @@ -287,8 +276,6 @@ let assumed_variants () : (assumed_ty * VariantId.id * string) list = (Error, error_out_of_fuel_id, "OutOfFuel"); (Fuel, fuel_zero_id, "O"); (Fuel, fuel_succ_id, "S"); - (Option, option_some_id, "Some"); - (Option, option_none_id, "None"); ] | Lean -> [ @@ -297,8 +284,6 @@ let assumed_variants () : (assumed_ty * VariantId.id * string) list = (Error, error_failure_id, "panic"); (* No Fuel::Zero on purpose *) (* No Fuel::Succ on purpose *) - (Option, option_some_id, "some"); - (Option, option_none_id, "none"); ] | HOL4 -> [ @@ -307,8 +292,6 @@ let assumed_variants () : (assumed_ty * VariantId.id * string) list = (Error, error_failure_id, "Failure"); (* No Fuel::Zero on purpose *) (* No Fuel::Succ on purpose *) - (Option, option_some_id, "SOME"); - (Option, option_none_id, "NONE"); ] let assumed_llbc_functions () : @@ -317,66 +300,30 @@ let assumed_llbc_functions () : match !backend with | FStar | Coq | HOL4 -> [ - (Replace, None, "mem_replace_fwd"); - (Replace, rg0, "mem_replace_back"); - (VecNew, None, "vec_new"); - (VecPush, None, "vec_push_fwd") (* Shouldn't be used *); - (VecPush, rg0, "vec_push_back"); - (VecInsert, None, "vec_insert_fwd") (* Shouldn't be used *); - (VecInsert, rg0, "vec_insert_back"); - (VecLen, None, "vec_len"); - (VecIndex, None, "vec_index_fwd"); - (VecIndex, rg0, "vec_index_back") (* shouldn't be used *); - (VecIndexMut, None, "vec_index_mut_fwd"); - (VecIndexMut, rg0, "vec_index_mut_back"); (ArrayIndexShared, None, "array_index_shared"); (ArrayIndexMut, None, "array_index_mut_fwd"); (ArrayIndexMut, rg0, "array_index_mut_back"); (ArrayToSliceShared, None, "array_to_slice_shared"); (ArrayToSliceMut, None, "array_to_slice_mut_fwd"); (ArrayToSliceMut, rg0, "array_to_slice_mut_back"); - (ArraySubsliceShared, None, "array_subslice_shared"); - (ArraySubsliceMut, None, "array_subslice_mut_fwd"); - (ArraySubsliceMut, rg0, "array_subslice_mut_back"); (ArrayRepeat, None, "array_repeat"); (SliceIndexShared, None, "slice_index_shared"); (SliceIndexMut, None, "slice_index_mut_fwd"); (SliceIndexMut, rg0, "slice_index_mut_back"); - (SliceSubsliceShared, None, "slice_subslice_shared"); - (SliceSubsliceMut, None, "slice_subslice_mut_fwd"); - (SliceSubsliceMut, rg0, "slice_subslice_mut_back"); (SliceLen, None, "slice_len"); ] | Lean -> [ - (Replace, None, "mem.replace"); - (Replace, rg0, "mem.replace_back"); - (VecNew, None, "Vec.new"); - (VecPush, None, "Vec.push_fwd") (* Shouldn't be used *); - (VecPush, rg0, "Vec.push"); - (VecInsert, None, "Vec.insert_fwd") (* Shouldn't be used *); - (VecInsert, rg0, "Vec.insert"); - (VecLen, None, "Vec.len"); - (VecIndex, None, "Vec.index_shared"); - (VecIndex, rg0, "Vec.index_shared_back") (* shouldn't be used *); - (VecIndexMut, None, "Vec.index_mut"); - (VecIndexMut, rg0, "Vec.index_mut_back"); (ArrayIndexShared, None, "Array.index_shared"); (ArrayIndexMut, None, "Array.index_mut"); (ArrayIndexMut, rg0, "Array.index_mut_back"); (ArrayToSliceShared, None, "Array.to_slice_shared"); (ArrayToSliceMut, None, "Array.to_slice_mut"); (ArrayToSliceMut, rg0, "Array.to_slice_mut_back"); - (ArraySubsliceShared, None, "Array.subslice_shared"); - (ArraySubsliceMut, None, "Array.subslice_mut"); - (ArraySubsliceMut, rg0, "Array.subslice_mut_back"); (ArrayRepeat, None, "Array.repeat"); (SliceIndexShared, None, "Slice.index_shared"); (SliceIndexMut, None, "Slice.index_mut"); (SliceIndexMut, rg0, "Slice.index_mut_back"); - (SliceSubsliceShared, None, "Slice.subslice_shared"); - (SliceSubsliceMut, None, "Slice.subslice_mut"); - (SliceSubsliceMut, rg0, "Slice.subslice_mut_back"); (SliceLen, None, "Slice.len"); ] @@ -850,12 +797,9 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Assumed Result -> "r" | Assumed Error -> ConstStrings.error_basename | Assumed Fuel -> ConstStrings.fuel_basename - | Assumed Option -> "opt" - | Assumed Vec -> "v" | Assumed Array -> "a" | Assumed Slice -> "s" | Assumed Str -> "s" - | Assumed Range -> "r" | Assumed State -> ConstStrings.state_basename | AdtId adt_id -> let def = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in @@ -1397,8 +1341,18 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : extraction_ctx = + (* Lookup the builtin information, if there is *) + let open ExtractBuiltin in + let sname = name_to_simple_name def.name in + let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in (* Compute and register the type def name *) - let ctx = ctx_add_type_decl def ctx in + let def_name = + match info with + | None -> ctx.fmt.type_name def.name + | Some info -> info.rust_name + in + let is_opaque = def.kind = Opaque in + let ctx = ctx_add is_opaque (TypeId (AdtId def.def_id)) def_name ctx in (* Compute and register: * - the variant names, if this is an enumeration * - the field names, if this is a structure @@ -1406,18 +1360,73 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let ctx = match def.kind with | Struct fields -> + (* Compute the names *) + let field_names, cons_name = + match info with + | None -> + let field_names = + FieldId.mapi + (fun fid (field : field) -> + (fid, ctx.fmt.field_name def.name fid field.field_name)) + fields + in + let cons_name = ctx.fmt.struct_constructor def.name in + (field_names, cons_name) + | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> + let field_names = + FieldId.mapi + (fun fid (_, name) -> (fid, name)) + (List.combine fields field_names) + in + (field_names, cons_name) + | _ -> raise (Failure "Invalid builtin information") + in (* Add the fields *) let ctx = - fst - (ctx_add_fields def (FieldId.mapi (fun id f -> (id, f)) fields) ctx) + List.fold_left + (fun ctx (fid, name) -> + ctx_add is_opaque (FieldId (AdtId def.def_id, fid)) name ctx) + ctx field_names in (* Add the constructor name *) - fst (ctx_add_struct def ctx) + ctx_add is_opaque (StructId (AdtId def.def_id)) cons_name ctx | Enum variants -> - fst - (ctx_add_variants def - (VariantId.mapi (fun id v -> (id, v)) variants) - ctx) + let variant_names = + match info with + | None -> + VariantId.mapi + (fun variant_id (variant : variant) -> + let name = + ctx.fmt.variant_name def.name variant.variant_name + in + (* Add the type name prefix for Lean *) + let name = + if !Config.backend = Lean then + let type_name = ctx.fmt.type_name def.name in + type_name ^ "." ^ name + else name + in + (variant_id, name)) + variants + | Some { body_info = Some (Enum variant_infos); _ } -> + (* We need to compute the map from variant to variant *) + let variant_map = + StringMap.of_list + (List.map + (fun (info : builtin_enum_variant_info) -> + (info.rust_variant_name, info.extract_variant_name)) + variant_infos) + in + VariantId.mapi + (fun variant_id (variant : variant) -> + (variant_id, StringMap.find variant.variant_name variant_map)) + variants + | _ -> raise (Failure "Invalid builtin information") + in + List.fold_left + (fun ctx (vid, vname) -> + ctx_add is_opaque (VariantId (AdtId def.def_id, vid)) vname ctx) + ctx variant_names | Opaque -> (* Nothing to do *) ctx diff --git a/compiler/ExtractAssumed.ml b/compiler/ExtractAssumed.ml deleted file mode 100644 index 7f094b24..00000000 --- a/compiler/ExtractAssumed.ml +++ /dev/null @@ -1,61 +0,0 @@ -(** This file declares external identifiers that we catch to map them to - definitions coming from the standard libraries in our backends. *) - -open Names - -type simple_name = string list [@@deriving show, ord] - -let name_to_simple_name (s : name) : simple_name = - (* We simply ignore the disambiguators *) - List.filter_map (function Ident id -> Some id | Disambiguator _ -> None) s - -(** Small helper which cuts a string at the occurrences of "::" *) -let string_to_simple_name (s : string) : simple_name = - (* No function to split by using string separator?? *) - let name = String.split_on_char ':' s in - List.filter (fun s -> s <> "") name - -module SimpleNameOrd = struct - type t = simple_name - - let compare = compare_simple_name - let to_string = show_simple_name - let pp_t = pp_simple_name - let show_t = show_simple_name -end - -module SimpleNameMap = Collections.MakeMap (SimpleNameOrd) - -let assumed_globals : (string * string) list = - [ - (* Min *) - ("core::num::usize::MIN", "core_usize_min"); - ("core::num::u8::MIN", "core_u8_min"); - ("core::num::u16::MIN", "core_u16_min"); - ("core::num::u32::MIN", "core_u32_min"); - ("core::num::u64::MIN", "core_u64_min"); - ("core::num::u128::MIN", "core_u128_min"); - ("core::num::isize::MIN", "core_isize_min"); - ("core::num::i8::MIN", "core_i8_min"); - ("core::num::i16::MIN", "core_i16_min"); - ("core::num::i32::MIN", "core_i32_min"); - ("core::num::i64::MIN", "core_i64_min"); - ("core::num::i128::MIN", "core_i128_min"); - (* Max *) - ("core::num::usize::MAX", "core_usize_max"); - ("core::num::u8::MAX", "core_u8_max"); - ("core::num::u16::MAX", "core_u16_max"); - ("core::num::u32::MAX", "core_u32_max"); - ("core::num::u64::MAX", "core_u64_max"); - ("core::num::u128::MAX", "core_u128_max"); - ("core::num::isize::MAX", "core_isize_max"); - ("core::num::i8::MAX", "core_i8_max"); - ("core::num::i16::MAX", "core_i16_max"); - ("core::num::i32::MAX", "core_i32_max"); - ("core::num::i64::MAX", "core_i64_max"); - ("core::num::i128::MAX", "core_i128_max"); - ] - -let assumed_globals_map : string SimpleNameMap.t = - SimpleNameMap.of_list - (List.map (fun (x, y) -> (string_to_simple_name x, y)) assumed_globals) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index a921515b..54f69735 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -5,7 +5,7 @@ open TranslateCore module C = Contexts module RegionVarId = T.RegionVarId module F = Format -open ExtractAssumed +open ExtractBuiltin (** The local logger *) let log = L.pure_to_extract_log @@ -803,15 +803,11 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = if variant_id = error_failure_id then "@error::Failure" else if variant_id = error_out_of_fuel_id then "@error::OutOfFuel" else raise (Failure "Unreachable") - | Assumed Option -> - if variant_id = option_some_id then "@option::Some" - else if variant_id = option_none_id then "@option::None" - else raise (Failure "Unreachable") | Assumed Fuel -> if variant_id = fuel_zero_id then "@fuel::0" else if variant_id = fuel_succ_id then "@fuel::Succ" else raise (Failure "Unreachable") - | Assumed (State | Vec | Array | Slice | Str | Range) -> + | Assumed (State | Array | Slice | Str) -> raise (Failure ("Unreachable: variant id (" @@ -830,9 +826,7 @@ 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 | Option | Vec | Array | Slice | Str - | Range ) -> + | Assumed (State | Result | Error | Fuel | Array | Slice | Str) -> (* We can't directly have access to the fields of those types *) raise (Failure "Unreachable") | AdtId id -> ( @@ -1186,65 +1180,6 @@ let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : let ctx, tcs = ctx_add_local_trait_clauses trait_clauses ctx in (ctx, tys, cgs, tcs) -let ctx_add_type_decl_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - assert (match def.kind with Struct _ -> true | _ -> false); - let is_opaque = false in - let cons_name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add is_opaque (StructId (AdtId def.def_id)) cons_name ctx in - (ctx, cons_name) - -let ctx_add_type_decl (def : type_decl) (ctx : extraction_ctx) : extraction_ctx - = - let is_opaque = def.kind = Opaque in - let def_name = ctx.fmt.type_name def.name in - let ctx = ctx_add is_opaque (TypeId (AdtId def.def_id)) def_name ctx in - ctx - -let ctx_add_field (def : type_decl) (field_id : FieldId.id) (field : field) - (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in - let name = ctx.fmt.field_name def.name field_id field.field_name in - let ctx = ctx_add is_opaque (FieldId (AdtId def.def_id, field_id)) name ctx in - (ctx, name) - -let ctx_add_fields (def : type_decl) (fields : (FieldId.id * field) list) - (ctx : extraction_ctx) : extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_field def vid v ctx) - ctx fields - -let ctx_add_variant (def : type_decl) (variant_id : VariantId.id) - (variant : variant) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in - let name = ctx.fmt.variant_name def.name variant.variant_name in - (* Add the type name prefix for Lean *) - let name = - if !Config.backend = Lean then - let type_name = ctx.fmt.type_name def.name in - type_name ^ "." ^ name - else name - in - let ctx = - ctx_add is_opaque (VariantId (AdtId def.def_id, variant_id)) name ctx - in - (ctx, name) - -let ctx_add_variants (def : type_decl) - (variants : (VariantId.id * variant) list) (ctx : extraction_ctx) : - extraction_ctx * string list = - List.fold_left_map - (fun ctx (vid, v) -> ctx_add_variant def vid v ctx) - ctx variants - -let ctx_add_struct (def : type_decl) (ctx : extraction_ctx) : - extraction_ctx * string = - assert (match def.kind with Struct _ -> true | _ -> false); - let is_opaque = false in - let name = ctx.fmt.struct_constructor def.name in - let ctx = ctx_add is_opaque (StructId (AdtId def.def_id)) name ctx in - (ctx, name) - let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let is_opaque = false in @@ -1277,7 +1212,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : to a custom definition in our standard library (for instance, happens with "core::num::usize::MAX") *) let sname = name_to_simple_name def.name in - match SimpleNameMap.find_opt sname assumed_globals_map with + match SimpleNameMap.find_opt sname builtin_globals_map with | Some name -> (* Yes: register the custom binding *) ctx_add is_opaque decl name ctx diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml new file mode 100644 index 00000000..cf5cc70d --- /dev/null +++ b/compiler/ExtractBuiltin.ml @@ -0,0 +1,468 @@ +(** This file declares external identifiers that we catch to map them to + definitions coming from the standard libraries in our backends. *) + +open Names +open Config + +type simple_name = string list [@@deriving show, ord] + +let name_to_simple_name (s : name) : simple_name = + (* We simply ignore the disambiguators *) + List.filter_map (function Ident id -> Some id | Disambiguator _ -> None) s + +(** Small helper which cuts a string at the occurrences of "::" *) +let string_to_simple_name (s : string) : simple_name = + (* No function to split by using string separator?? *) + let name = String.split_on_char ':' s in + List.filter (fun s -> s <> "") name + +module SimpleNameOrd = struct + type t = simple_name + + let compare = compare_simple_name + let to_string = show_simple_name + let pp_t = pp_simple_name + let show_t = show_simple_name +end + +module SimpleNameMap = Collections.MakeMap (SimpleNameOrd) + +(** Small utility to memoize some computations *) +let mk_memoized (f : unit -> 'a) : unit -> 'a = + let r = ref None in + let g () = + match !r with + | Some x -> x + | None -> + let x = f () in + r := Some x; + x + in + g + +let builtin_globals : (string * string) list = + [ + (* Min *) + ("core::num::usize::MIN", "core_usize_min"); + ("core::num::u8::MIN", "core_u8_min"); + ("core::num::u16::MIN", "core_u16_min"); + ("core::num::u32::MIN", "core_u32_min"); + ("core::num::u64::MIN", "core_u64_min"); + ("core::num::u128::MIN", "core_u128_min"); + ("core::num::isize::MIN", "core_isize_min"); + ("core::num::i8::MIN", "core_i8_min"); + ("core::num::i16::MIN", "core_i16_min"); + ("core::num::i32::MIN", "core_i32_min"); + ("core::num::i64::MIN", "core_i64_min"); + ("core::num::i128::MIN", "core_i128_min"); + (* Max *) + ("core::num::usize::MAX", "core_usize_max"); + ("core::num::u8::MAX", "core_u8_max"); + ("core::num::u16::MAX", "core_u16_max"); + ("core::num::u32::MAX", "core_u32_max"); + ("core::num::u64::MAX", "core_u64_max"); + ("core::num::u128::MAX", "core_u128_max"); + ("core::num::isize::MAX", "core_isize_max"); + ("core::num::i8::MAX", "core_i8_max"); + ("core::num::i16::MAX", "core_i16_max"); + ("core::num::i32::MAX", "core_i32_max"); + ("core::num::i64::MAX", "core_i64_max"); + ("core::num::i128::MAX", "core_i128_max"); + ] + +let builtin_globals_map : string SimpleNameMap.t = + SimpleNameMap.of_list + (List.map (fun (x, y) -> (string_to_simple_name x, y)) builtin_globals) + +type builtin_variant_info = { fields : (string * string) list } + +type builtin_enum_variant_info = { + rust_variant_name : string; + extract_variant_name : string; + fields : string list option; +} + +type builtin_type_body_info = + | Struct of string * string list + (* The constructor name and the map for the field names *) + | Enum of builtin_enum_variant_info list +(* For every variant, a map for the field names *) + +type builtin_type_info = { + rust_name : string; + extract_name : string; + keep_params : bool list option; + (** We might want to filter some of the type parameters. + + For instance, `Vec` type takes a type parameter for the allocator, + which we want to ignore. + *) + body_info : builtin_type_body_info option; +} + +(** The assumed types. + + The optional list of booleans is filtering information for the type + parameters. For instance, in the case of the `Vec` functions, there is + a type parameter for the allocator to use, which we want to filter. + *) +let builtin_types () : builtin_type_info list = + [ + (* Alloc *) + { + rust_name = "alloc::alloc::Global"; + extract_name = + (match !backend with + | Lean -> "AllocGlobal" + | Coq | FStar | HOL4 -> "alloc_global"); + keep_params = None; + body_info = None; + }; + (* Vec *) + { + rust_name = "alloc::vec::Vec"; + extract_name = + (match !backend with Lean -> "Vec" | Coq | FStar | HOL4 -> "vec"); + keep_params = Some [ true; false ]; + body_info = None; + }; + (* Option *) + { + rust_name = "core::option::Option"; + extract_name = + (match !backend with + | Lean -> "Option" + | Coq | FStar | HOL4 -> "option"); + keep_params = None; + body_info = + Some + (Enum + [ + { + rust_variant_name = "None"; + extract_variant_name = + (match !backend with + | FStar | Coq -> "None" + | Lean -> "none" + | HOL4 -> "NONE"); + fields = None; + }; + { + rust_variant_name = "Some"; + extract_variant_name = + (match !backend with + | FStar | Coq -> "Some" + | Lean -> "some" + | HOL4 -> "SOME"); + fields = None; + }; + ]); + }; + (* Range *) + { + rust_name = "core::ops::range::Range"; + extract_name = + (match !backend with Lean -> "Range" | Coq | FStar | HOL4 -> "range"); + keep_params = None; + body_info = + Some + (Struct + ( (match !backend with + | Lean -> "Range.mk" + | Coq | HOL4 -> "mk_range" + | FStar -> "Mkrange"), + [ "start"; "end_" ] )); + }; + ] + +let mk_builtin_types_map () = + SimpleNameMap.of_list + (List.map + (fun info -> (string_to_simple_name info.rust_name, info)) + (builtin_types ())) + +let builtin_types_map = mk_memoized mk_builtin_types_map + +type builtin_fun_info = { + rg : Types.RegionGroupId.id option; + extract_name : string; +} + +(** The assumed functions. + + The optional list of booleans is filtering information for the type + parameters. For instance, in the case of the `Vec` functions, there is + a type parameter for the allocator to use, which we want to filter. + *) +let builtin_funs () : (string * bool list option * builtin_fun_info list) list = + let rg0 = Some Types.RegionGroupId.zero in + [ + ( "core::mem::replace", + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "mem_replace_fwd" + | Lean -> "mem.replace"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "mem_replace_back" + | Lean -> "mem.replace_back"); + }; + ] ); + ( "alloc::vec::Vec::new", + Some [ true; false ], + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_new" + | Lean -> "Vec.new"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_new_back" + | Lean -> "Vec.new_back"); + }; + ] ); + ( "alloc::vec::Vec::push", + Some [ true; false ], + [ + (* The forward function shouldn't be used *) + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_push_fwd" + | Lean -> "Vec.push_fwd"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_push_back" + | Lean -> "Vec.push"); + }; + ] ); + ( "alloc::vec::Vec::insert", + Some [ true; false ], + [ + (* The forward function shouldn't be used *) + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_insert_fwd" + | Lean -> "Vec.insert_fwd"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_insert_back" + | Lean -> "Vec.insert"); + }; + ] ); + ( "alloc::vec::Vec::len", + Some [ true; false ], + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_len" + | Lean -> "Vec.len"); + }; + ] ); + ( "alloc::vec::Vec::index", + Some [ true; false ], + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_index_fwd" + | Lean -> "Vec.index_shared"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_index_back" + | Lean -> "Vec.index_shared_back"); + }; + ] ); + ( "alloc::vec::Vec::index_mut", + Some [ true; false ], + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_index_mut_fwd" + | Lean -> "Vec.index_mut"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "vec_index_mut_back" + | Lean -> "Vec.index_mut_back"); + }; + ] ); + ] + +let mk_builtin_funs_map () = + SimpleNameMap.of_list + (List.map + (fun (name, filter, info) -> + (string_to_simple_name name, (filter, info))) + (builtin_funs ())) + +let builtin_funs_map () = mk_memoized mk_builtin_funs_map + +type builtin_trait_info = { + rust_name : string; + extract_name : string; + parent_clauses : string list; + consts : (string * string) list; + types : (string * string * string list) list; + (** Every type has: + - a Rust name + - an extraction name + - a list of clauses *) + funs : (string * Types.RegionGroupId.id option * string) list; +} + +let builtin_traits () = + let rg0 = Some Types.RegionGroupId.zero in + [ + { + (* Deref *) + rust_name = "core::ops::deref::Deref"; + extract_name = + (match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_Deref" + | Lean -> "core.ops.deref.Deref"); + parent_clauses = []; + consts = []; + types = + [ + ( "Target", + (match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_Deref_Target" + | Lean -> "Target"), + [] ); + ]; + funs = + [ + ( "deref", + None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_Deref_deref" + | Lean -> "deref" ); + ]; + }; + { + (* DerefMut *) + rust_name = "core::ops::deref::DerefMut"; + extract_name = + (match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut" + | Lean -> "core.ops.deref.DerefMut"); + parent_clauses = + [ + (match !backend with + | Coq | FStar | HOL4 -> "deref_inst" + | Lean -> "DerefInst"); + ]; + consts = []; + types = []; + funs = + [ + ( "deref_mut", + None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut" + | Lean -> "deref_mut" ); + ( "deref_mut", + rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut_back" + | Lean -> "deref_mut_back" ); + ]; + }; + { + (* Index *) + rust_name = "core::ops::index::Index"; + extract_name = + (match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_Index" + | Lean -> "core.ops.index.Index"); + parent_clauses = []; + consts = []; + types = + [ + ( "Output", + (match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_Index_Output" + | Lean -> "Output"), + [] ); + ]; + funs = + [ + ( "index", + None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_Index_index" + | Lean -> "index" ); + ]; + }; + { + (* IndexMut *) + rust_name = "core::ops::index::IndexMut"; + extract_name = + (match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_IndexMut" + | Lean -> "core.ops.index.IndexMut"); + parent_clauses = + [ + (match !backend with + | Coq | FStar | HOL4 -> "index_inst" + | Lean -> "IndexInst"); + ]; + consts = []; + types = []; + funs = + [ + ( "index_mut", + None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut" + | Lean -> "index_mut" ); + ( "index_mut", + rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut_back" + | Lean -> "index_mut_back" ); + ]; + }; + ] + +let mk_builtin_traits_map () = + SimpleNameMap.of_list + (List.map + (fun info -> (string_to_simple_name info.rust_name, info)) + (builtin_traits ())) + +let builtin_traits_map () = mk_memoized mk_builtin_traits_map diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index a09a6d05..5e849ba7 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -88,7 +88,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) can_diverge := !can_diverge || info.can_diverge | FunId (Assumed id) -> (* None of the assumed functions can diverge nor are considered stateful *) - can_fail := !can_fail || Assumed.assumed_can_fail id + can_fail := !can_fail || Assumed.assumed_fun_can_fail id | TraitMethod _ -> (* We consider trait functions can fail, diverge, and are not stateful *) can_fail := true; diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index c1041fa3..167e3d58 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -241,17 +241,6 @@ let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -(** Compute the expansion of an Option value. - *) -let compute_expanded_symbolic_option_value (expand_enumerations : bool) - (kind : V.sv_kind) (ty : T.rty) : V.symbolic_expansion list = - assert expand_enumerations; - let some_se = - V.SeAdt (Some T.option_some_id, [ mk_fresh_symbolic_value kind ty ]) - in - let none_se = V.SeAdt (Some T.option_none_id, []) in - [ none_se; some_se ] - let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) (field_types : T.rty list) : V.symbolic_expansion = (* Generate the field values *) @@ -286,8 +275,6 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) def_id generics ctx | T.Tuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind generics.types ] - | T.Assumed T.Option, [], [ ty ] -> - compute_expanded_symbolic_option_value expand_enumerations kind ty | T.Assumed T.Box, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] | _ -> @@ -704,7 +691,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = | T.Adt ((Tuple | Assumed Box), _) | T.Ref (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Vec | Option | Array | Slice | Str | Range), _) -> + | T.Adt (Assumed (Array | Slice | Str), _) -> (* We can't expand those *) raise (Failure diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index a42c552a..341e97eb 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -142,10 +142,10 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) | V.Adt av -> (* Sanity check *) (match v.V.ty with - | T.Adt (T.Assumed (T.Box | Vec), _) -> + | T.Adt (T.Assumed T.Box, _) -> raise (Failure "Can't copy an assumed value other than Option") | T.Adt (T.AdtId _, _) -> assert allow_adt_copy - | T.Adt ((T.Assumed Option | T.Tuple), _) -> () (* Ok *) + | T.Adt (T.Tuple, _) -> () (* Ok *) | T.Adt ( T.Assumed (Slice | T.Array), { @@ -722,70 +722,38 @@ let eval_rvalue_aggregate (config : C.config) fun ctx -> (* Match on the aggregate kind *) match aggregate_kind with - | E.AggregatedTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in - let generics = TypesUtils.mk_generic_args [] tys [] [] in - let ty = T.Adt (T.Tuple, generics) in - let aggregated : V.typed_value = { V.value = v; ty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedOption (variant_id, ty) -> - (* Sanity check *) - if variant_id = T.option_none_id then assert (values = []) - else if variant_id = T.option_some_id then - assert (List.length values = 1) - else raise (Failure "Unreachable"); - (* Construt the value *) - let generics = TypesUtils.mk_generic_args [] [ ty ] [] [] in - let aty = T.Adt (T.Assumed T.Option, generics) in - let av : V.adt_value = - { V.variant_id = Some variant_id; V.field_values = values } - in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedAdt (def_id, opt_variant_id, generics) -> - (* Sanity checks *) - let type_decl = C.ctx_lookup_type_decl ctx def_id in - assert ( - List.length type_decl.generics.regions = List.length generics.regions); - let expected_field_types = - Assoc.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id - generics - in - assert ( - expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } - in - let aty = T.Adt (T.AdtId def_id, generics) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx - | E.AggregatedRange ety -> - (* There should be two fields exactly *) - let v0, v1 = - match values with - | [ v0; v1 ] -> (v0, v1) - | _ -> raise (Failure "Unreachable") - in - (* Ranges are parametric over the type of indices. For now we only - support scalars, which can be of any type *) - assert (literal_type_is_integer (ty_as_literal ety)); - assert (v0.ty = ety); - assert (v1.ty = ety); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = None; V.field_values = values } - in - let generics = TypesUtils.mk_generic_args_from_types [ ety ] in - let aty = T.Adt (T.Assumed T.Range, generics) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in - (* Call the continuation *) - cf aggregated ctx + | E.AggregatedAdt (type_id, opt_variant_id, generics) -> ( + match type_id with + | Tuple -> + let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in + let v = V.Adt { variant_id = None; field_values = values } in + let generics = TypesUtils.mk_generic_args [] tys [] [] in + let ty = T.Adt (T.Tuple, generics) in + let aggregated : V.typed_value = { V.value = v; ty } in + (* Call the continuation *) + cf aggregated ctx + | AdtId def_id -> + (* Sanity checks *) + let type_decl = C.ctx_lookup_type_decl ctx def_id in + assert ( + List.length type_decl.generics.regions + = List.length generics.regions); + let expected_field_types = + Assoc.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id + generics + in + assert ( + expected_field_types + = List.map (fun (v : V.typed_value) -> v.V.ty) values); + (* Construct the value *) + let av : V.adt_value = + { V.variant_id = opt_variant_id; V.field_values = values } + in + let aty = T.Adt (T.AdtId def_id, generics) in + let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + (* Call the continuation *) + cf aggregated ctx + | Assumed _ -> raise (Failure "Unreachable")) | E.AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) assert (List.for_all (fun (v : V.typed_value) -> v.V.ty = ety) values); diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 465d0028..2a277c91 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -96,7 +96,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) | pe :: p' -> ( (* Match on the projection element and the value *) match (pe, v.V.value, v.V.ty) with - | ( Field (((ProjAdt (_, _) | ProjOption _) as proj_kind), field_id), + | ( Field ((ProjAdt (_, _) as proj_kind), field_id), V.Adt adt, T.Adt (type_id, _) ) -> ( (* Check consistency *) @@ -104,8 +104,6 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> assert (def_id = def_id'); assert (opt_variant_id = adt.variant_id) - | ProjOption variant_id, T.Assumed T.Option -> - assert (Some variant_id = adt.variant_id) | _ -> raise (Failure "Unreachable")); (* Actually project *) let fv = T.FieldId.nth adt.field_values field_id in @@ -136,7 +134,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) Ok (ctx, { res with updated }) (* If we reach Bottom, it may mean we need to expand an uninitialized * enumeration value *)) - | Field ((ProjAdt (_, _) | ProjTuple _ | ProjOption _), _), V.Bottom, _ -> + | Field ((ProjAdt (_, _) | ProjTuple _), _), V.Bottom, _ -> Error (FailBottom (1 + List.length p', pe, v.ty)) (* Symbolic value: needs to be expanded *) | _, Symbolic sp, _ -> @@ -376,20 +374,6 @@ let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) let ty = T.Adt (T.AdtId def_id, generics) in { V.value = av; V.ty } -let compute_expanded_bottom_option_value (variant_id : T.VariantId.id) - (param_ty : T.ety) : V.typed_value = - (* Note that the variant can be [Some] or [None]: we expand bottom values - * when writing to fields or setting discriminants *) - let field_values = - if variant_id = T.option_some_id then [ mk_bottom param_ty ] - else if variant_id = T.option_none_id then [] - else raise (Failure "Unreachable") - in - let av = V.Adt { variant_id = Some variant_id; field_values } in - let generics = TypesUtils.mk_generic_args [] [ param_ty ] [] [] in - let ty = T.Adt (T.Assumed T.Option, generics) in - { V.value = av; ty } - let compute_expanded_bottom_tuple_value (field_types : T.ety list) : V.typed_value = (* Generate the field values *) @@ -451,17 +435,6 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) T.Adt (T.AdtId def_id', generics) ) -> assert (def_id = def_id'); compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics - (* Option *) - | ( Field (ProjOption variant_id, _), - T.Adt - ( T.Assumed T.Option, - { - T.regions = []; - types = [ ty ]; - const_generics = []; - trait_refs = []; - } ) ) -> - compute_expanded_bottom_option_value variant_id ty (* Tuples *) | ( Field (ProjTuple arity, _), T.Adt diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index 041b0a97..0ff8063f 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -63,10 +63,6 @@ val compute_expanded_bottom_adt_value : T.egeneric_args -> V.typed_value -(** Compute an expanded [Option] ⊥ value *) -val compute_expanded_bottom_option_value : - T.VariantId.id -> T.ety -> V.typed_value - (** Drop (end) outer loans at a given place, which should be seen as an l-value (we will write to it later, but need to drop the loans before writing). diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 9f35c6f2..2aced79f 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -10,7 +10,6 @@ open TypesUtils open ValuesUtils module Inv = Invariants module S = SynthesizeSymbolic -open Utils open Cps open InterpreterUtils open InterpreterProjectors @@ -233,8 +232,7 @@ let set_discriminant (config : C.config) (p : E.place) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> match (v.V.ty, v.V.value) with - | T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), generics), V.Adt av - -> ( + | T.Adt ((T.AdtId _ as type_id), generics), V.Adt av -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -253,24 +251,15 @@ let set_discriminant (config : C.config) (p : E.place) | T.AdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics - | T.Assumed T.Option -> - assert (generics.regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil generics.types) | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | T.Adt (((T.AdtId _ | T.Assumed T.Option) as type_id), generics), V.Bottom - -> + | T.Adt ((T.AdtId _ as type_id), generics), V.Bottom -> let bottom_v = match type_id with | T.AdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics - | T.Assumed T.Option -> - assert (generics.regions = []); - compute_expanded_bottom_option_value variant_id - (Collections.List.to_cons_nil generics.types) | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx @@ -313,7 +302,7 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) mk_unit_ty | _ -> (* Retrieve the function's signature *) - let sg = Assumed.get_assumed_sig fid in + let sg = Assumed.get_assumed_fun_sig fid in (* Instantiate the return type *) (* There shouldn't be any reference to Self *) let tr_self : T.erased_region T.trait_instance_id = @@ -426,11 +415,6 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = in comp cf_pop cf_assign -(** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_replace_concrete (_config : C.config) (_generics : T.egeneric_args) : - cm_fun = - fun _cf _ctx -> raise Unimplemented - (** Auxiliary function - see {!eval_assumed_function_call} *) let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : cm_fun = @@ -475,67 +459,6 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : comp cf_move cf_create cf ctx | _ -> raise (Failure "Inconsistent state") -(** Auxiliary function which factorizes code to evaluate [std::Deref::deref] - and [std::DerefMut::deref_mut] - see {!eval_assumed_function_call} *) -let eval_box_deref_mut_or_shared_concrete (config : C.config) - (generics : T.egeneric_args) (is_mut : bool) : cm_fun = - fun cf ctx -> - (* Check the arguments *) - match - (generics.regions, generics.types, generics.const_generics, ctx.env) - with - | ( [], - [ boxed_ty ], - [], - Var (VarBinder input_var, input_value) - :: Var (_ret_var, _) - :: C.Frame :: _ ) -> - (* Required type checking. We must have: - - input_value.ty = & (mut) Box - - boxed_ty = ty - for some ty - *) - (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in - assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); - let input_ty = ty_get_box input_ty in - assert (input_ty = boxed_ty)); - - (* Borrow the boxed value *) - let p = - { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } - in - let borrow_kind = if is_mut then E.Mut else E.Shared in - let rv = E.RvRef (p, borrow_kind) in - let cf_borrow = eval_rvalue_not_global config rv in - - (* Move the borrow to its destination *) - let cf_move cf res : m_fun = - match res with - | Error EPanic -> - (* We can't get there by borrowing a value *) - raise (Failure "Unreachable") - | Ok borrowed_value -> - (* Move and continue *) - let destp = mk_place_from_var_id E.VarId.zero in - assign_to_place config borrowed_value destp cf - in - - (* Compose and apply *) - comp cf_borrow cf_move cf ctx - | _ -> raise (Failure "Inconsistent state") - -(** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_deref_concrete (config : C.config) (generics : T.egeneric_args) : - cm_fun = - let is_mut = false in - eval_box_deref_mut_or_shared_concrete config generics is_mut - -(** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_deref_mut_concrete (config : C.config) (generics : T.egeneric_args) - : cm_fun = - let is_mut = true in - eval_box_deref_mut_or_shared_concrete config generics is_mut - (** Auxiliary function - see {!eval_assumed_function_call}. [Box::free] is not handled the same way as the other assumed functions: @@ -575,11 +498,6 @@ let eval_box_free (config : C.config) (generics : T.egeneric_args) cc cf ctx | _ -> raise (Failure "Inconsistent state") -(** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_vec_function_concrete (_config : C.config) (_fid : A.assumed_fun_id) - (_generics : T.egeneric_args) : cm_fun = - fun _cf _ctx -> raise Unimplemented - (** 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 = @@ -636,18 +554,12 @@ let eval_assumed_function_call_concrete (config : C.config) * access to a body. *) let cf_eval_body : cm_fun = match fid with - | 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 | BoxFree -> (* Should have been treated above *) raise (Failure "Unreachable") - | VecNew | VecPush | VecInsert | VecLen | VecIndex | VecIndexMut -> - eval_vec_function_concrete config fid generics | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared - | ArrayToSliceMut | ArraySubsliceShared | ArraySubsliceMut - | ArrayRepeat | SliceIndexShared | SliceIndexMut | SliceSubsliceShared - | SliceSubsliceMut | SliceLen -> + | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut + | SliceLen -> raise (Failure "Unimplemented") in @@ -1531,7 +1443,7 @@ and eval_assumed_function_call_symbolic (config : C.config) (* There shouldn't be any reference to Self *) let tr_self = T.UnknownTrait __FUNCTION__ in instantiate_fun_sig ctx generics tr_self - (Assumed.get_assumed_sig fid) + (Assumed.get_assumed_fun_sig fid) in (* Evaluate the function call *) diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 9ac5ce13..5c8ec7af 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -447,7 +447,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = fields_with_types (* Assumed type case *) | V.Adt av, T.Adt (T.Assumed aty_id, generics) -> ( - assert (av.V.variant_id = None || aty_id = T.Option); + assert (av.V.variant_id = None); match ( aty_id, av.V.field_values, @@ -456,19 +456,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = generics.const_generics ) with (* Box *) - | T.Box, [ inner_value ], [], [ inner_ty ], [] - | T.Option, [ inner_value ], [], [ inner_ty ], [] -> + | T.Box, [ inner_value ], [], [ inner_ty ], [] -> assert (inner_value.V.ty = inner_ty) - | T.Option, _, [], [ _ ], [] -> - (* Option::None: nothing to check *) - () - | T.Vec, fvs, [], [ vec_ty ], [] -> - List.iter - (fun (v : V.typed_value) -> assert (v.ty = vec_ty)) - fvs - | T.Range, [ v0; v1 ], [], [ inner_ty ], [] -> - assert (v0.V.ty = inner_ty); - assert (v1.V.ty = inner_ty) | T.Array, inner_values, _, [ inner_ty ], [ cg ] -> (* *) assert ( diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index a982af30..2553127a 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -5,13 +5,13 @@ let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : fun_sig = match fun_id with | Regular id -> (FunDeclId.Map.find id fun_decls).signature - | Assumed aid -> Assumed.get_assumed_sig aid + | Assumed aid -> Assumed.get_assumed_fun_sig aid let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : Names.fun_name = match fun_id with | Regular id -> (FunDeclId.Map.find id fun_decls).name - | Assumed aid -> Assumed.get_assumed_name aid + | Assumed aid -> Assumed.get_assumed_fun_name aid (** Return the opaque declarations found in the crate. @@ -22,7 +22,7 @@ let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : *) let crate_get_opaque_decls (k : crate) (filter_assumed : bool) : T.type_decl list * fun_decl list = - let open ExtractAssumed in + let open ExtractBuiltin in let is_opaque_fun (d : fun_decl) : bool = let sname = name_to_simple_name d.name in d.body = None @@ -30,7 +30,7 @@ let crate_get_opaque_decls (k : crate) (filter_assumed : bool) : (which don't have a body but must not be considered as opaque) *) && (match d.kind with TraitMethodDecl _ -> false | _ -> true) && ((not filter_assumed) - || not (SimpleNameMap.mem sname assumed_globals_map)) + || not (SimpleNameMap.mem sname builtin_globals_map)) in let is_opaque_type (d : T.type_decl) : bool = d.kind = T.Opaque in (* Note that by checking the function bodies we also the globals *) diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 1058fab0..ee06fa07 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -108,7 +108,7 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = | Assign (_, rv) -> ( match rv with | Use _ | RvRef _ -> not must_end_with_exit - | Aggregate (AggregatedTuple, []) -> not must_end_with_exit + | Aggregate (AggregatedAdt (Tuple, _, _), []) -> not must_end_with_exit | _ -> false) | FakeRead _ | Drop _ | Nop -> not must_end_with_exit | Panic | Return -> true diff --git a/compiler/Print.ml b/compiler/Print.ml index 1d5ddc50..aeacfbf0 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -127,17 +127,6 @@ module Values = struct (* Assumed type *) match (aty, field_values) with | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | Option, _ -> - if av.variant_id = Some T.option_some_id then - "@Option::Some(" - ^ Collections.List.to_cons_nil field_values - ^ ")" - else if av.variant_id = Some T.option_none_id then ( - assert (field_values = []); - "@Option::None") - else raise (Failure "Unreachable") - | Range, _ -> "@Range{ " ^ String.concat ", " field_values ^ "}" - | Vec, _ -> "@Vec[" ^ String.concat ", " field_values ^ "]" | Array, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index be7b3cb4..6396fe96 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -195,12 +195,9 @@ let assumed_ty_to_string (aty : assumed_ty) : string = | Result -> "Result" | Error -> "Error" | Fuel -> "Fuel" - | Option -> "Option" - | Vec -> "Vec" | Array -> "Array" | Slice -> "Slice" | Str -> "Str" - | Range -> "Range" let type_id_to_string (fmt : type_formatter) (id : type_id) : string = match id with @@ -354,10 +351,6 @@ let rec mprojection_to_string (fmt : ast_formatter) (inside : string) | pe :: p' -> ( let s = mprojection_to_string fmt inside p' in match pe.pkind with - | E.ProjOption variant_id -> - assert (variant_id = T.option_some_id); - assert (pe.field_id = T.FieldId.zero); - "(" ^ s ^ "as Option::Some)." ^ T.FieldId.to_string pe.field_id | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id | E.ProjAdt (adt_id, opt_variant_id) -> ( let field_name = @@ -395,8 +388,6 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) | State | Array | Slice | Str -> (* Those types are opaque: we can't get there *) raise (Failure "Unreachable") - | Vec -> "@Vec" - | Range -> "@Range" | Result -> let variant_id = Option.get variant_id in if variant_id = result_return_id then "@Result::Return" @@ -412,13 +403,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) 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 raise (Failure "Unreachable: improper variant id for fuel type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then "@Option::Some " - else if variant_id = option_none_id then "@Option::None" - else - raise (Failure "Unreachable: improper variant id for result type")) + else raise (Failure "Unreachable: improper variant id for fuel type")) let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (field_id : FieldId.id) : string = @@ -435,11 +420,10 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) | Assumed aty -> ( (* Assumed type *) match aty with - | Range -> FieldId.to_string field_id - | State | Fuel | Vec | Array | Slice | Str -> + | State | Fuel | Array | Slice | Str -> (* Opaque types: we can't get there *) raise (Failure "Unreachable") - | Result | Error | Option -> + | Result | Error -> (* Enumerations: we can't get there *) raise (Failure "Unreachable")) @@ -510,31 +494,13 @@ let adt_g_value_to_string (fmt : value_formatter) | [ v ] -> "@Fuel::Succ " ^ v | _ -> raise (Failure "@Fuel::Succ takes exactly one value") else raise (Failure "Unreachable: improper variant id for fuel type") - | Option -> - let variant_id = Option.get variant_id in - if variant_id = option_some_id then - match field_values with - | [ v ] -> "@Option::Some " ^ v - | _ -> raise (Failure "Option::Some takes exactly one value") - else if variant_id = option_none_id then ( - assert (field_values = []); - "@Option::None") - else - raise (Failure "Unreachable: improper variant id for result type") - | Vec | Array | Slice | Str -> - assert (variant_id = None); - let field_values = - List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values - in - let id = assumed_ty_to_string aty in - id ^ " [" ^ String.concat "; " field_values ^ "]" - | Range -> + | Array | Slice | Str -> assert (variant_id = None); let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values in let id = assumed_ty_to_string aty in - id ^ " {" ^ String.concat "; " field_values ^ "}") + id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> let fmt = value_to_type_formatter fmt in raise @@ -593,29 +559,16 @@ 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 - | 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" | ArrayToSliceMut -> "@ArrayToSliceMut" - | ArraySubsliceShared -> "@ArraySubsliceShared" - | ArraySubsliceMut -> "@ArraySubsliceMut" | ArrayRepeat -> "@ArrayRepeat" | SliceLen -> "@SliceLen" | SliceIndexShared -> "@SliceIndexShared" | SliceIndexMut -> "@SliceIndexMut" - | SliceSubsliceShared -> "@SliceSubsliceShared" - | SliceSubsliceMut -> "@SliceSubsliceMut" let pure_assumed_fun_id_to_string (fid : pure_assumed_fun_id) : string = match fid with diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 47c7beb4..81e13af7 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -64,17 +64,7 @@ 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 - | Vec - | Option - | Array - | Slice - | Str - | Range +type assumed_ty = State | Result | Error | Fuel | Array | Slice | Str [@@deriving show, ord] (* TODO: we should never directly manipulate [Return] and [Fail], but rather diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index b00509a6..a326d19e 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1513,7 +1513,7 @@ let unit_vars_to_unit (def : fun_decl) : fun_decl = function calls, and when translating end abstractions. Here, we can do something simpler, in one micro-pass. *) -let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = +let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = (* The map visitor *) let obj = object @@ -1522,30 +1522,42 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = method! visit_texpression env e = match opt_destruct_function_call e with | Some (fun_id, _tys, args) -> ( + (* 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 fun_id with | 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 | BoxNew, _ -> assert (rg_id = None); let arg, args = Collections.List.pop args in mk_apps arg args - | BoxDeref, None -> + | BoxFree, _ -> + assert (args = []); + mk_unit_rvalue + | ( ( SliceIndexShared | SliceIndexMut | ArrayIndexShared + | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut + | ArrayRepeat | SliceLen ), + _ ) -> + super#visit_texpression env e) + | Fun (FromLlbc (FunId (Regular fid), _lp_id, rg_id)) -> ( + (* Lookup the function name *) + let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in + match (Names.name_to_string def.name, rg_id) with + | "alloc::box::Boxed::deref", None -> (* [Box::deref] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | BoxDeref, Some _ -> + | "alloc::box::Boxed::deref", Some _ -> (* [Box::deref] backward is [()] (doesn't give back anything) *) assert (args = []); mk_unit_rvalue - | BoxDerefMut, None -> + | "alloc::box::Boxed::deref_mut", None -> (* [Box::deref_mut] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | BoxDerefMut, Some _ -> + | "alloc::box::Boxed::deref_mut", Some _ -> (* [Box::deref_mut] back is almost the identity: * let box_deref_mut (x_init : t) (x_back : t) : t = x_back * *) @@ -1555,17 +1567,7 @@ let eliminate_box_functions (_ctx : trans_ctx) (def : fun_decl) : fun_decl = | _ -> raise (Failure "Unreachable") in mk_apps arg args - | BoxFree, _ -> - assert (args = []); - mk_unit_rvalue - | ( ( 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) | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e end diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index b80ff72f..d31f0cf9 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -46,18 +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") - | Option -> - let ty = Collections.List.to_cons_nil generics.types in - let variant_id = Option.get variant_id in - if variant_id = option_some_id then [ ty ] - else if variant_id = option_none_id then [] - else - raise (Failure "Unreachable: improper variant id for option type") - | Range -> - let ty = Collections.List.to_cons_nil generics.types in - assert (variant_id = None); - [ ty; ty ] - | Vec | Array | Slice | Str -> + | Array | Slice | Str -> (* 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/Substitute.ml b/compiler/Substitute.ml index b1680282..6d9b9e15 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -305,19 +305,7 @@ let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) generics.types | T.Assumed aty -> ( match aty with - | T.Box | T.Vec -> - assert (generics.regions = []); - assert (List.length generics.types = 1); - assert (generics.const_generics = []); - generics.types - | T.Option -> - assert (generics.regions = []); - assert (List.length generics.types = 1); - assert (generics.const_generics = []); - if adt.V.variant_id = Some T.option_some_id then generics.types - else if adt.V.variant_id = Some T.option_none_id then [] - else raise (Failure "Unreachable") - | T.Range -> + | T.Box -> assert (generics.regions = []); assert (List.length generics.types = 1); assert (generics.const_generics = []); diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 54221cb1..9c698b51 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -405,8 +405,6 @@ let rec translate_sty (ty : T.sty) : ty = mk_simpl_tuple_ty generics.types | T.Assumed aty -> ( match aty with - | T.Vec -> Adt (Assumed Vec, generics) - | T.Option -> Adt (Assumed Option, generics) | T.Box -> ( (* Eliminate the boxes *) match generics.types with @@ -418,8 +416,7 @@ let rec translate_sty (ty : T.sty) : ty = ) | T.Array -> Adt (Assumed Array, generics) | T.Slice -> Adt (Assumed Slice, generics) - | T.Str -> Adt (Assumed Str, generics) - | T.Range -> Adt (Assumed Range, generics))) + | T.Str -> Adt (Assumed Str, generics))) | TypeVar vid -> TypeVar vid | Literal ty -> Literal ty | Never -> raise (Failure "Unreachable") @@ -510,12 +507,9 @@ let translate_type_id (id : T.type_id) : type_id = | T.Assumed aty -> let aty = match aty with - | T.Vec -> Vec - | T.Option -> Option | T.Array -> Array | T.Slice -> Slice | T.Str -> Str - | T.Range -> Range | T.Box -> (* Boxes have to be eliminated: this type id shouldn't be translated *) @@ -534,8 +528,7 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = let t_generics = translate_fwd_generic_args type_infos generics in (* Eliminate boxes and simplify tuples *) match type_id with - | AdtId _ - | T.Assumed (T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> + | AdtId _ | T.Assumed (T.Array | T.Slice | T.Str) -> (* No general parametricity for now *) assert ( not @@ -610,8 +603,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) match ty with | T.Adt (type_id, generics) -> ( match type_id with - | T.AdtId _ - | Assumed (T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> + | T.AdtId _ | Assumed (T.Array | T.Slice | T.Str) -> (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); let type_id = translate_type_id type_id in @@ -815,7 +807,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) | FunId (Assumed aid) -> assert (lid = None); { - can_fail = Assumed.assumed_can_fail aid; + can_fail = Assumed.assumed_fun_can_fail aid; stateful_group = false; stateful = false; can_diverge = false; @@ -1221,9 +1213,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (* For now, only tuples can contain borrows *) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ - | T.Assumed - (T.Box | T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> + | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> assert (field_values = []); None | T.Tuple -> @@ -1368,9 +1358,7 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) * vector value upon visiting the "abstraction borrow" node *) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ - | T.Assumed - (T.Box | T.Vec | T.Option | T.Array | T.Slice | T.Str | T.Range) -> + | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> assert (field_values = []); (ctx, None) | T.Tuple -> @@ -2441,17 +2429,12 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_typed_pattern_from_var var None) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.Assumed (T.Vec | T.Array | T.Slice | T.Str) -> + | T.Assumed (T.Array | T.Slice | T.Str) -> (* We can't expand those values: we can access the fields only * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number * of fields!) *) raise (Failure "Attempt to expand a non-expandable value") - | T.Assumed Range -> raise (Failure "Unimplemented") - | T.Assumed T.Option -> - (* We shouldn't get there in the "one-branch" case: options have - * two variants *) - raise (Failure "Unreachable") and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 8e01c869..15297770 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -297,9 +297,11 @@ let translate_crate_to_pure (crate : A.crate) : (* Translate all the function *signatures* *) let assumed_sigs = List.map - (fun (id, sg, _, _) -> - (E.Assumed id, List.map (fun _ -> None) (sg : A.fun_sig).inputs, sg)) - Assumed.assumed_infos + (fun (info : Assumed.assumed_fun_info) -> + ( E.Assumed info.fun_id, + List.map (fun _ -> None) info.fun_sig.inputs, + info.fun_sig )) + Assumed.assumed_fun_infos in let local_sigs = List.map @@ -425,11 +427,15 @@ let export_type (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (true, kind) in (* Extract, if the config instructs to do so (depending on whether the type - * is opaque or not) *) - if + is opaque or not). Remark: we don't check if the definitions are builtin + here but in the function [export_types_group]: the reason is that if one + definition in the group is builtin, then we must check that all the + definitions are marked builtin *) + let extract = (is_opaque && config.extract_opaque) || ((not is_opaque) && config.extract_transparent) - then ( + in + if extract then ( if extract_decl then Extract.extract_type_decl ctx fmt type_decl_group kind def; if extract_extra_info then @@ -464,41 +470,58 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) List.map (fun id -> Pure.TypeDeclId.Map.find id ctx.trans_types) ids in - (* Extract the type declarations. - - Because some declaration groups are delimited, we wrap the declarations - between [{start,end}_type_decl_group]. + (* Check if the definition are builtin - if yes they must be ignored. + Note that if one definition in the group is builtin, then all the + definitions must be builtin *) + let builtin = + let open ExtractBuiltin in + let types_map = builtin_types_map () in + List.map + (fun (def : Pure.type_decl) -> + let sname = name_to_simple_name def.name in + SimpleNameMap.find_opt sname types_map <> None) + defs + in - Ex.: - ==== - When targeting HOL4, the calls to [{start,end}_type_decl_group] would generate - the [Datatype] and [End] delimiters in the snippet of code below: + if List.exists (fun b -> b) builtin then + (* Sanity check *) + assert (List.for_all (fun b -> b) builtin) + else ( + (* Extract the type declarations. + + Because some declaration groups are delimited, we wrap the declarations + between [{start,end}_type_decl_group]. + + Ex.: + ==== + When targeting HOL4, the calls to [{start,end}_type_decl_group] would generate + the [Datatype] and [End] delimiters in the snippet of code below: + + {[ + Datatype: + tree = + TLeaf 'a + | TNode node ; + + node = + Node (tree list) + End + ]} + *) + Extract.start_type_decl_group ctx fmt is_rec defs; + List.iteri + (fun i def -> + let kind = kind_from_index i in + export_type_decl kind def) + defs; + Extract.end_type_decl_group fmt is_rec defs; - {[ - Datatype: - tree = - TLeaf 'a - | TNode node ; - - node = - Node (tree list) - End - ]} - *) - Extract.start_type_decl_group ctx fmt is_rec defs; - List.iteri - (fun i def -> - let kind = kind_from_index i in - export_type_decl kind def) - defs; - Extract.end_type_decl_group fmt is_rec defs; - - (* Export the extra information (ex.: [Arguments] instructions in Coq) *) - List.iteri - (fun i def -> - let kind = kind_from_index i in - export_type_extra_info kind def) - defs + (* Export the extra information (ex.: [Arguments] instructions in Coq) *) + List.iteri + (fun i def -> + let kind = kind_from_index i in + export_type_extra_info kind def) + defs) (** Export a global declaration. @@ -520,12 +543,12 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) && (((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque)) in - (* Check if it is an assumed global - if yes, we ignore it because we + (* Check if it is a builtin global - if yes, we ignore it because we map the definition to one in the standard library *) - let open ExtractAssumed in + let open ExtractBuiltin in let sname = name_to_simple_name global.name in let extract = - extract && SimpleNameMap.find_opt sname assumed_globals_map = None + extract && SimpleNameMap.find_opt sname builtin_globals_map = None in if extract then (* We don't wrap global declaration groups between calls to functions diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 4a187893..16f8c5f9 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -168,9 +168,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) in (* Continue exploring *) analyze expl_info ty_info rty - | Adt - ( (Tuple | Assumed (Box | Vec | Option | Slice | Array | Str | Range)), - generics ) -> + | Adt ((Tuple | Assumed (Box | Slice | Array | Str)), generics) -> (* Nothing to update: just explore the type parameters *) List.fold_left (fun ty_info ty -> analyze expl_info ty_info ty) diff --git a/compiler/dune b/compiler/dune index 2f5a0a44..4ec46b70 100644 --- a/compiler/dune +++ b/compiler/dune @@ -22,8 +22,8 @@ Expressions ExpressionsUtils Extract - ExtractAssumed ExtractBase + ExtractBuiltin FunsAnalysis Identifiers InterpreterBorrowsCore -- cgit v1.2.3 From c486bd0675f489c5ac917749a68e2c71b55041ae Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 23 Oct 2023 17:29:15 +0200 Subject: Make progress on handling the builtins --- compiler/Extract.ml | 254 +++++++++++++++++++++++++++++++++++++-------- compiler/ExtractBase.ml | 68 ------------ compiler/ExtractBuiltin.ml | 93 +++++++++-------- compiler/Translate.ml | 9 +- 4 files changed, 270 insertions(+), 154 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 30c4c27d..6a306592 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -4062,64 +4062,234 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break to insert lines between declarations *) F.pp_print_break fmt 0 0 -(** Register the names for one trait method item *) -let extract_trait_decl_method_register_names (ctx : extraction_ctx) - (trait_decl : trait_decl) (name : string) (id : fun_decl_id) : +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : extraction_ctx = - (* We add one field per required forward/backward function *) - let trans = A.FunDeclId.Map.find id ctx.trans_funs in - - let register_fun ctx f = ctx_add_trait_method trait_decl name f.f ctx in + let is_opaque = false in + let generics = trait_decl.generics in + (* Compute the clause names *) + let clause_names = + match builtin_info with + | None -> + List.map + (fun (c : trait_clause) -> + let name = ctx.fmt.trait_parent_clause_name trait_decl c in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ name + in + (c.clause_id, name)) + generics.trait_clauses + | Some info -> + List.map + (fun (c, name) -> (c.clause_id, name)) + (List.combine generics.trait_clauses info.parent_clauses) + in + (* Register the names *) + List.fold_left + (fun ctx (cid, cname) -> + ctx_add is_opaque (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) + ctx clause_names + +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_register_constant_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + let is_opaque = false in + let consts = trait_decl.consts in + (* Compute the names *) + let constant_names = + match builtin_info with + | None -> + List.map + (fun (item_name, _) -> + let name = ctx.fmt.trait_const_name trait_decl item_name in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ name + in + (item_name, name)) + consts + | Some info -> + let const_map = StringMap.of_list info.consts in + List.map + (fun (item_name, _) -> + (item_name, StringMap.find item_name const_map)) + consts + in (* Register the names *) - let funs = trans.fwd :: trans.backs in - List.fold_left register_fun ctx funs + List.fold_left + (fun ctx (item_name, name) -> + ctx_add is_opaque (TraitItemId (trait_decl.def_id, item_name)) name ctx) + ctx constant_names + +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_type_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + let is_opaque = false in + let types = trait_decl.types in + (* Compute the names *) + let type_names = + match builtin_info with + | None -> + let compute_type_name (item_name : string) : string = + let type_name = ctx.fmt.trait_type_name trait_decl item_name in + if !Config.record_fields_short_names then type_name + else ctx.fmt.trait_decl_name trait_decl ^ type_name + in + let compute_clause_name (item_name : string) (clause : trait_clause) : + TraitClauseId.id * string = + let name = + ctx.fmt.trait_type_clause_name trait_decl item_name clause + in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ name + in + (clause.clause_id, name) + in + List.map + (fun (item_name, (item_clauses, _)) -> + (* Type name *) + let type_name = compute_type_name item_name in + (* Clause names *) + let clauses = + List.map (compute_clause_name item_name) item_clauses + in + (item_name, (type_name, clauses))) + types + | Some info -> + let type_map = StringMap.of_list info.types in + List.map + (fun (item_name, (item_clauses, _)) -> + let type_name, clauses_info = StringMap.find item_name type_map in + let clauses = + List.map + (fun (clause, clause_name) -> (clause.clause_id, clause_name)) + (List.combine item_clauses clauses_info) + in + (item_name, (type_name, clauses))) + types + in + (* Register the names *) + List.fold_left + (fun ctx (item_name, (type_name, clauses)) -> + let ctx = + ctx_add is_opaque + (TraitItemId (trait_decl.def_id, item_name)) + type_name ctx + in + List.fold_left + (fun ctx (clause_id, clause_name) -> + ctx_add is_opaque + (TraitItemClauseId (trait_decl.def_id, item_name, clause_id)) + clause_name ctx) + ctx clauses) + ctx type_names + +(** Similar to {!extract_trait_decl_register_names} *) +let extract_trait_decl_method_names (ctx : extraction_ctx) + (trait_decl : trait_decl) + (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : + extraction_ctx = + let is_opaque = false in + let required_methods = trait_decl.required_methods in + (* Compute the names *) + let method_names = + (* We add one field per required forward/backward function *) + let get_funs_for_id (id : fun_decl_id) : fun_decl list = + let trans : pure_fun_translation = FunDeclId.Map.find id ctx.trans_funs in + List.map (fun f -> f.f) (trans.fwd :: trans.backs) + in + match builtin_info with + | None -> + (* We add one field per required forward/backward function *) + let compute_item_names (item_name : string) (id : fun_decl_id) : + string * (RegionGroupId.id option * string) list = + let compute_fun_name (f : fun_decl) : RegionGroupId.id option * string + = + (* We do something special: we use the base name but remove everything + but the crate (because [get_name] removes it) and the last ident. + This allows us to reuse the [ctx_compute_fun_decl] function. + *) + let basename : name = + match (f.basename : name) with + | Ident crate :: name -> + Ident crate :: [ Collections.List.last name ] + | _ -> raise (Failure "Unexpected") + in + let f = { f with basename } in + let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in + let name = ctx_compute_fun_name trans f ctx in + (* Add a prefix if necessary *) + let name = + if !Config.record_fields_short_names then name + else ctx.fmt.trait_decl_name trait_decl ^ "_" ^ name + in + (f.back_id, name) + in + let funs = get_funs_for_id id in + (item_name, List.map compute_fun_name funs) + in + List.map (fun (name, id) -> compute_item_names name id) required_methods + | Some info -> + let funs_map = StringMap.of_list info.funs in + List.map + (fun (item_name, fun_id) -> + let info = StringMap.find item_name funs_map in + let trans_funs = get_funs_for_id fun_id in + let rg_with_name_list = + List.map + (fun (trans_fun : fun_decl) -> + List.find (fun (rg, _) -> rg = trans_fun.back_id) info) + trans_funs + in + (item_name, rg_with_name_list)) + required_methods + in + (* Register the names *) + List.fold_left + (fun ctx (item_name, funs) -> + (* We add one field per required forward/backward function *) + List.fold_left + (fun ctx (rg, fun_name) -> + ctx_add is_opaque + (TraitMethodId (trait_decl.def_id, item_name, rg)) + fun_name ctx) + ctx funs) + ctx method_names (** Similar to {!extract_type_decl_register_names} *) let extract_trait_decl_register_names (ctx : extraction_ctx) (trait_decl : trait_decl) : extraction_ctx = - let { - def_id = _; - name = _; - generics; - preds = _; - all_trait_clauses = _; - consts; - types; - required_methods; - provided_methods = _; - } = - trait_decl + (* Lookup the information if this is a builtin trait *) + let open ExtractBuiltin in + let sname = name_to_simple_name trait_decl.name in + let builtin_info = + SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) in let ctx = ctx_add_trait_decl trait_decl ctx in (* Parent clauses *) let ctx = - List.fold_left - (fun ctx clause -> ctx_add_trait_parent_clause trait_decl clause ctx) - ctx generics.trait_clauses + extract_trait_decl_register_parent_clause_names ctx trait_decl builtin_info in (* Constants *) let ctx = - List.fold_left - (fun ctx (name, (_, _)) -> ctx_add_trait_const trait_decl name ctx) - ctx consts + extract_trait_decl_register_constant_names ctx trait_decl builtin_info in (* Types *) - let ctx = - List.fold_left - (fun ctx (name, (clauses, _)) -> - let ctx = ctx_add_trait_type trait_decl name ctx in - List.fold_left - (fun ctx clause -> - ctx_add_trait_type_clause trait_decl name clause ctx) - ctx clauses) - ctx types - in + let ctx = extract_trait_decl_type_names ctx trait_decl builtin_info in (* Required methods *) - List.fold_left - (fun ctx (name, id) -> - (* We add one field per required forward/backward function *) - extract_trait_decl_method_register_names ctx trait_decl name id) - ctx required_methods + let ctx = extract_trait_decl_method_names ctx trait_decl builtin_info in + ctx (** Similar to {!extract_type_decl_register_names} *) let extract_trait_impl_register_names (ctx : extraction_ctx) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 54f69735..ea5fe8d3 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1288,74 +1288,6 @@ let ctx_add_trait_impl (d : trait_impl) (ctx : extraction_ctx) : extraction_ctx let name = ctx.fmt.trait_impl_name decl d in ctx_add is_opaque (TraitImplId d.def_id) name ctx -let ctx_add_trait_const (d : trait_decl) (item : string) (ctx : extraction_ctx) - : extraction_ctx = - let is_opaque = false in - let name = ctx.fmt.trait_const_name d item in - (* Add a prefix if necessary *) - let name = - if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name d ^ name - in - ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx - -let ctx_add_trait_type (d : trait_decl) (item : string) (ctx : extraction_ctx) : - extraction_ctx = - let is_opaque = false in - let name = ctx.fmt.trait_type_name d item in - (* Add a prefix if necessary *) - let name = - if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name d ^ name - in - ctx_add is_opaque (TraitItemId (d.def_id, item)) name ctx - -let ctx_add_trait_method (d : trait_decl) (item_name : string) (f : fun_decl) - (ctx : extraction_ctx) : extraction_ctx = - (* We do something special: we use the base name but remove everything - but the crate (because [get_name] removes it) and the last ident. - This allows us to reuse the [ctx_compute_fun_decl] function. - *) - let basename : name = - match (f.basename : name) with - | Ident crate :: name -> Ident crate :: [ Collections.List.last name ] - | _ -> raise (Failure "Unexpected") - in - let f = { f with basename } in - let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in - let name = ctx_compute_fun_name trans f ctx in - (* Add a prefix if necessary *) - let name = - if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name d ^ "_" ^ name - in - let is_opaque = false in - ctx_add is_opaque (TraitMethodId (d.def_id, item_name, f.back_id)) name ctx - -let ctx_add_trait_parent_clause (d : trait_decl) (clause : trait_clause) - (ctx : extraction_ctx) : extraction_ctx = - let is_opaque = false in - let name = ctx.fmt.trait_parent_clause_name d clause in - (* Add a prefix if necessary *) - let name = - if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name d ^ name - in - ctx_add is_opaque (TraitParentClauseId (d.def_id, clause.clause_id)) name ctx - -let ctx_add_trait_type_clause (d : trait_decl) (item : string) - (clause : trait_clause) (ctx : extraction_ctx) : extraction_ctx = - let is_opaque = false in - let name = ctx.fmt.trait_type_clause_name d item clause in - (* Add a prefix if necessary *) - let name = - if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name d ^ name - in - ctx_add is_opaque - (TraitItemClauseId (d.def_id, item, clause.clause_id)) - name ctx - type names_map_init = { keywords : string list; assumed_adts : (assumed_ty * string) list; diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index cf5cc70d..3b4afff6 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -1,5 +1,8 @@ (** This file declares external identifiers that we catch to map them to - definitions coming from the standard libraries in our backends. *) + definitions coming from the standard libraries in our backends. + + TODO: there misses trait **implementations** + *) open Names open Config @@ -331,20 +334,20 @@ let mk_builtin_funs_map () = let builtin_funs_map () = mk_memoized mk_builtin_funs_map -type builtin_trait_info = { +type builtin_trait_decl_info = { rust_name : string; extract_name : string; parent_clauses : string list; consts : (string * string) list; - types : (string * string * string list) list; + types : (string * (string * string list)) list; (** Every type has: - a Rust name - an extraction name - a list of clauses *) - funs : (string * Types.RegionGroupId.id option * string) list; + funs : (string * (Types.RegionGroupId.id option * string) list) list; } -let builtin_traits () = +let builtin_trait_decls_info () = let rg0 = Some Types.RegionGroupId.zero in [ { @@ -359,18 +362,20 @@ let builtin_traits () = types = [ ( "Target", - (match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_Deref_Target" - | Lean -> "Target"), - [] ); + ( (match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_Deref_Target" + | Lean -> "Target"), + [] ) ); ]; funs = [ ( "deref", - None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_Deref_deref" - | Lean -> "deref" ); + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_Deref_deref" + | Lean -> "deref" ); + ] ); ]; }; { @@ -391,15 +396,16 @@ let builtin_traits () = funs = [ ( "deref_mut", - None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut" - | Lean -> "deref_mut" ); - ( "deref_mut", - rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut_back" - | Lean -> "deref_mut_back" ); + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut" + | Lean -> "deref_mut" ); + ( rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut_back" + | Lean -> "deref_mut_back" ); + ] ); ]; }; { @@ -414,18 +420,20 @@ let builtin_traits () = types = [ ( "Output", - (match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_Index_Output" - | Lean -> "Output"), - [] ); + ( (match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_Index_Output" + | Lean -> "Output"), + [] ) ); ]; funs = [ ( "index", - None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_Index_index" - | Lean -> "index" ); + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_Index_index" + | Lean -> "index" ); + ] ); ]; }; { @@ -446,23 +454,24 @@ let builtin_traits () = funs = [ ( "index_mut", - None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut" - | Lean -> "index_mut" ); - ( "index_mut", - rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut_back" - | Lean -> "index_mut_back" ); + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut" + | Lean -> "index_mut" ); + ( rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut_back" + | Lean -> "index_mut_back" ); + ] ); ]; }; ] -let mk_builtin_traits_map () = +let mk_builtin_trait_decls_map () = SimpleNameMap.of_list (List.map (fun info -> (string_to_simple_name info.rust_name, info)) - (builtin_traits ())) + (builtin_trait_decls_info ())) -let builtin_traits_map () = mk_memoized mk_builtin_traits_map +let builtin_trait_decls_map = mk_memoized mk_builtin_trait_decls_map diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 15297770..0871a305 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -731,8 +731,13 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) let export_trait_decl (fmt : Format.formatter) (_config : gen_config) (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) : unit = let trait_decl = T.TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls in - let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in - Extract.extract_trait_decl ctx fmt trait_decl + (* Check if the trait declaration is builtin, in which case we ignore it *) + let open ExtractBuiltin in + let sname = name_to_simple_name trait_decl.name in + if SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) = None then + let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in + Extract.extract_trait_decl ctx fmt trait_decl + else () (** Export a trait implementation. *) let export_trait_impl (fmt : Format.formatter) (_config : gen_config) -- cgit v1.2.3 From dc18bb9eed7615bd2fcfa240011f2e41eea4b874 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 11:15:46 +0200 Subject: Add some debugging information --- compiler/InterpreterStatements.ml | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'compiler') diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 2aced79f..e0c4703b 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1108,6 +1108,13 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) match call.func.func with | FunId (Regular fid) -> let def = C.ctx_lookup_fun_decl ctx fid in + log#ldebug + (lazy + ("fun call:\n- call: " ^ call_to_string ctx call + ^ "\n- call.generics:\n" + ^ egeneric_args_to_string ctx call.func.generics + ^ "\n- def.signature:\n" + ^ fun_sig_to_string ctx def.A.signature)); let tr_self = T.UnknownTrait __FUNCTION__ in let inst_sg = instantiate_fun_sig ctx call.func.generics tr_self def.A.signature -- cgit v1.2.3 From 63107911c16a9991f7d5cf8c6df621318a03ca3b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 14:32:38 +0200 Subject: Fix various issues with the builtins --- compiler/Extract.ml | 115 +++++++++++++++++++++++---------- compiler/ExtractBase.ml | 1 + compiler/ExtractBuiltin.ml | 82 +++++++++++++++++------ compiler/Translate.ml | 158 ++++++++++++++++++++++++++------------------- 4 files changed, 234 insertions(+), 122 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 6a306592..ddc02fa7 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1277,7 +1277,10 @@ and extract_trait_decl_ref (ctx : extraction_ctx) (fmt : F.formatter) let name = ctx_get_trait_decl is_opaque tr.trait_decl_id ctx in if use_brackets then F.pp_print_string fmt "("; F.pp_print_string fmt name; - extract_generic_args ctx fmt no_params_tys tr.decl_generics; + (* There is something subtle here: the trait obligations for the implemented + trait are put inside the parent clauses, so we must ignore them here *) + let generics = { tr.decl_generics with trait_refs = [] } in + extract_generic_args ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")" and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) @@ -1349,7 +1352,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let def_name = match info with | None -> ctx.fmt.type_name def.name - | Some info -> info.rust_name + | Some info -> String.concat "." info.rust_name in let is_opaque = def.kind = Opaque in let ctx = ctx_add is_opaque (TypeId (AdtId def.def_id)) def_name ctx in @@ -1363,7 +1366,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (* Compute the names *) let field_names, cons_name = match info with - | None -> + | None | Some { body_info = None; _ } -> let field_names = FieldId.mapi (fun fid (field : field) -> @@ -1379,7 +1382,11 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (List.combine fields field_names) in (field_names, cons_name) - | _ -> raise (Failure "Invalid builtin information") + | Some info -> + raise + (Failure + ("Invalid builtin information: " + ^ show_builtin_type_info info)) in (* Add the fields *) let ctx = @@ -2365,33 +2372,70 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) let extract_fun_decl_register_names (ctx : extraction_ctx) (has_decreases_clause : fun_decl -> bool) (def : pure_fun_translation) : extraction_ctx = - let fwd = def.fwd in - let backs = def.backs in - (* Register the decrease clauses, if necessary *) - let register_decreases ctx def = - if has_decreases_clause def then - (* Add the termination measure *) - let ctx = ctx_add_termination_measure def ctx in - (* Add the decreases proof for Lean only *) - match !Config.backend with - | Coq | FStar -> ctx - | HOL4 -> raise (Failure "Unexpected") - | Lean -> ctx_add_decreases_proof def ctx - else ctx - in - let ctx = List.fold_left register_decreases ctx (fwd.f :: fwd.loops) in - let register_fun ctx f = ctx_add_fun_decl def f ctx in - let register_funs ctx fl = List.fold_left register_fun ctx fl in - (* Register the names of the forward functions *) - let ctx = - if def.keep_fwd then register_funs ctx (fwd.f :: fwd.loops) else ctx - in - (* Register the names of the backward functions *) - List.fold_left - (fun ctx { f = back; loops = loop_backs } -> - let ctx = register_fun ctx back in - register_funs ctx loop_backs) - ctx backs + (* Ignore the trait methods **declarations** (rem.: we do not ignore the trait + method implementations): we do not need to refer to them directly. We will + only use their type for the fields of the records we generate for the trait + declarations *) + match def.fwd.f.kind with + | TraitMethodDecl _ -> ctx + | _ -> ( + (* Check if the function is builtin *) + let builtin = + let open ExtractBuiltin in + let funs_map = builtin_funs_map () in + let sname = name_to_simple_name def.fwd.f.basename in + SimpleNameMap.find_opt sname funs_map + in + (* Use the builtin names if necessary *) + match builtin with + | Some (_filter, info) -> + let backs = List.map (fun f -> f.f) def.backs in + let funs = if def.keep_fwd then def.fwd.f :: backs else backs in + let is_opaque = false in + List.fold_left + (fun ctx (f : fun_decl) -> + let open ExtractBuiltin in + let fun_id = + (Pure.FunId (Regular f.def_id), f.loop_id, f.back_id) + in + let fun_name = + (List.find + (fun (x : builtin_fun_info) -> x.rg = f.back_id) + info) + .extract_name + in + ctx_add is_opaque (FunId (FromLlbc fun_id)) fun_name ctx) + ctx funs + | None -> + let fwd = def.fwd in + let backs = def.backs in + (* Register the decrease clauses, if necessary *) + let register_decreases ctx def = + if has_decreases_clause def then + (* Add the termination measure *) + let ctx = ctx_add_termination_measure def ctx in + (* Add the decreases proof for Lean only *) + match !Config.backend with + | Coq | FStar -> ctx + | HOL4 -> raise (Failure "Unexpected") + | Lean -> ctx_add_decreases_proof def ctx + else ctx + in + let ctx = + List.fold_left register_decreases ctx (fwd.f :: fwd.loops) + in + let register_fun ctx f = ctx_add_fun_decl def f ctx in + let register_funs ctx fl = List.fold_left register_fun ctx fl in + (* Register the names of the forward functions *) + let ctx = + if def.keep_fwd then register_funs ctx (fwd.f :: fwd.loops) else ctx + in + (* Register the names of the backward functions *) + List.fold_left + (fun ctx { f = back; loops = loop_backs } -> + let ctx = register_fun ctx back in + register_funs ctx loop_backs) + ctx backs) (** Simply add the global name to the context. *) let extract_global_decl_register_names (ctx : extraction_ctx) @@ -4539,6 +4583,7 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) (** Extract a trait implementation *) let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (impl : trait_impl) : unit = + log#ldebug (lazy ("extract_trait_impl: " ^ Names.name_to_string impl.name)); (* Retrieve the impl name *) let with_opaque_pre = false in let impl_name = ctx_get_trait_impl with_opaque_pre impl.def_id ctx in @@ -4565,9 +4610,11 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* `let (....) : Trait ... =` *) (* Open the box for the name + generics *) F.pp_open_hovbox fmt ctx.indent_incr; - let qualif = Option.get (ctx.fmt.fun_decl_kind_to_qualif SingleNonRec) in - F.pp_print_string fmt qualif; - F.pp_print_space fmt (); + (match ctx.fmt.fun_decl_kind_to_qualif SingleNonRec with + | Some qualif -> + F.pp_print_string fmt qualif; + F.pp_print_space fmt () + | None -> ()); F.pp_print_string fmt impl_name; (* Print the generics *) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index ea5fe8d3..22b017e5 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1249,6 +1249,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info (keep_fwd, num_backs) +(* TODO: move to Extract *) let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = (* Sanity check: the function should not be a global body - those are handled diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 3b4afff6..0d591028 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -78,21 +78,24 @@ let builtin_globals_map : string SimpleNameMap.t = (List.map (fun (x, y) -> (string_to_simple_name x, y)) builtin_globals) type builtin_variant_info = { fields : (string * string) list } +[@@deriving show] type builtin_enum_variant_info = { rust_variant_name : string; extract_variant_name : string; fields : string list option; } +[@@deriving show] type builtin_type_body_info = | Struct of string * string list (* The constructor name and the map for the field names *) | Enum of builtin_enum_variant_info list (* For every variant, a map for the field names *) +[@@deriving show] type builtin_type_info = { - rust_name : string; + rust_name : string list; extract_name : string; keep_params : bool list option; (** We might want to filter some of the type parameters. @@ -102,6 +105,7 @@ type builtin_type_info = { *) body_info : builtin_type_body_info option; } +[@@deriving show] (** The assumed types. @@ -113,7 +117,7 @@ let builtin_types () : builtin_type_info list = [ (* Alloc *) { - rust_name = "alloc::alloc::Global"; + rust_name = [ "alloc"; "alloc"; "Global" ]; extract_name = (match !backend with | Lean -> "AllocGlobal" @@ -123,7 +127,7 @@ let builtin_types () : builtin_type_info list = }; (* Vec *) { - rust_name = "alloc::vec::Vec"; + rust_name = [ "alloc"; "vec"; "Vec" ]; extract_name = (match !backend with Lean -> "Vec" | Coq | FStar | HOL4 -> "vec"); keep_params = Some [ true; false ]; @@ -131,7 +135,7 @@ let builtin_types () : builtin_type_info list = }; (* Option *) { - rust_name = "core::option::Option"; + rust_name = [ "core"; "option"; "Option" ]; extract_name = (match !backend with | Lean -> "Option" @@ -163,7 +167,7 @@ let builtin_types () : builtin_type_info list = }; (* Range *) { - rust_name = "core::ops::range::Range"; + rust_name = [ "core"; "ops"; "range"; "Range" ]; extract_name = (match !backend with Lean -> "Range" | Coq | FStar | HOL4 -> "range"); keep_params = None; @@ -180,9 +184,7 @@ let builtin_types () : builtin_type_info list = let mk_builtin_types_map () = SimpleNameMap.of_list - (List.map - (fun info -> (string_to_simple_name info.rust_name, info)) - (builtin_types ())) + (List.map (fun info -> (info.rust_name, info)) (builtin_types ())) let builtin_types_map = mk_memoized mk_builtin_types_map @@ -190,6 +192,7 @@ type builtin_fun_info = { rg : Types.RegionGroupId.id option; extract_name : string; } +[@@deriving show] (** The assumed functions. @@ -197,10 +200,12 @@ type builtin_fun_info = { parameters. For instance, in the case of the `Vec` functions, there is a type parameter for the allocator to use, which we want to filter. *) -let builtin_funs () : (string * bool list option * builtin_fun_info list) list = +let builtin_funs () : + (string list * bool list option * builtin_fun_info list) list = let rg0 = Some Types.RegionGroupId.zero in + (* TODO: fix the names below *) [ - ( "core::mem::replace", + ( [ "core::mem::replace" ], None, [ { @@ -218,7 +223,7 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "mem.replace_back"); }; ] ); - ( "alloc::vec::Vec::new", + ( [ "alloc::vec::Vec::new" ], Some [ true; false ], [ { @@ -236,7 +241,7 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "Vec.new_back"); }; ] ); - ( "alloc::vec::Vec::push", + ( [ "alloc::vec::Vec::push" ], Some [ true; false ], [ (* The forward function shouldn't be used *) @@ -255,7 +260,7 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "Vec.push"); }; ] ); - ( "alloc::vec::Vec::insert", + ( [ "alloc::vec::Vec::insert" ], Some [ true; false ], [ (* The forward function shouldn't be used *) @@ -274,7 +279,7 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "Vec.insert"); }; ] ); - ( "alloc::vec::Vec::len", + ( [ "alloc::vec::Vec::len" ], Some [ true; false ], [ { @@ -285,7 +290,7 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "Vec.len"); }; ] ); - ( "alloc::vec::Vec::index", + ( [ "alloc::vec::Vec::index" ], Some [ true; false ], [ { @@ -304,7 +309,7 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "Vec.index_shared_back"); }; ] ); - ( "alloc::vec::Vec::index_mut", + ( [ "alloc::vec::Vec::index_mut" ], Some [ true; false ], [ { @@ -323,16 +328,52 @@ let builtin_funs () : (string * bool list option * builtin_fun_info list) list = | Lean -> "Vec.index_mut_back"); }; ] ); + ( [ "alloc"; "boxed"; "Box"; "deref" ], + Some [ true; false ], + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "alloc_boxed_box_deref" + | Lean -> "alloc.boxed.Box.deref"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "alloc_boxed_box_deref_back" + | Lean -> "alloc.boxed.Box.deref_back"); + }; + ] ); + ( [ "alloc"; "boxed"; "Box"; "deref_mut" ], + Some [ true; false ], + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "alloc_boxed_box_deref_mut" + | Lean -> "alloc.boxed.Box.deref_mut"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "alloc_boxed_box_deref_mut_back" + | Lean -> "alloc.boxed.Box.deref_mut_back"); + }; + ] ); ] let mk_builtin_funs_map () = SimpleNameMap.of_list (List.map - (fun (name, filter, info) -> - (string_to_simple_name name, (filter, info))) + (fun (name, filter, info) -> (name, (filter, info))) (builtin_funs ())) -let builtin_funs_map () = mk_memoized mk_builtin_funs_map +let builtin_funs_map = mk_memoized mk_builtin_funs_map type builtin_trait_decl_info = { rust_name : string; @@ -346,6 +387,7 @@ type builtin_trait_decl_info = { - a list of clauses *) funs : (string * (Types.RegionGroupId.id option * string) list) list; } +[@@deriving show] let builtin_trait_decls_info () = let rg0 = Some Types.RegionGroupId.zero in @@ -389,7 +431,7 @@ let builtin_trait_decls_info () = [ (match !backend with | Coq | FStar | HOL4 -> "deref_inst" - | Lean -> "DerefInst"); + | Lean -> "derefInst"); ]; consts = []; types = []; diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 0871a305..95252b61 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -654,78 +654,100 @@ let export_functions_group_scc (fmt : Format.formatter) (config : gen_config) *) let export_functions_group (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (pure_ls : pure_fun_translation list) : unit = - (* Utility to check a function has a decrease clause *) - let has_decreases_clause (def : Pure.fun_decl) : bool = - PureUtils.FunLoopIdSet.mem (def.def_id, def.loop_id) - ctx.functions_with_decreases_clause + (* Check if the definition are builtin - if yes they must be ignored. + Note that if one definition in the group is builtin, then all the + definitions must be builtin *) + let builtin = + let open ExtractBuiltin in + let funs_map = builtin_funs_map () in + List.map + (fun (trans : pure_fun_translation) -> + let sname = name_to_simple_name trans.fwd.f.basename in + SimpleNameMap.find_opt sname funs_map <> None) + pure_ls in - (* Extract the decrease clauses template bodies *) - if config.extract_template_decreases_clauses then - List.iter - (fun { fwd; _ } -> - (* We only generate decreases clauses for the forward functions, because - the termination argument should only depend on the forward inputs. - The backward functions thus use the same decreases clauses as the - forward function. - - Rem.: we might filter backward functions in {!PureMicroPasses}, but - we don't remove forward functions. Instead, we remember if we should - filter those functions at extraction time with a boolean (see the - type of the [pure_ls] input parameter). - *) - let extract_decrease decl = - let has_decr_clause = has_decreases_clause decl in - if has_decr_clause then - match !Config.backend with - | Lean -> - Extract.extract_template_lean_termination_and_decreasing ctx fmt - decl - | FStar -> - Extract.extract_template_fstar_decreases_clause ctx fmt decl - | Coq -> - raise (Failure "Coq doesn't have decreases/termination clauses") - | HOL4 -> - raise - (Failure "HOL4 doesn't have decreases/termination clauses") - in - extract_decrease fwd.f; - List.iter extract_decrease fwd.loops) - pure_ls; - - (* Concatenate the function definitions, filtering the useless forward - * functions. *) - let decls = - List.concat - (List.map - (fun { keep_fwd; fwd; backs } -> - let fwd = if keep_fwd then List.append fwd.loops [ fwd.f ] else [] in - let backs : Pure.fun_decl list = - List.concat - (List.map (fun back -> List.append back.loops [ back.f ]) backs) - in - List.append fwd backs) - pure_ls) - in + if List.exists (fun b -> b) builtin then + (* Sanity check *) + assert (List.for_all (fun b -> b) builtin) + else + (* Utility to check a function has a decrease clause *) + let has_decreases_clause (def : Pure.fun_decl) : bool = + PureUtils.FunLoopIdSet.mem (def.def_id, def.loop_id) + ctx.functions_with_decreases_clause + in + + (* Extract the decrease clauses template bodies *) + if config.extract_template_decreases_clauses then + List.iter + (fun { fwd; _ } -> + (* We only generate decreases clauses for the forward functions, because + the termination argument should only depend on the forward inputs. + The backward functions thus use the same decreases clauses as the + forward function. + + Rem.: we might filter backward functions in {!PureMicroPasses}, but + we don't remove forward functions. Instead, we remember if we should + filter those functions at extraction time with a boolean (see the + type of the [pure_ls] input parameter). + *) + let extract_decrease decl = + let has_decr_clause = has_decreases_clause decl in + if has_decr_clause then + match !Config.backend with + | Lean -> + Extract.extract_template_lean_termination_and_decreasing ctx + fmt decl + | FStar -> + Extract.extract_template_fstar_decreases_clause ctx fmt decl + | Coq -> + raise + (Failure "Coq doesn't have decreases/termination clauses") + | HOL4 -> + raise + (Failure "HOL4 doesn't have decreases/termination clauses") + in + extract_decrease fwd.f; + List.iter extract_decrease fwd.loops) + pure_ls; + + (* Concatenate the function definitions, filtering the useless forward + * functions. *) + let decls = + List.concat + (List.map + (fun { keep_fwd; fwd; backs } -> + let fwd = + if keep_fwd then List.append fwd.loops [ fwd.f ] else [] + in + let backs : Pure.fun_decl list = + List.concat + (List.map + (fun back -> List.append back.loops [ back.f ]) + backs) + in + List.append fwd backs) + pure_ls) + in - (* Extract the function definitions *) - (if config.extract_fun_decls then - (* Group the mutually recursive definitions *) - let subgroups = ReorderDecls.group_reorder_fun_decls decls in + (* Extract the function definitions *) + (if config.extract_fun_decls then + (* Group the mutually recursive definitions *) + let subgroups = ReorderDecls.group_reorder_fun_decls decls in - (* Extract the subgroups *) - let export_subgroup (is_rec : bool) (decls : Pure.fun_decl list) : unit = - export_functions_group_scc fmt config ctx is_rec decls - in - List.iter (fun (is_rec, decls) -> export_subgroup is_rec decls) subgroups); - - (* Insert unit tests if necessary *) - if config.test_trans_unit_functions then - List.iter - (fun trans -> - if trans.keep_fwd then - Extract.extract_unit_test_if_unit_fun ctx fmt trans.fwd.f) - pure_ls + (* Extract the subgroups *) + let export_subgroup (is_rec : bool) (decls : Pure.fun_decl list) : unit = + export_functions_group_scc fmt config ctx is_rec decls + in + List.iter (fun (is_rec, decls) -> export_subgroup is_rec decls) subgroups); + + (* Insert unit tests if necessary *) + if config.test_trans_unit_functions then + List.iter + (fun trans -> + if trans.keep_fwd then + Extract.extract_unit_test_if_unit_fun ctx fmt trans.fwd.f) + pure_ls (** Export a trait declaration. *) let export_trait_decl (fmt : Format.formatter) (_config : gen_config) -- cgit v1.2.3 From be70eed487b507dc002660a4c891397003165e75 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 15:01:55 +0200 Subject: Add support for builtin trait implementations --- compiler/Extract.ml | 32 ++++++++++++++++++++++++++++++-- compiler/ExtractBase.ml | 17 ----------------- compiler/ExtractBuiltin.ml | 34 ++++++++++++++++++++++++++++++++++ compiler/Translate.ml | 17 ++++++++++++++++- 4 files changed, 80 insertions(+), 20 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index ddc02fa7..a1c9605b 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -4320,7 +4320,15 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) let builtin_info = SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) in - let ctx = ctx_add_trait_decl trait_decl ctx in + let ctx = + let trait_name = + match builtin_info with + | None -> ctx.fmt.trait_decl_name trait_decl + | Some info -> info.extract_name + in + let is_opaque = false in + ctx_add is_opaque (TraitDeclId trait_decl.def_id) trait_name ctx + in (* Parent clauses *) let ctx = extract_trait_decl_register_parent_clause_names ctx trait_decl builtin_info @@ -4338,11 +4346,31 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) (** Similar to {!extract_type_decl_register_names} *) let extract_trait_impl_register_names (ctx : extraction_ctx) (trait_impl : trait_impl) : extraction_ctx = + let trait_decl = + TraitDeclId.Map.find trait_impl.impl_trait.trait_decl_id + ctx.trans_trait_decls + in + (* Check if the trait implementation is builtin *) + let builtin_info = + let open ExtractBuiltin in + let type_sname = name_to_simple_name trait_impl.name in + let trait_sname = name_to_simple_name trait_decl.name in + SimpleNamePairMap.find_opt (type_sname, trait_sname) + (builtin_trait_impls_map ()) + in + (* For now we do not support overriding provided methods *) assert (trait_impl.provided_methods = []); (* Everything is taken care of by {!extract_trait_decl_register_names} *but* the name of the implementation itself *) - ctx_add_trait_impl trait_impl ctx + (* Compute the name *) + let name = + match builtin_info with + | None -> ctx.fmt.trait_impl_name trait_decl trait_impl + | Some name -> name + in + let is_opaque = false in + ctx_add is_opaque (TraitImplId trait_impl.def_id) name ctx (** Small helper. diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 22b017e5..3ff299f2 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1272,23 +1272,6 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) ctx.fun_name_info; } -let ctx_add_trait_decl (d : trait_decl) (ctx : extraction_ctx) : extraction_ctx - = - let is_opaque = false in - let name = ctx.fmt.trait_decl_name d in - ctx_add is_opaque (TraitDeclId d.def_id) name ctx - -let ctx_add_trait_impl (d : trait_impl) (ctx : extraction_ctx) : extraction_ctx - = - (* We need to lookup the trait decl that is implemented by the trait impl *) - let decl = - Pure.TraitDeclId.Map.find d.impl_trait.trait_decl_id ctx.trans_trait_decls - in - (* Compute the name *) - let is_opaque = false in - let name = ctx.fmt.trait_impl_name decl d in - ctx_add is_opaque (TraitImplId d.def_id) name ctx - type names_map_init = { keywords : string list; assumed_adts : (assumed_ty * string) list; diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 0d591028..d3cea54e 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -517,3 +517,37 @@ let mk_builtin_trait_decls_map () = (builtin_trait_decls_info ())) let builtin_trait_decls_map = mk_memoized mk_builtin_trait_decls_map + +(* TODO: generalize this. + + For now, the key is: + - name of the impl (ex.: "alloc.boxed.Boxed") + - name of the implemented trait (ex.: "core.ops.deref.Deref" +*) +type simple_name_pair = simple_name * simple_name [@@deriving show, ord] + +module SimpleNamePairOrd = struct + type t = simple_name_pair + + let compare = compare_simple_name_pair + let to_string = show_simple_name_pair + let pp_t = pp_simple_name_pair + let show_t = show_simple_name_pair +end + +module SimpleNamePairMap = Collections.MakeMap (SimpleNamePairOrd) + +let builtin_trait_impls_info () : ((string list * string list) * string) list = + [ + (* core::ops::Deref> *) + ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "Deref" ]), + "alloc.boxed.Box.coreOpsDerefInst" ); + (* core::ops::DerefMut> *) + ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "DerefMut" ]), + "alloc.boxed.Box.coreOpsDerefMutInst" ); + ] + +let mk_builtin_trait_impls_map () = + SimpleNamePairMap.of_list (builtin_trait_impls_info ()) + +let builtin_trait_impls_map = mk_memoized mk_builtin_trait_impls_map diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 95252b61..74a8537f 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -764,8 +764,23 @@ let export_trait_decl (fmt : Format.formatter) (_config : gen_config) (** Export a trait implementation. *) let export_trait_impl (fmt : Format.formatter) (_config : gen_config) (ctx : gen_ctx) (trait_impl_id : Pure.trait_impl_id) : unit = + (* Lookup the definition *) let trait_impl = T.TraitImplId.Map.find trait_impl_id ctx.trans_trait_impls in - Extract.extract_trait_impl ctx fmt trait_impl + let trait_decl = + Pure.TraitDeclId.Map.find trait_impl.impl_trait.trait_decl_id + ctx.trans_trait_decls + in + (* Check if the trait implementation is builtin *) + let builtin_info = + let open ExtractBuiltin in + let type_sname = name_to_simple_name trait_impl.name in + let trait_sname = name_to_simple_name trait_decl.name in + SimpleNamePairMap.find_opt (type_sname, trait_sname) + (builtin_trait_impls_map ()) + in + match builtin_info with + | None -> Extract.extract_trait_impl ctx fmt trait_impl + | Some _ -> () (** A generic utility to generate the extracted definitions: as we may want to split the definitions between different files (or not), we can control -- cgit v1.2.3 From b631875f8166b3db81187a179eef2f21f52db2bd Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 15:26:41 +0200 Subject: Remove the possibility of generating opaque module signatures --- compiler/Config.ml | 7 -- compiler/Extract.ml | 167 +++++++++++----------------------- compiler/ExtractBase.ml | 233 ++++++++++++------------------------------------ compiler/Translate.ml | 34 +------ 4 files changed, 111 insertions(+), 330 deletions(-) (limited to 'compiler') diff --git a/compiler/Config.ml b/compiler/Config.ml index 62f6c300..cd0903b6 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -306,13 +306,6 @@ let filter_useless_monadic_calls = ref true *) let filter_useless_functions = ref true -(** Obsolete. TODO: remove. - - For Lean we used to parameterize the entire development by a section variable - called opaque_defs, of type OpaqueDefs. - *) -let wrap_opaque_in_sig = ref false - (** Use short names for the record fields. Some backends can't disambiguate records when their field names have collisions. diff --git a/compiler/Extract.ml b/compiler/Extract.ml index a1c9605b..275cb3b9 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -758,12 +758,6 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) fname ^ lp_suffix ^ suffix in - let opaque_pre () = - match !Config.backend with - | FStar | Coq | HOL4 -> "" - | Lean -> if !Config.wrap_opaque_in_sig then "opaque_defs." else "" - in - let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) : string = (* Small helper to derive var names from ADT type names. @@ -934,7 +928,6 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) trait_type_name; trait_method_name; trait_type_clause_name; - opaque_pre; var_basename; type_var_basename; const_generic_var_basename; @@ -983,11 +976,8 @@ let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) (* In HOL4, opaque functions have a special treatment *) if is_single_opaque_fun_decl_group dg then () else - let with_opaque_pre = false in let compute_fun_def_name (def : Pure.fun_decl) : string = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx - ^ "_def" + ctx_get_local_function def.def_id def.loop_id def.back_id ctx ^ "_def" in let names = List.map compute_fun_def_name dg in (* Add a break before *) @@ -1110,7 +1100,7 @@ let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (cg : const_generic) : unit = match cg with | ConstGenericGlobal id -> - let s = ctx_get_global ctx.use_opaque_pre id ctx in + let s = ctx_get_global id ctx in F.pp_print_string fmt s | ConstGenericValue v -> ctx.fmt.extract_literal fmt inside v | ConstGenericVar id -> @@ -1178,14 +1168,13 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) In HOL4 we would write: `('a, 'b) tree` *) - let with_opaque_pre = false in match !backend with | FStar | Coq | Lean -> let print_paren = inside && has_params in if print_paren then F.pp_print_string fmt "("; (* TODO: for now, only the opaque *functions* are extracted in the opaque module. The opaque *types* are assumed. *) - F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx); + F.pp_print_string fmt (ctx_get_type type_id ctx); extract_generic_args ctx fmt no_params_tys generics; if print_paren then F.pp_print_string fmt ")" | HOL4 -> @@ -1208,7 +1197,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (extract_rec true) types; if print_paren then F.pp_print_string fmt ")"; F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type with_opaque_pre type_id ctx); + F.pp_print_string fmt (ctx_get_type type_id ctx); if trait_refs <> [] then ( F.pp_print_space fmt (); Collections.List.iter_link (F.pp_print_space fmt) @@ -1273,8 +1262,7 @@ and extract_trait_decl_ref (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 is_opaque = false in - let name = ctx_get_trait_decl is_opaque tr.trait_decl_id ctx in + let name = ctx_get_trait_decl tr.trait_decl_id ctx in if use_brackets then F.pp_print_string fmt "("; F.pp_print_string fmt name; (* There is something subtle here: the trait obligations for the implemented @@ -1307,14 +1295,13 @@ and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) : unit = - let with_opaque_pre = false in match id with | Self -> (* This has specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) raise (Failure "Unexpected") | TraitImpl id -> - let name = ctx_get_trait_impl with_opaque_pre id ctx in + let name = ctx_get_trait_impl id ctx in F.pp_print_string fmt name | Clause id -> let name = ctx_get_local_trait_clause id ctx in @@ -1354,8 +1341,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : | None -> ctx.fmt.type_name def.name | Some info -> String.concat "." info.rust_name in - let is_opaque = def.kind = Opaque in - let ctx = ctx_add is_opaque (TypeId (AdtId def.def_id)) def_name ctx in + let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in (* Compute and register: * - the variant names, if this is an enumeration * - the field names, if this is a structure @@ -1392,11 +1378,11 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let ctx = List.fold_left (fun ctx (fid, name) -> - ctx_add is_opaque (FieldId (AdtId def.def_id, fid)) name ctx) + ctx_add (FieldId (AdtId def.def_id, fid)) name ctx) ctx field_names in (* Add the constructor name *) - ctx_add is_opaque (StructId (AdtId def.def_id)) cons_name ctx + ctx_add (StructId (AdtId def.def_id)) cons_name ctx | Enum variants -> let variant_names = match info with @@ -1432,7 +1418,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : in List.fold_left (fun ctx (vid, vname) -> - ctx_add is_opaque (VariantId (AdtId def.def_id, vid)) vname ctx) + ctx_add (VariantId (AdtId def.def_id, vid)) vname ctx) ctx variant_names | Opaque -> (* Nothing to do *) @@ -1635,9 +1621,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) (* If Coq: print the constructor name *) (* TODO: remove superfluous test not is_rec below *) if !backend = Coq && not is_rec then ( - let with_opaque_pre = false in - F.pp_print_string fmt - (ctx_get_struct with_opaque_pre (AdtId def.def_id) ctx); + F.pp_print_string fmt (ctx_get_struct (AdtId def.def_id) ctx); F.pp_print_string fmt " "); (match !backend with | Lean -> () @@ -1681,16 +1665,14 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) (* 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 *) assert (is_rec && (!backend = Coq || !backend = Lean)); - let with_opaque_pre = false in (* 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 with_opaque_pre (AdtId def.def_id) ctx + if !backend = Lean then "mk" else ctx_get_struct (AdtId def.def_id) ctx in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in + let def_name = ctx_get_local_type def.def_id ctx in extract_type_decl_variant ctx fmt type_decl_group def_name type_params cg_params cons_name fields) in @@ -1720,8 +1702,7 @@ let extract_comment (fmt : F.formatter) (sl : string list) : unit = let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = - let with_opaque_pre = false in - let trait_name = ctx_get_trait_decl with_opaque_pre clause.trait_id ctx in + let trait_name = ctx_get_trait_decl clause.trait_id ctx in F.pp_print_string fmt trait_name; extract_generic_args ctx fmt no_params_tys clause.generics @@ -1743,8 +1724,7 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); - let with_opaque_pre = false in - let trait_id = ctx_get_trait_decl with_opaque_pre trait_decl.def_id ctx in + let trait_id = ctx_get_trait_decl trait_decl.def_id ctx in F.pp_print_string fmt trait_id; List.iter (fun p -> @@ -1913,8 +1893,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let is_opaque_coq = !backend = Coq && is_opaque in let use_forall = is_opaque_coq && def.generics <> empty_generic_params in (* Retrieve the definition name *) - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in + let def_name = ctx_get_local_type def.def_id ctx in (* 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 = @@ -2001,8 +1980,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : type_decl) : unit = (* Retrieve the definition name *) - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in + let def_name = ctx_get_local_type def.def_id ctx in (* Generic parameters are unsupported *) assert (def.generics.const_generics = []); (* Trait clauses on type definitions are unsupported *) @@ -2027,8 +2005,7 @@ let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) (fmt : F.formatter) (def : type_decl) : unit = (* Retrieve the definition name *) - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre def.def_id ctx in + let def_name = ctx_get_local_type def.def_id ctx in (* Sanity check *) assert (def.generics = empty_generic_params); (* Generate the declaration *) @@ -2111,8 +2088,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) | Struct fields -> let adt_id = AdtId decl.def_id in (* Generate the instruction for the record constructor *) - let with_opaque_pre = false in - let cons_name = ctx_get_struct with_opaque_pre adt_id ctx in + let cons_name = ctx_get_struct adt_id ctx in extract_arguments_info cons_name fields; (* Generate the instruction for the record projectors, if there are *) let is_rec = decl_is_from_rec_group kind in @@ -2156,11 +2132,8 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) in let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in - let with_opaque_pre = false in - let def_name = ctx_get_local_type with_opaque_pre decl.def_id ctx in - let cons_name = - ctx_get_struct with_opaque_pre (AdtId decl.def_id) ctx - in + let def_name = ctx_get_local_type decl.def_id ctx in + let cons_name = ctx_get_struct (AdtId decl.def_id) ctx in let extract_field_proj (field_id : FieldId.id) (_ : field) : unit = F.pp_print_space fmt (); (* Outer box for the projector definition *) @@ -2391,7 +2364,6 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) | Some (_filter, info) -> let backs = List.map (fun f -> f.f) def.backs in let funs = if def.keep_fwd then def.fwd.f :: backs else backs in - let is_opaque = false in List.fold_left (fun ctx (f : fun_decl) -> let open ExtractBuiltin in @@ -2404,7 +2376,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) info) .extract_name in - ctx_add is_opaque (FunId (FromLlbc fun_id)) fun_name ctx) + ctx_add (FunId (FromLlbc fun_id)) fun_name ctx) ctx funs | None -> let fwd = def.fwd in @@ -2509,18 +2481,14 @@ let extract_adt_g_value * [{ field0=...; ...; fieldn=...; }] in case of structures. *) let cons = - (* The ADT shouldn't be opaque *) - let with_opaque_pre = false in match variant_id with | Some vid -> ( (* In the case of Lean, we might have to add the type name as a prefix *) match (!backend, adt_id) with | Lean, Assumed _ -> - ctx_get_type with_opaque_pre adt_id ctx - ^ "." - ^ ctx_get_variant adt_id vid ctx + ctx_get_type adt_id ctx ^ "." ^ ctx_get_variant adt_id vid ctx | _ -> ctx_get_variant adt_id vid ctx) - | None -> ctx_get_struct with_opaque_pre adt_id ctx + | None -> ctx_get_struct adt_id ctx in let use_parentheses = inside && field_values <> [] in if use_parentheses then F.pp_print_string fmt "("; @@ -2539,8 +2507,7 @@ let extract_adt_g_value (* Extract globals in the same way as variables *) let extract_global (ctx : extraction_ctx) (fmt : F.formatter) (id : A.GlobalDeclId.id) : unit = - let with_opaque_pre = ctx.use_opaque_pre in - F.pp_print_string fmt (ctx_get_global with_opaque_pre id ctx) + F.pp_print_string fmt (ctx_get_global id ctx) (** [inside]: see {!extract_ty}. @@ -2676,9 +2643,9 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) if inside then F.pp_print_string fmt "("; (* Open a box for the function call *) F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the function name *) - let with_opaque_pre = ctx.use_opaque_pre in - (* For the function name: the id is not the same depending on whether + (* Print the function name. + + For the function name: the id is not the same depending on whether we call a trait method and a "regular" function (remark: trait method *implementations* are considered as regular functions here; only calls to method of traits which are parameterized in a where @@ -2751,7 +2718,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) let fun_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 + let fun_name = ctx_get_function fun_id ctx in F.pp_print_string fmt fun_name; (* Note that we do not need to print the generics for the trait @@ -2762,7 +2729,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); extract_trait_ref ctx fmt TypeDeclId.Set.empty true trait_ref | _ -> - let fun_name = ctx_get_function with_opaque_pre fun_id ctx in + let fun_name = ctx_get_function fun_id ctx in F.pp_print_string fmt fun_name); (* Sanity check: HOL4 doesn't support const generics *) @@ -3260,7 +3227,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) - let cs = ctx_get_struct false (Assumed Array) ctx in + let cs = ctx_get_struct (Assumed Array) ctx in F.pp_print_string fmt cs; (* Print the parameters *) let _, generics = ty_as_adt e_ty in @@ -3613,10 +3580,8 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (has_decreases_clause : bool) (def : fun_decl) : unit = assert (not def.is_global_decl_body); (* Retrieve the function name *) - let with_opaque_pre = false in let def_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id def.back_id - ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then @@ -3649,8 +3614,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) if `wrap_opaque_in_sig`: we generate a record of assumed funcions. TODO: this is obsolete. *) - (if not (!Config.wrap_opaque_in_sig && (kind = Assumed || kind = Declared)) - then + (if not (kind = Assumed || kind = Declared) then let qualif = ctx.fmt.fun_decl_kind_to_qualif kind in match qualif with | Some qualif -> @@ -3867,10 +3831,8 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = (* Retrieve the definition name *) - let with_opaque_pre = false in let def_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id def.back_id - ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in assert (def.signature.generics.const_generics = []); (* Add the type/const gen parameters - note that we need those bindings @@ -4065,10 +4027,9 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) extract_comment fmt [ "[" ^ Print.global_name_to_string global.name ^ "]" ]; F.pp_print_space fmt (); - let with_opaque_pre = false in - let decl_name = ctx_get_global with_opaque_pre global.def_id ctx in + let decl_name = ctx_get_global global.def_id ctx in let body_name = - ctx_get_function with_opaque_pre + ctx_get_function (FromLlbc (Pure.FunId (Regular global.body_id), None, None)) ctx in @@ -4111,7 +4072,6 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) (trait_decl : trait_decl) (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : extraction_ctx = - let is_opaque = false in let generics = trait_decl.generics in (* Compute the clause names *) let clause_names = @@ -4135,7 +4095,7 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (cid, cname) -> - ctx_add is_opaque (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) + ctx_add (TraitParentClauseId (trait_decl.def_id, cid)) cname ctx) ctx clause_names (** Similar to {!extract_trait_decl_register_names} *) @@ -4143,7 +4103,6 @@ let extract_trait_decl_register_constant_names (ctx : extraction_ctx) (trait_decl : trait_decl) (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : extraction_ctx = - let is_opaque = false in let consts = trait_decl.consts in (* Compute the names *) let constant_names = @@ -4169,7 +4128,7 @@ let extract_trait_decl_register_constant_names (ctx : extraction_ctx) (* Register the names *) List.fold_left (fun ctx (item_name, name) -> - ctx_add is_opaque (TraitItemId (trait_decl.def_id, item_name)) name ctx) + ctx_add (TraitItemId (trait_decl.def_id, item_name)) name ctx) ctx constant_names (** Similar to {!extract_trait_decl_register_names} *) @@ -4177,7 +4136,6 @@ let extract_trait_decl_type_names (ctx : extraction_ctx) (trait_decl : trait_decl) (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : extraction_ctx = - let is_opaque = false in let types = trait_decl.types in (* Compute the names *) let type_names = @@ -4227,13 +4185,11 @@ let extract_trait_decl_type_names (ctx : extraction_ctx) List.fold_left (fun ctx (item_name, (type_name, clauses)) -> let ctx = - ctx_add is_opaque - (TraitItemId (trait_decl.def_id, item_name)) - type_name ctx + ctx_add (TraitItemId (trait_decl.def_id, item_name)) type_name ctx in List.fold_left (fun ctx (clause_id, clause_name) -> - ctx_add is_opaque + ctx_add (TraitItemClauseId (trait_decl.def_id, item_name, clause_id)) clause_name ctx) ctx clauses) @@ -4244,7 +4200,6 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) (trait_decl : trait_decl) (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : extraction_ctx = - let is_opaque = false in let required_methods = trait_decl.required_methods in (* Compute the names *) let method_names = @@ -4305,7 +4260,7 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) (* We add one field per required forward/backward function *) List.fold_left (fun ctx (rg, fun_name) -> - ctx_add is_opaque + ctx_add (TraitMethodId (trait_decl.def_id, item_name, rg)) fun_name ctx) ctx funs) @@ -4326,8 +4281,7 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) | None -> ctx.fmt.trait_decl_name trait_decl | Some info -> info.extract_name in - let is_opaque = false in - ctx_add is_opaque (TraitDeclId trait_decl.def_id) trait_name ctx + ctx_add (TraitDeclId trait_decl.def_id) trait_name ctx in (* Parent clauses *) let ctx = @@ -4369,8 +4323,7 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) | None -> ctx.fmt.trait_impl_name trait_decl trait_impl | Some name -> name in - let is_opaque = false in - ctx_add is_opaque (TraitImplId trait_impl.def_id) name ctx + ctx_add (TraitImplId trait_impl.def_id) name ctx (** Small helper. @@ -4446,8 +4399,7 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (decl : trait_decl) : unit = (* Retrieve the trait name *) - let with_opaque_pre = false in - let decl_name = ctx_get_trait_decl with_opaque_pre decl.def_id ctx in + let decl_name = ctx_get_trait_decl decl.def_id ctx in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -4592,7 +4544,7 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) if use_forall then F.pp_print_string fmt ","; (* Extract the function call *) F.pp_print_space fmt (); - let id = ctx_get_local_function false f.def_id None f.back_id ctx in + let id = ctx_get_local_function f.def_id None f.back_id ctx in F.pp_print_string fmt id; let all_generics = let i_tys, i_cgs, i_tcs = impl_generics in @@ -4613,8 +4565,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (impl : trait_impl) : unit = log#ldebug (lazy ("extract_trait_impl: " ^ Names.name_to_string impl.name)); (* Retrieve the impl name *) - let with_opaque_pre = false in - let impl_name = ctx_get_trait_impl with_opaque_pre impl.def_id ctx in + let impl_name = ctx_get_trait_impl impl.def_id ctx in (* Add a break before *) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) @@ -4690,7 +4641,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) let item_name = ctx_get_trait_const trait_decl_id name ctx in let ty () = F.pp_print_space fmt (); - F.pp_print_string fmt (ctx_get_global false id ctx) + F.pp_print_string fmt (ctx_get_global id ctx) in extract_trait_impl_item ctx fmt item_name ty) @@ -4776,12 +4727,8 @@ 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 "("; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( @@ -4796,12 +4743,8 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "Check"; F.pp_print_space fmt (); F.pp_print_string fmt "("; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( @@ -4813,12 +4756,8 @@ 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 "("; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( @@ -4832,12 +4771,8 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; F.pp_print_string fmt "“"; - (* Note that if the function is opaque, the unit test will fail - because the normalizer will get stuck *) - let with_opaque_pre = ctx.use_opaque_pre in let fun_name = - ctx_get_local_function with_opaque_pre def.def_id def.loop_id - def.back_id ctx + ctx_get_local_function def.def_id def.loop_id def.back_id ctx in F.pp_print_string fmt fun_name; if sg.inputs <> [] then ( diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 3ff299f2..f26beeb6 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -251,37 +251,6 @@ type formatter = { trait_type_name : trait_decl -> string -> string; trait_method_name : trait_decl -> string -> string; trait_type_clause_name : trait_decl -> string -> trait_clause -> string; - opaque_pre : unit -> string; - (** TODO: obsolete, remove. - - The prefix to use for opaque definitions. - - We need this because for some backends like Lean and Coq, we group - opaque definitions in module signatures, meaning that using those - definitions requires to prefix them with a module parameter name (such - as "opaque_defs."). - - For instance, if we have an opaque function [f : int -> int], which - is used by the non-opaque function [g], we would generate (in Coq): - {[ - (* The module signature declaring the opaque definitions *) - module type OpaqueDefs = { - f_fwd : int -> int - ... (* Other definitions *) - } - - (* The definitions generated for the non-opaque definitions *) - module Funs (opaque: OpaqueDefs) = { - let g ... = - ... - opaque_defs.f_fwd - ... - } - ]} - - Upon using [f] in [g], we don't directly use the the name "f_fwd", - but prefix it with the "opaque_defs." identifier. - *) var_basename : StringSet.t -> string option -> ty -> string; (** Generates a variable basename. @@ -498,20 +467,6 @@ type names_map = { precisely which identifiers are mapped to the same name... *) names_set : StringSet.t; - opaque_ids : IdSet.t; - (** TODO: this is obsolete. Remove. - - The set of opaque definitions. - - See {!formatter.opaque_pre} for detailed explanations about why - we need to know which definitions are opaque to compute names. - - Also note that the opaque ids don't contain the ids of the assumed - definitions. In practice, assumed definitions are opaque_defs. However, they - are not grouped in the opaque module, meaning we never need to - prefix them (with, say, "opaque_defs."): we thus consider them as non-opaque - with regards to the names map. - *) } let empty_names_map : names_map = @@ -519,7 +474,6 @@ let empty_names_map : names_map = id_to_name = IdMap.empty; name_to_id = StringMap.empty; names_set = StringSet.empty; - opaque_ids = IdSet.empty; } (** Small helper to report name collision *) @@ -547,8 +501,8 @@ let names_map_check_collision (id_to_string : id -> string) (id : id) (* There is a clash: print a nice debugging message for the user *) report_name_collision id_to_string clash id name -let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) - (name : string) (nm : names_map) : names_map = +let names_map_add (id_to_string : id -> string) (id : id) (name : string) + (nm : names_map) : names_map = (* Check if there is a clash *) names_map_check_collision id_to_string id name nm; (* Sanity check *) @@ -564,32 +518,24 @@ let names_map_add (id_to_string : id -> string) (is_opaque : bool) (id : id) let id_to_name = IdMap.add id name nm.id_to_name in let name_to_id = StringMap.add name id nm.name_to_id in let names_set = StringSet.add name nm.names_set in - let opaque_ids = - if is_opaque then IdSet.add id nm.opaque_ids else nm.opaque_ids - in - { id_to_name; name_to_id; names_set; opaque_ids } + { id_to_name; name_to_id; names_set } let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) (name : string) (nm : names_map) : names_map = - let is_opaque = false in - names_map_add id_to_string is_opaque (TypeId (Assumed id)) name nm + names_map_add id_to_string (TypeId (Assumed id)) name nm let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) (name : string) (nm : names_map) : names_map = - let is_opaque = false in - names_map_add id_to_string is_opaque (StructId (Assumed id)) name nm + names_map_add id_to_string (StructId (Assumed id)) name nm let names_map_add_assumed_variant (id_to_string : id -> string) (id : assumed_ty) (variant_id : VariantId.id) (name : string) (nm : names_map) : names_map = - let is_opaque = false in - names_map_add id_to_string is_opaque - (VariantId (Assumed id, variant_id)) - name nm + names_map_add id_to_string (VariantId (Assumed id, variant_id)) name nm -let names_map_add_function (id_to_string : id -> string) (is_opaque : bool) - (fid : fun_id) (name : string) (nm : names_map) : names_map = - names_map_add id_to_string is_opaque (FunId fid) name nm +let names_map_add_function (id_to_string : id -> string) (fid : fun_id) + (name : string) (nm : names_map) : names_map = + names_map_add id_to_string (FunId fid) name nm (** The unsafe names map stores mappings from identifiers to names which might collide. For some backends and some names, it might be acceptable to have @@ -667,14 +613,6 @@ type extraction_ctx = { fmt : formatter; indent_incr : int; (** The indent increment we insert whenever we need to indent more *) - use_opaque_pre : bool; - (** Do we use the "opaque_defs." prefix for the opaque definitions? - - Opaque function definitions might refer opaque types: if we are in the - opaque module, we musn't use the "opaque_defs." prefix, otherwise we - use it. - Also see {!names_map.opaque_ids}. - *) use_dep_ite : bool; (** For Lean: do we use dependent-if then else expressions? @@ -884,8 +822,7 @@ let allow_collisions (id : id) : bool = !Config.record_fields_short_names | _ -> false -let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) - : extraction_ctx = +let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = (* The id_to_string function to print nice debugging messages if there are * collisions *) let id_to_string (id : id) : string = id_to_string id ctx in @@ -902,7 +839,6 @@ let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) others (ex.: fields and keywords). *) if allow_collisions id then ( - assert (not is_opaque); (* Check with the ids which are considered to be strict on collisions *) names_map_check_collision id_to_string id name ctx.strict_names_map; { @@ -916,16 +852,13 @@ let ctx_add (is_opaque : bool) (id : id) (name : string) (ctx : extraction_ctx) *) let strict_names_map = if strict_collisions id then - names_map_add id_to_string is_opaque id name ctx.strict_names_map + names_map_add id_to_string id name ctx.strict_names_map else ctx.strict_names_map in - let names_map = - names_map_add id_to_string is_opaque id name ctx.names_map - in + let names_map = names_map_add id_to_string id name ctx.names_map in { ctx with strict_names_map; names_map } -(** [with_opaque_pre]: if [true] and the definition is opaque, add the opaque prefix *) -let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = +let ctx_get (id : id) (ctx : extraction_ctx) : string = (* We do not use the same name map if we allow/disallow collisions *) let map_to_string (m : string IdMap.t) : string = "[\n" @@ -951,9 +884,7 @@ let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = else let m = ctx.names_map.id_to_name in match IdMap.find_opt id m with - | Some s -> - let is_opaque = IdSet.mem id ctx.names_map.opaque_ids in - if with_opaque_pre && is_opaque then ctx.fmt.opaque_pre () ^ s else s + | Some s -> s | None -> let err = "Could not find: " ^ id_to_string id ctx ^ "\nNames map:\n" @@ -963,53 +894,38 @@ let ctx_get (with_opaque_pre : bool) (id : id) (ctx : extraction_ctx) : string = if !Config.extract_fail_hard then raise (Failure err) else "(ERROR: \"" ^ id_to_string id ctx ^ "\")" -let ctx_get_global (with_opaque_pre : bool) (id : A.GlobalDeclId.id) - (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (GlobalId id) ctx +let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx -let ctx_get_function (with_opaque_pre : bool) (id : fun_id) - (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (FunId id) ctx +let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = + ctx_get (FunId id) ctx -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 (FunId (Regular id), lp, rg)) ctx +let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) + (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = + ctx_get_function (FromLlbc (FunId (Regular id), lp, rg)) ctx -let ctx_get_type (with_opaque_pre : bool) (id : type_id) (ctx : extraction_ctx) - : string = +let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = assert (id <> Tuple); - ctx_get with_opaque_pre (TypeId id) ctx + ctx_get (TypeId id) ctx -let ctx_get_local_type (with_opaque_pre : bool) (id : TypeDeclId.id) - (ctx : extraction_ctx) : string = - ctx_get_type with_opaque_pre (AdtId id) ctx +let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = + ctx_get_type (AdtId id) ctx let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - (* In practice, the assumed types are opaque. However, assumed types - are never grouped in the opaque module, meaning we never need to - prefix them: we thus consider them as non-opaque with regards to the - names map. - *) - let is_opaque = false in - ctx_get_type is_opaque (Assumed id) ctx + ctx_get_type (Assumed id) ctx let ctx_get_trait_self_clause (ctx : extraction_ctx) : string = - let with_opaque_pre = false in - ctx_get with_opaque_pre TraitSelfClauseId ctx + ctx_get TraitSelfClauseId ctx -let ctx_get_trait_decl (with_opaque_pre : bool) (id : trait_decl_id) - (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (TraitDeclId id) ctx +let ctx_get_trait_decl (id : trait_decl_id) (ctx : extraction_ctx) : string = + ctx_get (TraitDeclId id) ctx -let ctx_get_trait_impl (with_opaque_pre : bool) (id : trait_impl_id) - (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (TraitImplId id) ctx +let ctx_get_trait_impl (id : trait_impl_id) (ctx : extraction_ctx) : string = + ctx_get (TraitImplId id) ctx let ctx_get_trait_item (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (TraitItemId (id, item_name)) ctx + ctx_get (TraitItemId (id, item_name)) ctx let ctx_get_trait_const (id : trait_decl_id) (item_name : string) (ctx : extraction_ctx) : string = @@ -1021,83 +937,69 @@ let ctx_get_trait_type (id : trait_decl_id) (item_name : string) let ctx_get_trait_method (id : trait_decl_id) (item_name : string) (rg_id : T.RegionGroupId.id option) (ctx : extraction_ctx) : string = - let with_opaque_pre = false in - ctx_get with_opaque_pre (TraitMethodId (id, item_name, rg_id)) ctx + ctx_get (TraitMethodId (id, item_name, rg_id)) ctx let ctx_get_trait_parent_clause (id : trait_decl_id) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - let with_opaque_pre = false in - ctx_get with_opaque_pre (TraitParentClauseId (id, clause)) ctx + ctx_get (TraitParentClauseId (id, clause)) ctx let ctx_get_trait_item_clause (id : trait_decl_id) (item : string) (clause : trait_clause_id) (ctx : extraction_ctx) : string = - let with_opaque_pre = false in - ctx_get with_opaque_pre (TraitItemClauseId (id, item, clause)) ctx + ctx_get (TraitItemClauseId (id, item, clause)) ctx let ctx_get_var (id : VarId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (VarId id) ctx + ctx_get (VarId id) ctx let ctx_get_type_var (id : TypeVarId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (TypeVarId id) ctx + ctx_get (TypeVarId id) ctx let ctx_get_const_generic_var (id : ConstGenericVarId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (ConstGenericVarId id) ctx + ctx_get (ConstGenericVarId id) ctx let ctx_get_local_trait_clause (id : TraitClauseId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (LocalTraitClauseId id) ctx + ctx_get (LocalTraitClauseId id) ctx let ctx_get_field (type_id : type_id) (field_id : FieldId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (FieldId (type_id, field_id)) ctx + ctx_get (FieldId (type_id, field_id)) ctx -let ctx_get_struct (with_opaque_pre : bool) (def_id : type_id) - (ctx : extraction_ctx) : string = - ctx_get with_opaque_pre (StructId def_id) ctx +let ctx_get_struct (def_id : type_id) (ctx : extraction_ctx) : string = + ctx_get (StructId def_id) ctx let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (VariantId (def_id, variant_id)) ctx + ctx_get (VariantId (def_id, variant_id)) ctx let ctx_get_decreases_proof (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (DecreasesProofId (Regular def_id, loop_id)) ctx + ctx_get (DecreasesProofId (Regular def_id, loop_id)) ctx let ctx_get_termination_measure (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - let is_opaque = false in - ctx_get is_opaque (TerminationMeasureId (Regular def_id, loop_id)) ctx + ctx_get (TerminationMeasureId (Regular def_id, loop_id)) ctx (** Generate a unique type variable name and add it to the context *) let ctx_add_type_var (basename : string) (id : TypeVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in let name = basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name in - let ctx = ctx_add is_opaque (TypeVarId id) name ctx in + let ctx = ctx_add (TypeVarId id) name ctx in (ctx, name) (** Generate a unique const generic variable name and add it to the context *) let ctx_add_const_generic_var (basename : string) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let name = ctx.fmt.const_generic_var_basename ctx.names_map.names_set basename in let name = basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name in - let ctx = ctx_add is_opaque (ConstGenericVarId id) name ctx in + let ctx = ctx_add (ConstGenericVarId id) name ctx in (ctx, name) (** See {!ctx_add_type_var} *) @@ -1110,31 +1012,28 @@ let ctx_add_type_vars (vars : (string * TypeVarId.id) list) (** Generate a unique variable name and add it to the context *) let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let name = basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename in - let ctx = ctx_add is_opaque (VarId id) name ctx in + let ctx = ctx_add (VarId id) name ctx in (ctx, name) (** Generate a unique variable name for the trait self clause and add it to the context *) let ctx_add_trait_self_clause (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let basename = ctx.fmt.trait_self_clause_basename in let name = basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename in - let ctx = ctx_add is_opaque TraitSelfClauseId name ctx in + let ctx = ctx_add TraitSelfClauseId name ctx in (ctx, name) (** Generate a unique trait clause name and add it to the context *) let ctx_add_local_trait_clause (basename : string) (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let is_opaque = false in let name = basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename in - let ctx = ctx_add is_opaque (LocalTraitClauseId id) name ctx in + let ctx = ctx_add (LocalTraitClauseId id) name ctx in (ctx, name) (** See {!ctx_add_var} *) @@ -1182,30 +1081,23 @@ let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - let is_opaque = false in let name = ctx.fmt.decreases_proof_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add is_opaque - (DecreasesProofId (Regular def.def_id, def.loop_id)) - name ctx + ctx_add (DecreasesProofId (Regular def.def_id, def.loop_id)) name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = - let is_opaque = false in let name = ctx.fmt.termination_measure_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add is_opaque - (TerminationMeasureId (Regular def.def_id, def.loop_id)) - name ctx + ctx_add (TerminationMeasureId (Regular def.def_id, def.loop_id)) name ctx let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = (* TODO: update once the body id can be an option *) - let is_opaque = false in let decl = GlobalId def.def_id in (* Check if the global corresponds to an assumed global that we should map @@ -1215,13 +1107,13 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : match SimpleNameMap.find_opt sname builtin_globals_map with | Some name -> (* Yes: register the custom binding *) - ctx_add is_opaque decl name ctx + ctx_add decl name ctx | None -> (* Not the case: "standard" registration *) let name = ctx.fmt.global_name def.name in let body = FunId (FromLlbc (FunId (Regular def.body_id), None, None)) in - let ctx = ctx_add is_opaque decl (name ^ "_c") ctx in - let ctx = ctx_add is_opaque body (name ^ "_body") ctx in + let ctx = ctx_add decl (name ^ "_c") ctx in + let ctx = ctx_add body (name ^ "_body") ctx in ctx let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) @@ -1259,11 +1151,10 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) let def_id = def.def_id in let { keep_fwd; fwd = _; backs } = trans_group in let num_backs = List.length backs in - 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 = (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 + let ctx = ctx_add (FunId (FromLlbc fun_id)) def_name ctx in (* Add the name info *) { ctx with @@ -1296,12 +1187,11 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = let name_to_id = StringMap.of_list (List.map (fun x -> (x, UnknownId)) keywords) in - let opaque_ids = IdSet.empty in (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. * Also note that we don't need this mapping for keywords: we insert keywords only * to check collisions. *) let id_to_name = IdMap.empty in - let nm = { id_to_name; name_to_id; names_set; opaque_ids } in + let nm = { id_to_name; name_to_id; names_set } in (* For debugging - we are creating bindings for assumed types and functions, so * it is ok if we simply use the "show" function (those aren't simply identified * by numbers) *) @@ -1338,15 +1228,8 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions in let nm = - (* In practice, the assumed function are opaque. However, assumed functions - are never grouped in the opaque module, meaning we never need to - prefix them: we thus consider them as non-opaque with regards to the - names map. - *) - let is_opaque = false in List.fold_left - (fun nm (fid, name) -> - names_map_add_function id_to_string is_opaque fid name nm) + (fun nm (fid, name) -> names_map_add_function id_to_string fid name nm) nm assumed_functions in (* Return *) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 74a8537f..b3269aa2 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -851,37 +851,10 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if config.extract_state_type && config.extract_fun_decls then export_state_type (); - (* Obsolete: (TODO: remove) For Lean we parameterize the entire development by a section - variable called opaque_defs, of type OpaqueDefs. The code below emits the type - definition for OpaqueDefs, which is a structure, in which each field is one of the - functions marked as Opaque. We emit the `structure ...` bit here, then rely on - `extract_fun_decl` to be aware of this, and skip the keyword (e.g. "axiom" or "val") - so as to generate valid syntax for records. - - We also generate such a structure only if there actually are opaque definitions. *) - let wrap_in_sig = - config.extract_opaque && config.extract_fun_decls - && !Config.wrap_opaque_in_sig - && - let _, opaque_funs = crate_has_opaque_decls ctx true in - opaque_funs - in - if wrap_in_sig then ( - (* We change the name of the structure depending on whether we *only* - extract opaque definitions, or if we extract all definitions *) - let struct_name = - if config.extract_transparent then "Definitions" else "OpaqueDefs" - in - Format.pp_print_break fmt 0 0; - Format.pp_open_vbox fmt ctx.indent_incr; - Format.pp_print_string fmt ("structure " ^ struct_name ^ " where"); - Format.pp_print_break fmt 0 0); List.iter export_decl_group ctx.crate.declarations; if config.extract_state_type && not config.extract_fun_decls then - export_state_type (); - - if wrap_in_sig then Format.pp_close_box fmt () + export_state_type () type extract_file_info = { filename : string; @@ -1029,10 +1002,9 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (fun (id, _) -> strict_collisions id) (IdMap.bindings names_map.id_to_name) in - let is_opaque = false in List.fold_left (* id_to_string: we shouldn't need to use it *) - (fun m (id, n) -> names_map_add show_id is_opaque id n m) + (fun m (id, n) -> names_map_add show_id id n m) empty_names_map ids in @@ -1093,7 +1065,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : strict_names_map; fmt; indent_incr = 2; - use_opaque_pre = !Config.split_files; use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; fun_name_info = PureUtils.RegularFunIdMap.empty; trait_decl_id = None (* None by default *); @@ -1389,7 +1360,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : interface = true; } in - let ctx = { ctx with use_opaque_pre = false } in let file_info = { filename = opaque_filename; -- cgit v1.2.3 From 9ddd174959970f87658191034b70d0cfa02ff451 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 15:49:54 +0200 Subject: Filter some type arguments for the builtin types/functions --- compiler/Extract.ml | 67 ++++++++++++++++++++++++++++++++++++++++++++-- compiler/ExtractBase.ml | 13 +++++++++ compiler/ExtractBuiltin.ml | 15 +++++------ compiler/Translate.ml | 2 ++ 4 files changed, 87 insertions(+), 10 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 275cb3b9..bf90a411 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1175,6 +1175,26 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (* TODO: for now, only the opaque *functions* are extracted in the opaque module. The opaque *types* are assumed. *) F.pp_print_string fmt (ctx_get_type type_id ctx); + (* We might need to filter the type arguments, if the type + is builtin (for instance, we filter the global allocator type + argument for `Vec`). *) + let generics = + match type_id with + | AdtId id -> ( + match + TypeDeclId.Map.find_opt id ctx.types_filter_type_args_map + with + | None -> generics + | Some filter -> + let types = List.combine filter generics.types in + let types = + List.filter_map + (fun (b, ty) -> if b then Some ty else None) + types + in + { generics with types }) + | _ -> generics + in extract_generic_args ctx fmt no_params_tys generics; if print_paren then F.pp_print_string fmt ")" | HOL4 -> @@ -1335,6 +1355,17 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let open ExtractBuiltin in let sname = name_to_simple_name def.name in let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in + (* Register the filtering information, if there is *) + let ctx = + match info with + | Some { keep_params = Some keep; _ } -> + { + ctx with + types_filter_type_args_map = + TypeDeclId.Map.add def.def_id keep ctx.types_filter_type_args_map; + } + | _ -> ctx + in (* Compute and register the type def name *) let def_name = match info with @@ -2361,7 +2392,19 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) in (* Use the builtin names if necessary *) match builtin with - | Some (_filter, info) -> + | Some (filter_info, info) -> + (* Register the filtering information, if there is *) + let ctx = + match filter_info with + | Some keep -> + { + ctx with + funs_filter_type_args_map = + FunDeclId.Map.add def.fwd.f.def_id keep + ctx.funs_filter_type_args_map; + } + | _ -> ctx + in let backs = List.map (fun f -> f.f) def.backs in let funs = if def.keep_fwd then def.fwd.f :: backs else backs in List.fold_left @@ -2734,7 +2777,27 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (* Sanity check: HOL4 doesn't support const generics *) assert (generics.const_generics = [] || !backend <> HOL4); - (* Print the generics *) + (* Print the generics. + + We might need to filter some of the type arguments, if the type + is builtin (for instance, we filter the global allocator type + argument for `Vec::new`). + *) + let generics = + match fun_id with + | FromLlbc (FunId (Regular id), _, _) -> ( + match FunDeclId.Map.find_opt id ctx.funs_filter_type_args_map with + | None -> generics + | Some filter -> + let types = List.combine filter generics.types in + let types = + List.filter_map + (fun (b, ty) -> if b then Some ty else None) + types + in + { generics with types }) + | _ -> generics + in extract_generic_args ctx fmt TypeDeclId.Set.empty generics; (* Print the arguments *) List.iter diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index f26beeb6..e004aba8 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -640,6 +640,19 @@ type extraction_ctx = { functions_with_decreases_clause : PureUtils.FunLoopIdSet.t; trans_trait_decls : Pure.trait_decl Pure.TraitDeclId.Map.t; trans_trait_impls : Pure.trait_impl Pure.TraitImplId.Map.t; + types_filter_type_args_map : bool list TypeDeclId.Map.t; + (** The map to filter the type arguments for the builtin type + definitions. + + We need this for type `Vec`, for instance, which takes a useless + (in the context of the type translation) type argument for the + allocator which is used, and which we want to remove. + + TODO: it would be cleaner to filter those types in a micro-pass, + rather than at code generation time. + *) + funs_filter_type_args_map : bool list FunDeclId.Map.t; + (** Same as {!types_filter_type_args_map}, but for functions *) } (** Debugging function, used when communicating name collisions to the user, diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index d3cea54e..65c18efd 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -203,9 +203,8 @@ type builtin_fun_info = { let builtin_funs () : (string list * bool list option * builtin_fun_info list) list = let rg0 = Some Types.RegionGroupId.zero in - (* TODO: fix the names below *) [ - ( [ "core::mem::replace" ], + ( [ "core"; "mem"; "replace" ], None, [ { @@ -223,7 +222,7 @@ let builtin_funs () : | Lean -> "mem.replace_back"); }; ] ); - ( [ "alloc::vec::Vec::new" ], + ( [ "alloc"; "vec"; "Vec"; "new" ], Some [ true; false ], [ { @@ -241,7 +240,7 @@ let builtin_funs () : | Lean -> "Vec.new_back"); }; ] ); - ( [ "alloc::vec::Vec::push" ], + ( [ "alloc"; "vec"; "Vec"; "push" ], Some [ true; false ], [ (* The forward function shouldn't be used *) @@ -260,7 +259,7 @@ let builtin_funs () : | Lean -> "Vec.push"); }; ] ); - ( [ "alloc::vec::Vec::insert" ], + ( [ "alloc"; "vec"; "Vec"; "insert" ], Some [ true; false ], [ (* The forward function shouldn't be used *) @@ -279,7 +278,7 @@ let builtin_funs () : | Lean -> "Vec.insert"); }; ] ); - ( [ "alloc::vec::Vec::len" ], + ( [ "alloc"; "vec"; "Vec"; "len" ], Some [ true; false ], [ { @@ -290,7 +289,7 @@ let builtin_funs () : | Lean -> "Vec.len"); }; ] ); - ( [ "alloc::vec::Vec::index" ], + ( [ "alloc"; "vec"; "Vec"; "index" ], Some [ true; false ], [ { @@ -309,7 +308,7 @@ let builtin_funs () : | Lean -> "Vec.index_shared_back"); }; ] ); - ( [ "alloc::vec::Vec::index_mut" ], + ( [ "alloc"; "vec"; "Vec"; "index_mut" ], Some [ true; false ], [ { diff --git a/compiler/Translate.ml b/compiler/Translate.ml index b3269aa2..35dff9e6 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -1074,6 +1074,8 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : trans_types; trans_funs; functions_with_decreases_clause = rec_functions; + types_filter_type_args_map = Pure.TypeDeclId.Map.empty; + funs_filter_type_args_map = Pure.FunDeclId.Map.empty; } in -- cgit v1.2.3 From b2cbbb48494e8079eb000293e7734850e4ce3d05 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 16:15:38 +0200 Subject: Fix a printing issue with scalar values --- compiler/Extract.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index bf90a411..0260b78b 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -862,10 +862,12 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) (* We need to add parentheses if the value is negative *) if sv.PV.value >= Z.of_int 0 then F.pp_print_string fmt (Z.to_string sv.PV.value) - else + else if !backend = Lean then + (* TODO: parsing issues with Lean because there are ambiguous + interpretations between int values and nat values *) F.pp_print_string fmt - ("(" ^ Z.to_string sv.PV.value - ^ if !backend = Lean then ":Int" else "" ^ ")"); + ("(-(" ^ Z.to_string (Z.neg sv.PV.value) ^ ":Int))") + else F.pp_print_string fmt ("(" ^ Z.to_string sv.PV.value ^ ")"); (match !backend with | Coq -> let iname = int_name sv.PV.int_ty in -- cgit v1.2.3 From ce4de37c76d85ed7795f4938cf212abd31668007 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 16:15:53 +0200 Subject: Fix an issue coming from the modification for the opaque signatures --- compiler/Extract.ml | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 0260b78b..b1c65be9 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -3674,18 +3674,13 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) let use_forall = is_opaque_coq && def.signature.generics <> empty_generic_params in - (* Print the qualifier ("assume", etc.). - - if `wrap_opaque_in_sig`: we generate a record of assumed funcions. - TODO: this is obsolete. - *) - (if not (kind = Assumed || kind = Declared) then - let qualif = ctx.fmt.fun_decl_kind_to_qualif kind in - match qualif with - | Some qualif -> - F.pp_print_string fmt qualif; - F.pp_print_space fmt () - | None -> ()); + (* Print the qualifier ("assume", etc.). *) + let qualif = ctx.fmt.fun_decl_kind_to_qualif kind in + (match qualif with + | Some qualif -> + F.pp_print_string fmt qualif; + F.pp_print_space fmt () + | None -> ()); F.pp_print_string fmt def_name; F.pp_print_space fmt (); if use_forall then ( -- cgit v1.2.3 From fb4fe9ec2c00f15a745ee12357e4a8f929a4dfc0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 16:43:00 +0200 Subject: Fix minor issues --- compiler/ExtractBuiltin.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 65c18efd..2e46b120 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -211,15 +211,15 @@ let builtin_funs () : rg = None; extract_name = (match !backend with - | FStar | Coq | HOL4 -> "mem_replace_fwd" - | Lean -> "mem.replace"); + | FStar | Coq | HOL4 -> "core_mem_replace_fwd" + | Lean -> "core.mem.replace"); }; { rg = rg0; extract_name = (match !backend with - | FStar | Coq | HOL4 -> "mem_replace_back" - | Lean -> "mem.replace_back"); + | FStar | Coq | HOL4 -> "core_mem_replace_back" + | Lean -> "core.mem.replace_back"); }; ] ); ( [ "alloc"; "vec"; "Vec"; "new" ], -- cgit v1.2.3 From 6eebc66e34561bc6985b5866d49c8314a6fbaee9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 17:47:39 +0200 Subject: Start taking into account non-fallible functions like core::mem::replace --- compiler/ExtractBuiltin.ml | 8 ++++++++ compiler/PureMicroPasses.ml | 12 +++++++----- 2 files changed, 15 insertions(+), 5 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 2e46b120..9cc7c226 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -29,6 +29,7 @@ module SimpleNameOrd = struct end module SimpleNameMap = Collections.MakeMap (SimpleNameOrd) +module SimpleNameSet = Collections.MakeSet (SimpleNameOrd) (** Small utility to memoize some computations *) let mk_memoized (f : unit -> 'a) : unit -> 'a = @@ -374,6 +375,13 @@ let mk_builtin_funs_map () = let builtin_funs_map = mk_memoized mk_builtin_funs_map +let builtin_non_fallible_funs = + [ "alloc::boxed::Box::deref"; "alloc::boxed::Box::deref_mut" ] + +let builtin_non_fallible_funs_set = + SimpleNameSet.of_list + (List.map string_to_simple_name builtin_non_fallible_funs) + type builtin_trait_decl_info = { rust_name : string; extract_name : string; diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index a326d19e..f3e6cbe2 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1544,20 +1544,22 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = | Fun (FromLlbc (FunId (Regular fid), _lp_id, rg_id)) -> ( (* Lookup the function name *) let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in - match (Names.name_to_string def.name, rg_id) with - | "alloc::box::Boxed::deref", None -> + match + (Names.name_no_disambiguators_to_string def.name, rg_id) + with + | "alloc::boxed::Box::deref", None -> (* [Box::deref] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | "alloc::box::Boxed::deref", Some _ -> + | "alloc::boxed::Box::deref", Some _ -> (* [Box::deref] backward is [()] (doesn't give back anything) *) assert (args = []); mk_unit_rvalue - | "alloc::box::Boxed::deref_mut", None -> + | "alloc::boxed::Box::deref_mut", None -> (* [Box::deref_mut] forward is the identity *) let arg, args = Collections.List.pop args in mk_apps arg args - | "alloc::box::Boxed::deref_mut", Some _ -> + | "alloc::boxed::Box::deref_mut", Some _ -> (* [Box::deref_mut] back is almost the identity: * let box_deref_mut (x_init : t) (x_back : t) : t = x_back * *) -- cgit v1.2.3 From 9c230dddebb171ee1b3e0176838441163836b875 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 18:16:53 +0200 Subject: Handle properly the builtin, non fallible functions --- compiler/ExtractBase.ml | 4 ++-- compiler/ExtractBuiltin.ml | 34 +++++++++++++++++++++++++++++++++- compiler/FunsAnalysis.ml | 34 +++++++++++++++++++--------------- 3 files changed, 54 insertions(+), 18 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index e004aba8..8f32ba44 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -22,8 +22,8 @@ type region_group_info = { *) } -module StringSet = Collections.MakeSet (Collections.OrderedString) -module StringMap = Collections.MakeMap (Collections.OrderedString) +module StringSet = Collections.StringSet +module StringMap = Collections.StringMap type name = Names.name type type_name = Names.type_name diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 9cc7c226..4c6fe014 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -376,7 +376,39 @@ let mk_builtin_funs_map () = let builtin_funs_map = mk_memoized mk_builtin_funs_map let builtin_non_fallible_funs = - [ "alloc::boxed::Box::deref"; "alloc::boxed::Box::deref_mut" ] + let int_names = + [ + "usize"; + "u8"; + "u16"; + "u32"; + "u64"; + "u128"; + "isize"; + "i8"; + "i16"; + "i32"; + "i64"; + "i128"; + ] + in + let int_ops = + [ "wrapping_add"; "wrapping_sub"; "rotate_left"; "rotate_right" ] + in + let int_funs = + List.map + (fun int_name -> + List.map (fun op -> "core::num::" ^ int_name ^ "::" ^ op) int_ops) + int_names + in + let int_funs = List.concat int_funs in + [ + "alloc::boxed::Box::deref"; + "alloc::boxed::Box::deref_mut"; + "core::mem::replace"; + "core::mem::take"; + ] + @ int_funs let builtin_non_fallible_funs_set = SimpleNameSet.of_list diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 1273f57d..3ba5d35d 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -57,21 +57,16 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let stateful = ref false in let can_diverge = ref false in let is_rec = ref false in + let is_builtin_non_fallible_group = ref false in (* We have some specialized knowledge of some library functions; we don't have any more custom treatment than this, and these functions can be modeled suitably in Primitives.fst, rather than special-casing for them all the way. *) - let module M = struct type opaque_info = { fallible: bool; stateful: bool } end in - let open M in - let opaque_info (f: fun_decl) = - match f.name with - | [ Ident "core"; Ident "num"; Ident "u32"; _; Ident "wrapping_add" ] - | [ Ident "core"; Ident "num"; Ident "u32"; _; Ident "rotate_left" ] -> - { fallible = false; stateful = false } - | _ -> - (* Opaque function: we consider they fail by default *) - { fallible = true; stateful = true } + let is_builtin_non_fallible (f : fun_decl) : bool = + let open ExtractBuiltin in + let name = name_to_simple_name f.name in + SimpleNameSet.mem name builtin_non_fallible_funs_set in (* JP: Why not use a reduce visitor here with a tuple of the values to be @@ -124,11 +119,16 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) in (* Sanity check: global bodies don't contain stateful calls *) assert ((not f.is_global_decl_body) || not !stateful); + let is_builtin_non_fallible = is_builtin_non_fallible f in + is_builtin_non_fallible_group := + !is_builtin_non_fallible_group || is_builtin_non_fallible; match f.body with | None -> - let info = opaque_info f in - obj#may_fail info.fallible; - stateful := (not f.is_global_decl_body) && use_state && info.stateful + obj#may_fail (not is_builtin_non_fallible); + stateful := + (not f.is_global_decl_body) + && use_state + && not is_builtin_non_fallible | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; @@ -136,12 +136,16 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in assert ((not is_global_decl_body) || List.length d = 1); + assert ((not !is_builtin_non_fallible_group) || List.length d = 1); (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. - * However, we do keep the result of the analysis for global bodies. + * However, we do keep the result of the analysis for global bodies and for + * builtin functions which are marked as non-fallible. * *) - can_fail := (not is_global_decl_body) || !can_fail; + can_fail := + ((not is_global_decl_body) && not !is_builtin_non_fallible_group) + || !can_fail; { can_fail = !can_fail; stateful = !stateful; -- cgit v1.2.3 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') 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.2.3 From 4f507fa565a43b419af6ea7a641a353f62213b21 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 11:40:47 +0200 Subject: Remove the warning for loops --- compiler/Driver.ml | 8 -------- 1 file changed, 8 deletions(-) (limited to 'compiler') diff --git a/compiler/Driver.ml b/compiler/Driver.ml index 414b042d..3b9ea4d1 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -214,14 +214,6 @@ let () = log#linfo (lazy ("Imported: " ^ filename)); log#ldebug (lazy ("\n" ^ Print.Crate.crate_to_string m ^ "\n")); - (* Print a warning if the crate contains loops (loops are experimental for now) *) - let has_loops = - A.FunDeclId.Map.exists - (fun _ -> Aeneas.LlbcAstUtils.fun_decl_has_loops) - m.functions - in - if has_loops then log#lwarning (lazy "Support for loops is experimental"); - (* We don't support mutually recursive definitions with decreases clauses in Lean *) if !backend = Lean && !extract_decreases_clauses -- cgit v1.2.3 From a41299c8543fe12f98ae2554bc9cefca6990af5f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 12:06:21 +0200 Subject: Fix some issues to make the array test succeed again --- compiler/AssociatedTypes.ml | 39 ++++++++++++++++++++++++++++++++------- compiler/SymbolicToPure.ml | 21 ++++++++++++--------- 2 files changed, 44 insertions(+), 16 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 022aad2f..94e08996 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -171,6 +171,8 @@ type 'r norm_ctx = { convert_ety : T.ety -> 'r T.ty; convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; ty_to_string : 'r T.ty -> string; + generic_params_to_string : T.generic_params -> string; + generic_args_to_string : 'r T.generic_args -> string; trait_ref_to_string : 'r T.trait_ref -> string; trait_instance_id_to_string : 'r T.trait_instance_id -> string; pp_r : Format.formatter -> 'r -> unit; @@ -188,6 +190,9 @@ 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) + | RawPtr (ty, rkind) -> + let ty = ctx_normalize_ty ctx ty in + RawPtr (ty, rkind) | Arrow (inputs, output) -> let inputs = List.map (ctx_normalize_ty ctx) inputs in let output = ctx_normalize_ty ctx output in @@ -195,14 +200,18 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = | TraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy - ("ctx_normalize_ty: trait type: " ^ ctx.ty_to_string ty + ("ctx_normalize_ty:\n- trait type: " ^ ctx.ty_to_string ty ^ "\n- trait_ref: " ^ ctx.trait_ref_to_string trait_ref ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r trait_ref)); + ^ T.show_trait_ref ctx.pp_r trait_ref + ^ "\n- generics:\n" + ^ ctx.generic_args_to_string generics)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = ctx_normalize_trait_ref ctx trait_ref in let generics = ctx_normalize_generic_args ctx generics in + (* For now, we don't support higher order types *) + assert (generics = TypesUtils.mk_empty_generic_args); let ty : 'r T.ty = match trait_ref.trait_id with | T.TraitRef @@ -216,13 +225,13 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* Lookup the type *) let ty = snd (List.assoc type_name trait_impl.types) in - (* Annoying: convert etype to an stype - TODO: hwo to avoid that? *) + (* Annoying: convert etype to an stype - TODO: how to avoid that? *) let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in (* Substitute *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = Subst.make_subst_from_generics_no_regions trait_impl.generics - generics tr_self + trait_ref.generics tr_self in let ty = Subst.ty_substitute subst ty in (* Reconvert *) @@ -230,7 +239,14 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = (* Normalize *) ctx_normalize_ty ctx ty | T.TraitImpl impl_id -> - (* This happens. This doesn't come from the substituations + log#ldebug + (lazy + ("ctx_normalize_ty (trait impl):\n- trait type: " + ^ ctx.ty_to_string ty ^ "\n- trait_ref: " + ^ ctx.trait_ref_to_string trait_ref + ^ "\n- raw trait ref:\n" + ^ T.show_trait_ref ctx.pp_r trait_ref)); + (* This happens. This doesn't come from the substitutions performed by Aeneas (the [TraitImpl] would be wrapped in a [TraitRef] but from non-normalized traits translated from the Rustc AST. @@ -240,13 +256,13 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* Lookup the type *) let ty = snd (List.assoc type_name trait_impl.types) in - (* Annoying: convert etype to an stype - TODO: hwo to avoid that? *) + (* Annoying: convert etype to an stype - TODO: how to avoid that? *) let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in (* Substitute *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = Subst.make_subst_from_generics_no_regions trait_impl.generics - generics tr_self + trait_ref.generics tr_self in let ty = Subst.ty_substitute subst ty in (* Reconvert *) @@ -465,6 +481,9 @@ let ctx_normalize_trait_type_constraint (ctx : 'r norm_ctx) let ty = ctx_normalize_ty ctx ty in { T.trait_ref; generics; type_name; ty } +let generic_params_to_string ctx x = + "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx x)) ^ ">" + let mk_snorm_ctx (ctx : C.eval_ctx) : T.RegionVarId.id T.region norm_ctx = let get_ty_repr x = C.STraitTypeRefMap.find_opt x ctx.norm_trait_stypes in { @@ -473,6 +492,8 @@ let mk_snorm_ctx (ctx : C.eval_ctx) : T.RegionVarId.id T.region norm_ctx = convert_ety = TypesUtils.ety_no_regions_to_sty; convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; ty_to_string = PA.sty_to_string ctx; + generic_params_to_string = generic_params_to_string ctx; + generic_args_to_string = PA.sgeneric_args_to_string ctx; trait_ref_to_string = PA.strait_ref_to_string ctx; trait_instance_id_to_string = PA.strait_instance_id_to_string ctx; pp_r = T.pp_region T.pp_region_var_id; @@ -486,6 +507,8 @@ let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = convert_ety = TypesUtils.ety_no_regions_to_rty; convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; ty_to_string = PA.rty_to_string ctx; + generic_params_to_string = generic_params_to_string ctx; + generic_args_to_string = PA.rgeneric_args_to_string ctx; trait_ref_to_string = PA.rtrait_ref_to_string ctx; trait_instance_id_to_string = PA.rtrait_instance_id_to_string ctx; pp_r = T.pp_region T.pp_region_id; @@ -499,6 +522,8 @@ let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = convert_ety = (fun x -> x); convert_etrait_ref = (fun x -> x); ty_to_string = PA.ety_to_string ctx; + generic_params_to_string = generic_params_to_string ctx; + generic_args_to_string = PA.egeneric_args_to_string ctx; trait_ref_to_string = PA.etrait_ref_to_string ctx; trait_instance_id_to_string = PA.etrait_instance_id_to_string ctx; pp_r = T.pp_erased_region; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 4ba5296f..885d2ba5 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -534,12 +534,6 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = (* Eliminate boxes and simplify tuples *) match type_id with | AdtId _ | T.Assumed (T.Array | T.Slice | T.Str) -> - (* No general parametricity for now *) - assert ( - not - (List.exists - (TypesUtils.ty_has_borrows type_infos) - generics.types)); let type_id = translate_type_id type_id in Adt (type_id, t_generics) | Tuple -> @@ -614,15 +608,24 @@ let rec translate_back_ty (type_infos : TA.type_infos) | T.Adt (type_id, generics) -> ( match type_id with | T.AdtId _ | Assumed (T.Array | T.Slice | T.Str) -> - (* Don't accept ADTs (which are not tuples) with borrows for now *) - assert (not (TypesUtils.ty_has_borrows type_infos ty)); let type_id = translate_type_id type_id in if inside_mut then (* We do not want to filter anything, so we translate the generics as "forward" types *) let generics = translate_fwd_generic_args type_infos generics in Some (Adt (type_id, generics)) - else None + else + (* If not inside a mutable reference: check if at least one + of the generics contains a mutable reference (i.e., is not + translated to `None`. If yes, keep the whole type, and + translate all the generics as "forward" types (the backward + function will extract the proper information from the ADT value) + *) + let types = List.filter_map translate generics.types in + if types <> [] then + let generics = translate_fwd_generic_args type_infos generics in + Some (Adt (type_id, generics)) + else None | Assumed T.Box -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); -- cgit v1.2.3 From e3cb3646bbe3d50240aa0bf4763f8e816fb9a706 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 15:36:06 +0200 Subject: Fix some issues at extraction and add builtins --- compiler/Extract.ml | 45 ++++--- compiler/ExtractBuiltin.ml | 304 ++++++++++++++++++++++++++++++++++++++++++++- compiler/LlbcAstUtils.ml | 19 ++- compiler/Translate.ml | 10 +- 4 files changed, 340 insertions(+), 38 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index afd722e5..6b6a2686 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -234,26 +234,20 @@ let assumed_adts () : (assumed_ty * string) list = (Array, "Array"); (Slice, "Slice"); (Str, "Str"); + (RawPtr Mut, "MutRawPtr"); + (RawPtr Const, "ConstRawPtr"); ] - | Coq | FStar -> + | Coq | FStar | HOL4 -> [ (State, "state"); (Result, "result"); (Error, "error"); - (Fuel, "nat"); - (Array, "array"); - (Slice, "slice"); - (Str, "str"); - ] - | HOL4 -> - [ - (State, "state"); - (Result, "result"); - (Error, "error"); - (Fuel, "num"); + (Fuel, if !backend = HOL4 then "num" else "nat"); (Array, "array"); (Slice, "slice"); (Str, "str"); + (RawPtr Mut, "mut_raw_ptr"); + (RawPtr Const, "const_raw_ptr"); ] let assumed_struct_constructors () : (assumed_ty * string) list = @@ -1378,7 +1372,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let def_name = match info with | None -> ctx.fmt.type_name def.name - | Some info -> String.concat "." info.rust_name + | Some info -> info.extract_name in let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in (* Compute and register: @@ -4281,16 +4275,9 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) string * (RegionGroupId.id option * string) list = let compute_fun_name (f : fun_decl) : RegionGroupId.id option * string = - (* We do something special: we use the base name but remove everything - but the crate (because [get_name] removes it) and the last ident. - This allows us to reuse the [ctx_compute_fun_decl] function. - *) - let basename : name = - match (f.basename : name) with - | Ident crate :: name -> - Ident crate :: [ Collections.List.last name ] - | _ -> raise (Failure "Unexpected") - in + (* We do something special to reuse the [ctx_compute_fun_decl] + function. TODO: make it cleaner. *) + let basename : name = [ Ident item_name ] in let f = { f with basename } in let trans = A.FunDeclId.Map.find f.def_id ctx.trans_funs in let name = ctx_compute_fun_name trans f ctx in @@ -4503,6 +4490,17 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) extract_generic_params ctx fmt TypeDeclId.Set.empty generics type_params cg_params trait_clauses; + (* Add the parent clauses as local clauses, so that we can refer to them *) + let ctx = + List.fold_left + (fun ctx clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + ctx_add (LocalTraitClauseId clause.clause_id) item_name ctx) + ctx decl.generics.trait_clauses + in + F.pp_print_space fmt (); (match !backend with | Lean -> F.pp_print_string fmt "where" @@ -4522,6 +4520,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx in let ty () = + F.pp_print_space fmt (); extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 4c6fe014..c781463e 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -121,7 +121,7 @@ let builtin_types () : builtin_type_info list = rust_name = [ "alloc"; "alloc"; "Global" ]; extract_name = (match !backend with - | Lean -> "AllocGlobal" + | Lean -> "alloc.alloc.Global" | Coq | FStar | HOL4 -> "alloc_global"); keep_params = None; body_info = None; @@ -335,7 +335,7 @@ let builtin_funs () : rg = None; extract_name = (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_box_deref" + | FStar | Coq | HOL4 -> "alloc_boxed_Box_deref" | Lean -> "alloc.boxed.Box.deref"); }; (* The backward function shouldn't be used *) @@ -343,7 +343,7 @@ let builtin_funs () : rg = rg0; extract_name = (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_box_deref_back" + | FStar | Coq | HOL4 -> "alloc_boxed_Box_deref_back" | Lean -> "alloc.boxed.Box.deref_back"); }; ] ); @@ -354,7 +354,7 @@ let builtin_funs () : rg = None; extract_name = (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_box_deref_mut" + | FStar | Coq | HOL4 -> "alloc_boxed_Box_deref_mut" | Lean -> "alloc.boxed.Box.deref_mut"); }; { @@ -365,6 +365,179 @@ let builtin_funs () : | Lean -> "alloc.boxed.Box.deref_mut_back"); }; ] ); + (* TODO: fix the same like "[T]" below *) + ( [ "core"; "slice"; "index"; "[T]"; "index" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Slice_index" + | Lean -> "core.slice.index.Slice.index"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Slice_index_back" + | Lean -> "core.slice.index.Slice.index_back"); + }; + ] ); + ( [ "core"; "slice"; "index"; "[T]"; "index_mut" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Slice_index_mut" + | Lean -> "core.slice.index.Slice.index_mut"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Slice_index_mut_back" + | Lean -> "core.slice.index.Slice.index_mut_back"); + }; + ] ); + ( [ "core"; "array"; "[T; N]"; "index" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_array_Array_index" + | Lean -> "core.array.Array.index"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_array_Array_index_back" + | Lean -> "core.array.Array.index_back"); + }; + ] ); + ( [ "core"; "array"; "[T; N]"; "index_mut" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_array_Array_index_mut" + | Lean -> "core.array.Array.index_mut"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_array_Array_index_mut_back" + | Lean -> "core.array.Array.index_mut_back"); + }; + ] ); + ( [ "core"; "slice"; "index"; "Range"; "get" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_get" + | Lean -> "core.slice.index.Range.get"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_get_back" + | Lean -> "core.slice.index.Range.get_back"); + }; + ] ); + ( [ "core"; "slice"; "index"; "Range"; "get_mut" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_get_mut" + | Lean -> "core.slice.index.Range.get_mut"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_get_mut_back" + | Lean -> "core.slice.index.Range.get_mut_back"); + }; + ] ); + ( [ "core"; "slice"; "index"; "Range"; "index" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_index" + | Lean -> "core.slice.index.Range.index"); + }; + (* The backward function shouldn't be used *) + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_index_back" + | Lean -> "core.slice.index.Range.index_back"); + }; + ] ); + ( [ "core"; "slice"; "index"; "Range"; "index_mut" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_index_mut" + | Lean -> "core.slice.index.Range.index_mut"); + }; + { + rg = rg0; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_index_mut_back" + | Lean -> "core.slice.index.Range.index_mut_back"); + }; + ] ); + ( [ "core"; "slice"; "index"; "Range"; "get_unchecked" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_get_unchecked" + | Lean -> "core.slice.index.Range.get_unchecked"); + }; + ] ); + ( [ "core"; "slice"; "index"; "Range"; "get_unchecked_mut" ], + None, + [ + { + rg = None; + extract_name = + (match !backend with + | FStar | Coq | HOL4 -> "core_slice_index_Range_get_unchecked_mut" + | Lean -> "core.slice.index.Range.get_unchecked_mut"); + }; + ] ); ] let mk_builtin_funs_map () = @@ -528,7 +701,7 @@ let builtin_trait_decls_info () = [ (match !backend with | Coq | FStar | HOL4 -> "index_inst" - | Lean -> "IndexInst"); + | Lean -> "indexInst"); ]; consts = []; types = []; @@ -547,6 +720,104 @@ let builtin_trait_decls_info () = ] ); ]; }; + { + (* Sealed *) + rust_name = "core::slice::index::private_slice_index::Sealed"; + extract_name = + (match !backend with + | Coq | FStar | HOL4 -> "core_slice_index_sealed" + | Lean -> "core.slice.index.private_slice_index.Sealed"); + parent_clauses = []; + consts = []; + types = []; + funs = []; + }; + { + (* SliceIndex *) + rust_name = "core::slice::index::SliceIndex"; + extract_name = + (match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex" + | Lean -> "core.slice.index.SliceIndex"); + parent_clauses = + [ + (match !backend with + | Coq | FStar | HOL4 -> "sealed_inst" + | Lean -> "sealedInst"); + ]; + consts = []; + types = + [ + ( "Output", + ( (match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_Output" + | Lean -> "Output"), + [] ) ); + ]; + funs = + [ + ( "get", + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_get" + | Lean -> "get" ); + (* The backward function shouldn't be used *) + ( rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_get_back" + | Lean -> "get_back" ); + ] ); + ( "get_mut", + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_get_mut" + | Lean -> "get_mut" ); + ( rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_get_mut_back" + | Lean -> "get_mut_back" ); + ] ); + ( "get_unchecked", + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_get_unchecked" + | Lean -> "get_unchecked" ); + ] ); + ( "get_unchecked_mut", + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_get_unchecked_mut" + | Lean -> "get_unchecked_mut" ); + ] ); + ( "index", + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_index" + | Lean -> "index" ); + (* The backward function shouldn't be used *) + ( rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_index_back" + | Lean -> "index_back" ); + ] ); + ( "index_mut", + [ + ( None, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_index_mut" + | Lean -> "index_mut" ); + ( rg0, + match !backend with + | Coq | FStar | HOL4 -> "core_SliceIndex_index_mut_back" + | Lean -> "index_mut_back" ); + ] ); + ]; + }; ] let mk_builtin_trait_decls_map () = @@ -577,6 +848,7 @@ end module SimpleNamePairMap = Collections.MakeMap (SimpleNamePairOrd) let builtin_trait_impls_info () : ((string list * string list) * string) list = + (* TODO: fix the names like "[T]" below *) [ (* core::ops::Deref> *) ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "Deref" ]), @@ -584,6 +856,28 @@ let builtin_trait_impls_info () : ((string list * string list) * string) list = (* core::ops::DerefMut> *) ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "DerefMut" ]), "alloc.boxed.Box.coreOpsDerefMutInst" ); + (* core::ops::index::Index<[T], I> *) + ( ([ "core"; "slice"; "index"; "[T]" ], [ "core"; "ops"; "index"; "Index" ]), + "core.slice.index.Slice.coreopsindexIndexInst" ); + (* core::slice::index::private_slice_index::Sealed> *) + ( ( [ "core"; "slice"; "index"; "private_slice_index"; "Range" ], + [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] ), + "core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst" + ); + (* core::slice::index::SliceIndex, [T]> *) + ( ( [ "core"; "slice"; "index"; "Range" ], + [ "core"; "slice"; "index"; "SliceIndex" ] ), + "core.slice.index.Range.coresliceindexSliceIndexInst" ); + (* core::ops::index::IndexMut<[T], I> *) + ( ( [ "core"; "slice"; "index"; "[T]" ], + [ "core"; "ops"; "index"; "IndexMut" ] ), + "core.slice.index.Slice.coreopsindexIndexMutInst" ); + (* core::ops::index::Index<[T; N], I> *) + ( ([ "core"; "array"; "[T; N]" ], [ "core"; "ops"; "index"; "Index" ]), + "core.array.Array.coreopsindexIndexInst" ); + (* core::ops::index::IndexMut<[T; N], I> *) + ( ([ "core"; "array"; "[T; N]" ], [ "core"; "ops"; "index"; "IndexMut" ]), + "core.array.Array.coreopsindexIndexMutInst" ); ] let mk_builtin_trait_impls_map () = diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 2553127a..0ab4ed94 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -13,14 +13,14 @@ let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : | Regular id -> (FunDeclId.Map.find id fun_decls).name | Assumed aid -> Assumed.get_assumed_fun_name aid -(** Return the opaque declarations found in the crate. +(** Return the opaque declarations found in the crate, which are also *not builtin*. [filter_assumed]: if [true], do not consider as opaque the external definitions that we will map to definitions from the standard library. Remark: the list of functions also contains the list of opaque global bodies. *) -let crate_get_opaque_decls (k : crate) (filter_assumed : bool) : +let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : T.type_decl list * fun_decl list = let open ExtractBuiltin in let is_opaque_fun (d : fun_decl) : bool = @@ -30,14 +30,21 @@ let crate_get_opaque_decls (k : crate) (filter_assumed : bool) : (which don't have a body but must not be considered as opaque) *) && (match d.kind with TraitMethodDecl _ -> false | _ -> true) && ((not filter_assumed) - || not (SimpleNameMap.mem sname builtin_globals_map)) + || (not (SimpleNameMap.mem sname builtin_globals_map)) + && not (SimpleNameMap.mem sname (builtin_funs_map ()))) + in + let is_opaque_type (d : T.type_decl) : bool = + let sname = name_to_simple_name d.name in + d.kind = T.Opaque + && ((not filter_assumed) + || not (SimpleNameMap.mem sname (builtin_types_map ()))) in - let is_opaque_type (d : T.type_decl) : bool = d.kind = T.Opaque in (* Note that by checking the function bodies we also the globals *) ( List.filter is_opaque_type (T.TypeDeclId.Map.values k.types), List.filter is_opaque_fun (FunDeclId.Map.values k.functions) ) (** Return true if the crate contains opaque declarations, ignoring the assumed definitions. *) -let crate_has_opaque_decls (k : crate) (filter_assumed : bool) : bool = - crate_get_opaque_decls k filter_assumed <> ([], []) +let crate_has_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : + bool = + crate_get_opaque_non_builtin_decls k filter_assumed <> ([], []) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 35dff9e6..019a5c35 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -390,10 +390,10 @@ type gen_config = { [filter_assumed]: if [true], do not consider as opaque the external definitions that we will map to definitions from the standard library. *) -let crate_has_opaque_decls (ctx : gen_ctx) (filter_assumed : bool) : bool * bool - = +let crate_has_opaque_non_builtin_decls (ctx : gen_ctx) (filter_assumed : bool) : + bool * bool = let types, funs = - LlbcAstUtils.crate_get_opaque_decls ctx.crate filter_assumed + LlbcAstUtils.crate_get_opaque_non_builtin_decls ctx.crate filter_assumed in log#ldebug (lazy @@ -1257,7 +1257,9 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (* Check if there are opaque types and functions - in which case we need * to split *) - let has_opaque_types, has_opaque_funs = crate_has_opaque_decls ctx true in + let has_opaque_types, has_opaque_funs = + crate_has_opaque_non_builtin_decls ctx true + in let has_opaque_types = has_opaque_types || !Config.use_state in (* Extract the types *) -- cgit v1.2.3 From 81b7a7d706bc1a0f2f57bc254a8af158039a10cf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 18:44:28 +0200 Subject: Make the hashmap files typecheck again in Lean --- compiler/Extract.ml | 2500 ++------------------------------------------ compiler/ExtractBase.ml | 2 + compiler/ExtractBuiltin.ml | 509 +++------ compiler/ExtractTypes.ml | 2390 ++++++++++++++++++++++++++++++++++++++++++ compiler/Pure.ml | 4 +- compiler/Translate.ml | 1 + compiler/dune | 1 + 7 files changed, 2667 insertions(+), 2740 deletions(-) create mode 100644 compiler/ExtractTypes.ml (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 6b6a2686..caa4835f 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -7,2370 +7,8 @@ open Pure open PureUtils open TranslateCore open ExtractBase -open StringUtils open Config -module F = Format - -(** Small helper to compute the name of an int type *) -let int_name (int_ty : integer_type) = - let isize, usize, i_format, u_format = - match !backend with - | FStar | Coq | HOL4 -> - ("isize", "usize", format_of_string "i%d", format_of_string "u%d") - | Lean -> ("Isize", "Usize", format_of_string "I%d", format_of_string "U%d") - in - match int_ty with - | Isize -> isize - | I8 -> Printf.sprintf i_format 8 - | I16 -> Printf.sprintf i_format 16 - | I32 -> Printf.sprintf i_format 32 - | I64 -> Printf.sprintf i_format 64 - | I128 -> Printf.sprintf i_format 128 - | Usize -> usize - | U8 -> Printf.sprintf u_format 8 - | U16 -> Printf.sprintf u_format 16 - | U32 -> Printf.sprintf u_format 32 - | U64 -> Printf.sprintf u_format 64 - | U128 -> Printf.sprintf u_format 128 - -(** Small helper to compute the name of a unary operation *) -let unop_name (unop : unop) : string = - match unop with - | Not -> ( - match !backend with FStar | Lean -> "not" | Coq -> "negb" | HOL4 -> "~") - | Neg (int_ty : integer_type) -> ( - match !backend with Lean -> "-" | _ -> int_name int_ty ^ "_neg") - | Cast _ -> - (* We never directly use the unop name in this case *) - raise (Failure "Unsupported") - -(** Small helper to compute the name of a binary operation (note that many - binary operations like "less than" are extracted to primitive operations, - like [<]). - *) -let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = - let binop = - match binop with - | Div -> "div" - | Rem -> "rem" - | Add -> "add" - | Sub -> "sub" - | Mul -> "mul" - | Lt -> "lt" - | Le -> "le" - | Ge -> "ge" - | Gt -> "gt" - | BitXor -> "xor" - | BitAnd -> "and" - | BitOr -> "or" - | Shl -> "lsl" - | 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 *) - match !backend with - | Lean -> int_name int_ty ^ "." ^ binop - | FStar | Coq | HOL4 -> int_name int_ty ^ "_" ^ binop - -(** A list of keywords/identifiers used by the backend and with which we - want to check collision. - - Remark: this is useful mostly to look for collisions when generating - names for *variables*. - *) -let keywords () = - let named_unops = - unop_name Not - :: List.map (fun it -> unop_name (Neg it)) T.all_signed_int_types - in - let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in - let named_binops = - List.concat_map - (fun bn -> List.map (fun it -> named_binop_name bn it) T.all_int_types) - named_binops - in - let misc = - match !backend with - | FStar -> - [ - "assert"; - "assert_norm"; - "assume"; - "else"; - "fun"; - "fn"; - "FStar"; - "FStar.Mul"; - "if"; - "in"; - "include"; - "int"; - "let"; - "list"; - "match"; - "not"; - "open"; - "rec"; - "scalar_cast"; - "then"; - "type"; - "Type0"; - "Type"; - "unit"; - "val"; - "with"; - ] - | Coq -> - [ - "assert"; - "Arguments"; - "Axiom"; - "char_of_byte"; - "Check"; - "Declare"; - "Definition"; - "else"; - "End"; - "fun"; - "Fixpoint"; - "if"; - "in"; - "int"; - "Inductive"; - "Import"; - "let"; - "Lemma"; - "match"; - "Module"; - "not"; - "Notation"; - "Proof"; - "Qed"; - "rec"; - "Record"; - "Require"; - "Scope"; - "Search"; - "SearchPattern"; - "Set"; - "then"; - (* [tt] is unit *) - "tt"; - "type"; - "Type"; - "unit"; - "with"; - ] - | Lean -> - [ - "by"; - "class"; - "decreasing_by"; - "def"; - "deriving"; - "do"; - "else"; - "end"; - "for"; - "have"; - "if"; - "inductive"; - "instance"; - "import"; - "let"; - "macro"; - "match"; - "namespace"; - "opaque"; - "open"; - "run_cmd"; - "set_option"; - "simp"; - "structure"; - "syntax"; - "termination_by"; - "then"; - "Type"; - "unsafe"; - "where"; - "with"; - "opaque_defs"; - ] - | HOL4 -> - [ - "Axiom"; - "case"; - "Definition"; - "else"; - "End"; - "fix"; - "fix_exec"; - "fn"; - "fun"; - "if"; - "in"; - "int"; - "Inductive"; - "let"; - "of"; - "Proof"; - "QED"; - "then"; - "Theorem"; - ] - in - List.concat [ named_unops; named_binops; misc ] - -let assumed_adts () : (assumed_ty * string) list = - match !backend with - | Lean -> - [ - (State, "State"); - (Result, "Result"); - (Error, "Error"); - (Fuel, "Nat"); - (Array, "Array"); - (Slice, "Slice"); - (Str, "Str"); - (RawPtr Mut, "MutRawPtr"); - (RawPtr Const, "ConstRawPtr"); - ] - | Coq | FStar | HOL4 -> - [ - (State, "state"); - (Result, "result"); - (Error, "error"); - (Fuel, if !backend = HOL4 then "num" else "nat"); - (Array, "array"); - (Slice, "slice"); - (Str, "str"); - (RawPtr Mut, "mut_raw_ptr"); - (RawPtr Const, "const_raw_ptr"); - ] - -let assumed_struct_constructors () : (assumed_ty * string) list = - match !backend with - | Lean -> [ (Array, "Array.make") ] - | Coq -> [ (Array, "mk_array") ] - | FStar -> [ (Array, "mk_array") ] - | HOL4 -> [ (Array, "mk_array") ] - -let assumed_variants () : (assumed_ty * VariantId.id * string) list = - match !backend with - | FStar -> - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail"); - (Error, error_failure_id, "Failure"); - (Error, error_out_of_fuel_id, "OutOfFuel"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - ] - | Coq -> - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail_"); - (Error, error_failure_id, "Failure"); - (Error, error_out_of_fuel_id, "OutOfFuel"); - (Fuel, fuel_zero_id, "O"); - (Fuel, fuel_succ_id, "S"); - ] - | Lean -> - [ - (Result, result_return_id, "ret"); - (Result, result_fail_id, "fail"); - (Error, error_failure_id, "panic"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - ] - | HOL4 -> - [ - (Result, result_return_id, "Return"); - (Result, result_fail_id, "Fail"); - (Error, error_failure_id, "Failure"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - ] - -let assumed_llbc_functions () : - (A.assumed_fun_id * T.RegionGroupId.id option * string) list = - let rg0 = Some T.RegionGroupId.zero in - match !backend with - | FStar | Coq | HOL4 -> - [ - (ArrayIndexShared, None, "array_index_shared"); - (ArrayIndexMut, None, "array_index_mut_fwd"); - (ArrayIndexMut, rg0, "array_index_mut_back"); - (ArrayToSliceShared, None, "array_to_slice_shared"); - (ArrayToSliceMut, None, "array_to_slice_mut_fwd"); - (ArrayToSliceMut, rg0, "array_to_slice_mut_back"); - (ArrayRepeat, None, "array_repeat"); - (SliceIndexShared, None, "slice_index_shared"); - (SliceIndexMut, None, "slice_index_mut_fwd"); - (SliceIndexMut, rg0, "slice_index_mut_back"); - (SliceLen, None, "slice_len"); - ] - | Lean -> - [ - (ArrayIndexShared, None, "Array.index_shared"); - (ArrayIndexMut, None, "Array.index_mut"); - (ArrayIndexMut, rg0, "Array.index_mut_back"); - (ArrayToSliceShared, None, "Array.to_slice_shared"); - (ArrayToSliceMut, None, "Array.to_slice_mut"); - (ArrayToSliceMut, rg0, "Array.to_slice_mut_back"); - (ArrayRepeat, None, "Array.repeat"); - (SliceIndexShared, None, "Slice.index_shared"); - (SliceIndexMut, None, "Slice.index_mut"); - (SliceIndexMut, rg0, "Slice.index_mut_back"); - (SliceLen, None, "Slice.len"); - ] - -let assumed_pure_functions () : (pure_assumed_fun_id * string) list = - match !backend with - | FStar -> - [ - (Return, "return"); - (Fail, "fail"); - (Assert, "massert"); - (FuelDecrease, "decrease"); - (FuelEqZero, "is_zero"); - ] - | Coq -> - (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) - [ (Return, "return_"); (Fail, "fail_"); (Assert, "massert") ] - | Lean -> - (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) - [ (Return, "return"); (Fail, "fail_"); (Assert, "massert") ] - | HOL4 -> - (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) - [ (Return, "return"); (Fail, "fail"); (Assert, "massert") ] - -let names_map_init () : names_map_init = - { - keywords = keywords (); - assumed_adts = assumed_adts (); - assumed_structs = assumed_struct_constructors (); - assumed_variants = assumed_variants (); - assumed_llbc_functions = assumed_llbc_functions (); - assumed_pure_functions = assumed_pure_functions (); - } - -let extract_unop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit - = - match unop with - | Not | Neg _ -> - let unop = unop_name unop in - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt unop; - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")" - | Cast (src, tgt) -> ( - (* HOL4 has a special treatment: because it doesn't support dependent - types, we don't have a specific operator for the cast *) - match !backend with - | HOL4 -> - (* Casting, say, an u32 to an i32 would be done as follows: - {[ - mk_i32 (u32_to_int x) - ]} - *) - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt ("mk_" ^ int_name tgt); - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - F.pp_print_string fmt (int_name src ^ "_to_int"); - F.pp_print_space fmt (); - extract_expr true arg; - F.pp_print_string fmt ")"; - if inside then F.pp_print_string fmt ")" - | FStar | Coq | Lean -> - (* Rem.: the source type is an implicit parameter *) - if inside then F.pp_print_string fmt "("; - let cast_str = - match !backend with - | Coq | FStar -> "scalar_cast" - | Lean -> (* TODO: I8.cast, I16.cast, etc.*) "Scalar.cast" - | HOL4 -> raise (Failure "Unreachable") - in - F.pp_print_string fmt cast_str; - F.pp_print_space fmt (); - if !backend <> Lean then ( - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string src)); - F.pp_print_space fmt ()); - if !backend = Lean then F.pp_print_string fmt ("." ^ int_name tgt) - else - F.pp_print_string fmt - (StringUtils.capitalize_first_letter - (PrintPure.integer_type_to_string tgt)); - F.pp_print_space fmt (); - extract_expr true arg; - if inside then F.pp_print_string fmt ")") - -(** [extract_expr] : the boolean argument is [inside] *) -let extract_binop (extract_expr : bool -> texpression -> unit) - (fmt : F.formatter) (inside : bool) (binop : E.binop) - (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = - if inside then F.pp_print_string fmt "("; - (* Some binary operations have a special notation depending on the backend *) - (match (!backend, binop) with - | HOL4, (Eq | Ne) - | (FStar | Coq | Lean), (Eq | Lt | Le | Ne | Ge | Gt) - | Lean, (Div | Rem | Add | Sub | Mul) -> - let binop = - match binop with - | Eq -> "=" - | Lt -> "<" - | Le -> "<=" - | Ne -> if !backend = Lean then "!=" else "<>" - | Ge -> ">=" - | Gt -> ">" - | Div -> "/" - | Rem -> "%" - | Add -> "+" - | Sub -> "-" - | Mul -> "*" - | _ -> raise (Failure "Unreachable") - in - let binop = - match !backend with FStar | Lean | HOL4 -> binop | Coq -> "s" ^ binop - in - extract_expr false arg0; - F.pp_print_space fmt (); - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr false arg1 - | _ -> - let binop = named_binop_name binop int_ty in - F.pp_print_string fmt binop; - F.pp_print_space fmt (); - extract_expr true arg0; - F.pp_print_space fmt (); - extract_expr true arg1); - if inside then F.pp_print_string fmt ")" - -let type_decl_kind_to_qualif (kind : decl_kind) - (type_kind : type_decl_kind option) : string option = - match !backend with - | FStar -> ( - match kind with - | SingleNonRec -> Some "type" - | SingleRec -> Some "type" - | MutRecFirst -> Some "type" - | MutRecInner -> Some "and" - | MutRecLast -> Some "and" - | Assumed -> Some "assume type" - | Declared -> Some "val") - | Coq -> ( - match (kind, type_kind) with - | SingleNonRec, Some Enum -> Some "Inductive" - | SingleNonRec, Some Struct -> Some "Record" - | (SingleRec | MutRecFirst), Some _ -> Some "Inductive" - | (MutRecInner | MutRecLast), Some _ -> - (* Coq doesn't support groups of mutually recursive definitions which mix - * records and inducties: we convert everything to records if this happens - *) - Some "with" - | (Assumed | Declared), None -> Some "Axiom" - | SingleNonRec, None -> - (* This is for traits *) - Some "Record" - | _ -> - raise - (Failure - ("Unexpected: (" ^ show_decl_kind kind ^ ", " - ^ Print.option_to_string show_type_decl_kind type_kind - ^ ")"))) - | Lean -> ( - match kind with - | SingleNonRec -> - if type_kind = Some Struct then Some "structure" else Some "inductive" - | SingleRec -> Some "inductive" - | MutRecFirst -> Some "inductive" - | MutRecInner -> Some "inductive" - | MutRecLast -> Some "inductive" - | Assumed -> Some "axiom" - | Declared -> Some "axiom") - | HOL4 -> None - -let fun_decl_kind_to_qualif (kind : decl_kind) : string option = - match !backend with - | FStar -> ( - match kind with - | SingleNonRec -> Some "let" - | SingleRec -> Some "let rec" - | MutRecFirst -> Some "let rec" - | MutRecInner -> Some "and" - | MutRecLast -> Some "and" - | Assumed -> Some "assume val" - | Declared -> Some "val") - | Coq -> ( - match kind with - | SingleNonRec -> Some "Definition" - | SingleRec -> Some "Fixpoint" - | MutRecFirst -> Some "Fixpoint" - | MutRecInner -> Some "with" - | MutRecLast -> Some "with" - | Assumed -> Some "Axiom" - | Declared -> Some "Axiom") - | Lean -> ( - match kind with - | SingleNonRec -> Some "def" - | SingleRec -> Some "divergent def" - | MutRecFirst -> Some "mutual divergent def" - | MutRecInner -> Some "divergent def" - | MutRecLast -> Some "divergent def" - | Assumed -> Some "axiom" - | Declared -> Some "axiom") - | HOL4 -> None - -(** The type of types. - - TODO: move inside the formatter? - *) -let type_keyword () = - match !backend with - | FStar -> "Type0" - | Coq | Lean -> "Type" - | HOL4 -> raise (Failure "Unexpected") - -(** - [ctx]: we use the context to lookup type definitions, to retrieve type names. - This is used to compute variable names, when they have no basenames: in this - case we use the first letter of the type name. - - [variant_concatenate_type_name]: if true, add the type name as a prefix - to the variant names. - Ex.: - In Rust: - {[ - enum List = { - Cons(u32, Box),x - Nil, - } - ]} - - F*, if option activated: - {[ - type list = - | ListCons : u32 -> list -> list - | ListNil : list - ]} - - F*, if option not activated: - {[ - type list = - | Cons : u32 -> list -> list - | Nil : list - ]} - - Rk.: this should be true by default, because in Rust all the variant names - are actively uniquely identifier by the type name [List::Cons(...)], while - in other languages it is not necessarily the case, and thus clashes can mess - up type checking. Note that some languages actually forbids the name clashes - (it is the case of F* ). - *) -let mk_formatter (ctx : trans_ctx) (crate_name : string) - (variant_concatenate_type_name : bool) : formatter = - let int_name = int_name in - - (* Prepare a name. - * The first id elem is always the crate: if it is the local crate, - * we remove it. - * We also remove all the disambiguators, then convert everything to strings. - * **Rmk:** because we remove the disambiguators, there may be name collisions - * (which is ok, because we check for name collisions and fail if there is any). - *) - let get_name (name : name) : string list = - (* Rmk.: initially we only filtered the disambiguators equal to 0 *) - let name = Names.filter_disambiguators name in - match name with - | Ident crate :: name -> - let name = if crate = crate_name then name else Ident crate :: name in - let name = - List.map - (function - | Names.Ident s -> s - | Disambiguator d -> Names.Disambiguator.to_string d) - name - in - name - | _ -> - raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) - in - let flatten_name (name : string list) : string = - match !backend with - | FStar | Coq | HOL4 -> String.concat "_" name - | Lean -> String.concat "." name - in - let get_type_name = get_name in - let type_name_to_camel_case name = - let name = get_type_name name in - let name = List.map to_camel_case name in - String.concat "" name - in - let type_name_to_snake_case name = - let name = get_type_name name in - let name = List.map to_snake_case name in - let name = String.concat "_" name in - match !backend with - | FStar | Lean | HOL4 -> name - | Coq -> capitalize_first_letter name - in - let type_name name = - match !backend with - | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_t" - | Lean -> String.concat "." (get_type_name name) - in - let field_name (def_name : name) (field_id : FieldId.id) - (field_name : string option) : string = - let field_name_s = - match field_name with - | Some field_name -> field_name - | None -> - (* TODO: extract structs with no field names to tuples *) - FieldId.to_string field_id - in - if !Config.record_fields_short_names then - if field_name = None then (* TODO: this is a bit ugly *) - "_" ^ field_name_s - else field_name_s - else - let def_name = type_name_to_snake_case def_name ^ "_" in - def_name ^ field_name_s - in - let variant_name (def_name : name) (variant : string) : string = - match !backend with - | FStar | Coq | HOL4 -> - let variant = to_camel_case variant in - if variant_concatenate_type_name then - type_name_to_camel_case def_name ^ variant - else variant - | Lean -> variant - in - let struct_constructor (basename : name) : string = - let tname = type_name basename in - let prefix = - match !backend with FStar -> "Mk" | Coq | HOL4 -> "mk" | Lean -> "" - in - let suffix = - match !backend with FStar | Coq | HOL4 -> "" | Lean -> ".mk" - in - prefix ^ tname ^ suffix - in - let get_fun_name fname = - let fname = get_name fname in - (* TODO: don't convert to snake case for Coq, HOL4, F* *) - flatten_name fname - in - let global_name (name : global_name) : string = - (* Converting to snake case also lowercases the letters (in Rust, global - * names are written in capital letters). *) - let parts = List.map to_snake_case (get_name name) in - String.concat "_" parts - in - let fun_name (fname : fun_name) (num_loops : int) (loop_id : LoopId.id option) - (num_rgs : int) (rg : region_group_info option) (filter_info : bool * int) - : string = - let fname = get_fun_name fname in - (* Compute the suffix *) - let suffix = default_fun_suffix num_loops loop_id num_rgs rg filter_info in - (* Concatenate *) - fname ^ suffix - in - - let trait_decl_name (trait_decl : trait_decl) : string = - type_name trait_decl.name - in - - let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : - string = - (* TODO: provisional: we concatenate the trait impl name (which is its type) - with the trait decl name *) - let trait_decl = - let name = trait_decl.name in - match !backend with - | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_inst" - | Lean -> String.concat "" (get_type_name name) ^ "Inst" - in - flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) - in - - let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) - : string = - (* TODO: improve - it would be better to not use indices *) - let clause = "parent_clause_" ^ TraitClauseId.to_string clause.clause_id in - if !Config.record_fields_short_names then clause - else trait_decl_name trait_decl ^ "_" ^ clause - in - let trait_type_name (trait_decl : trait_decl) (item : string) : string = - if !Config.record_fields_short_names then item - else trait_decl_name trait_decl ^ "_" ^ item - in - let trait_const_name (trait_decl : trait_decl) (item : string) : string = - if !Config.record_fields_short_names then item - else trait_decl_name trait_decl ^ "_" ^ item - in - let trait_method_name (trait_decl : trait_decl) (item : string) : string = - if !Config.record_fields_short_names then item - else trait_decl_name trait_decl ^ "_" ^ item - in - let trait_type_clause_name (trait_decl : trait_decl) (item : string) - (clause : trait_clause) : string = - (* TODO: improve - it would be better to not use indices *) - trait_type_name trait_decl item - ^ "_clause_" - ^ TraitClauseId.to_string clause.clause_id - in - - let termination_measure_name (_fid : A.FunDeclId.id) (fname : fun_name) - (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = get_fun_name fname in - let lp_suffix = default_fun_loop_suffix num_loops loop_id in - (* Compute the suffix *) - let suffix = - match !Config.backend with - | FStar -> "_decreases" - | Lean -> "_terminates" - | Coq | HOL4 -> raise (Failure "Unexpected") - in - (* Concatenate *) - fname ^ lp_suffix ^ suffix - in - - let decreases_proof_name (_fid : A.FunDeclId.id) (fname : fun_name) - (num_loops : int) (loop_id : LoopId.id option) : string = - let fname = get_fun_name fname in - let lp_suffix = default_fun_loop_suffix num_loops loop_id in - (* Compute the suffix *) - let suffix = - match !Config.backend with - | Lean -> "_decreases" - | FStar | Coq | HOL4 -> raise (Failure "Unexpected") - in - (* Concatenate *) - fname ^ lp_suffix ^ suffix - in - - let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) - : string = - (* Small helper to derive var names from ADT type names. - - We do the following: - - convert the type name to snake case - - take the first letter of every "letter group" - Ex.: "HashMap" -> "hash_map" -> "hm" - *) - let name_from_type_ident (name : string) : string = - let cl = to_snake_case name in - let cl = String.split_on_char '_' cl in - let cl = List.filter (fun s -> String.length s > 0) cl in - assert (List.length cl > 0); - let cl = List.map (fun s -> s.[0]) cl in - StringUtils.string_of_chars cl - in - (* If there is a basename, we use it *) - match basename with - | Some basename -> - (* This should be a no-op *) - to_snake_case basename - | None -> ( - (* No basename: we use the first letter of the type *) - match ty with - | Adt (type_id, generics) -> ( - match type_id with - | Tuple -> - (* The "pair" case is frequent enough to have its special treatment *) - if List.length generics.types = 2 then "p" else "t" - | Assumed Result -> "r" - | Assumed Error -> ConstStrings.error_basename - | Assumed Fuel -> ConstStrings.fuel_basename - | Assumed Array -> "a" - | Assumed Slice -> "s" - | Assumed Str -> "s" - | Assumed State -> ConstStrings.state_basename - | Assumed (RawPtr _) -> "p" - | 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 - * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" - *) - (* The name shouldn't be empty, and its last element should - * be an ident *) - let cl = List.nth def.name (List.length def.name - 1) in - name_from_type_ident (Names.as_ident cl)) - | TypeVar _ -> ( - (* TODO: use "t" also for F* *) - match !backend with - | FStar -> "x" (* lacking inspiration here... *) - | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) - | Literal lty -> ( - match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") - | Arrow _ -> "f" - | TraitType (_, _, name) -> name_from_type_ident name) - in - let type_var_basename (_varset : StringSet.t) (basename : string) : string = - (* Rust type variables are snake-case and start with a capital letter *) - match !backend with - | FStar -> - (* This is *not* a no-op: this removes the capital letter *) - to_snake_case basename - | HOL4 -> - (* In HOL4, type variable names must start with "'" *) - "'" ^ to_snake_case basename - | Coq | Lean -> basename - in - let const_generic_var_basename (_varset : StringSet.t) (basename : string) : - string = - (* Rust type variables are snake-case and start with a capital letter *) - match !backend with - | FStar | HOL4 -> - (* This is *not* a no-op: this removes the capital letter *) - to_snake_case basename - | Coq | Lean -> basename - in - let trait_clause_basename (_varset : StringSet.t) (_clause : trait_clause) : - string = - (* TODO: actually use the clause to derive the name *) - "inst" - in - let trait_self_clause_basename = "self_clause" in - let append_index (basename : string) (i : int) : string = - basename ^ string_of_int i - in - - let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit - = - match cv with - | Scalar sv -> ( - match !backend with - | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) - | Coq | HOL4 | Lean -> - let print_brackets = inside && !backend = HOL4 in - if print_brackets then F.pp_print_string fmt "("; - (match !backend with - | Coq | Lean -> () - | HOL4 -> - F.pp_print_string fmt ("int_to_" ^ int_name sv.PV.int_ty); - F.pp_print_space fmt () - | _ -> raise (Failure "Unreachable")); - (* We need to add parentheses if the value is negative *) - if sv.PV.value >= Z.of_int 0 then - F.pp_print_string fmt (Z.to_string sv.PV.value) - else if !backend = Lean then - (* TODO: parsing issues with Lean because there are ambiguous - interpretations between int values and nat values *) - F.pp_print_string fmt - ("(-(" ^ Z.to_string (Z.neg sv.PV.value) ^ ":Int))") - else F.pp_print_string fmt ("(" ^ Z.to_string sv.PV.value ^ ")"); - (match !backend with - | Coq -> - let iname = int_name sv.PV.int_ty in - F.pp_print_string fmt ("%" ^ iname) - | Lean -> - let iname = String.lowercase_ascii (int_name sv.PV.int_ty) in - F.pp_print_string fmt ("#" ^ iname) - | HOL4 -> () - | _ -> raise (Failure "Unreachable")); - if print_brackets then F.pp_print_string fmt ")") - | Bool b -> - let b = - match !backend with - | HOL4 -> if b then "T" else "F" - | Coq | FStar | Lean -> if b then "true" else "false" - in - F.pp_print_string fmt b - | Char c -> ( - match !backend with - | HOL4 -> - (* [#"a"] is a notation for [CHR 97] (97 is the ASCII code for 'a') *) - F.pp_print_string fmt ("#\"" ^ String.make 1 c ^ "\"") - | FStar | Lean -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") - | Coq -> - if inside then F.pp_print_string fmt "("; - F.pp_print_string fmt "char_of_byte"; - F.pp_print_space fmt (); - (* Convert the the char to ascii *) - let c = - let i = Char.code c in - let x0 = i / 16 in - let x1 = i mod 16 in - "Coq.Init.Byte.x" ^ string_of_int x0 ^ string_of_int x1 - in - F.pp_print_string fmt c; - if inside then F.pp_print_string fmt ")") - in - let bool_name = if !backend = Lean then "Bool" else "bool" in - let char_name = if !backend = Lean then "Char" else "char" in - let str_name = if !backend = Lean then "String" else "string" in - { - bool_name; - char_name; - int_name; - str_name; - type_decl_kind_to_qualif; - fun_decl_kind_to_qualif; - field_name; - variant_name; - struct_constructor; - type_name; - global_name; - fun_name; - termination_measure_name; - decreases_proof_name; - trait_decl_name; - trait_impl_name; - trait_parent_clause_name; - trait_const_name; - trait_type_name; - trait_method_name; - trait_type_clause_name; - var_basename; - type_var_basename; - const_generic_var_basename; - trait_self_clause_basename; - trait_clause_basename; - append_index; - extract_literal; - extract_unop; - extract_binop; - } - -let mk_formatter_and_names_map (ctx : trans_ctx) (crate_name : string) - (variant_concatenate_type_name : bool) : formatter * names_map = - let fmt = mk_formatter ctx crate_name variant_concatenate_type_name in - let names_map = initialize_names_map fmt (names_map_init ()) in - (fmt, names_map) - -let is_single_opaque_fun_decl_group (dg : Pure.fun_decl list) : bool = - match dg with [ d ] -> d.body = None | _ -> false - -let is_single_opaque_type_decl_group (dg : Pure.type_decl list) : bool = - match dg with [ d ] -> d.kind = Opaque | _ -> false - -let is_empty_record_type_decl (d : Pure.type_decl) : bool = d.kind = Struct [] - -let is_empty_record_type_decl_group (dg : Pure.type_decl list) : bool = - match dg with [ d ] -> is_empty_record_type_decl d | _ -> false - -(** In some provers, groups of definitions must be delimited. - - - in Coq, *every* group (including singletons) must end with "." - - in Lean, groups of mutually recursive definitions must end with "end" - - in HOL4 (in most situations) the whole group must be within a `Define` command - - Calls to {!extract_fun_decl} should be inserted between calls to - {!start_fun_decl_group} and {!end_fun_decl_group}. - - TODO: maybe those [{start/end}_decl_group] functions are not that much a good - idea and we should merge them with the corresponding [extract_decl] functions. - *) -let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) - (is_rec : bool) (dg : Pure.fun_decl list) = - match !backend with - | FStar | Coq | Lean -> () - | HOL4 -> - (* In HOL4, opaque functions have a special treatment *) - if is_single_opaque_fun_decl_group dg then () - else - let compute_fun_def_name (def : Pure.fun_decl) : string = - ctx_get_local_function def.def_id def.loop_id def.back_id ctx ^ "_def" - in - let names = List.map compute_fun_def_name dg in - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open the box for the delimiters *) - F.pp_open_vbox fmt 0; - (* Open the box for the definitions themselves *) - F.pp_open_vbox fmt ctx.indent_incr; - (* Print the delimiters *) - if is_rec then - F.pp_print_string fmt - ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") - else ( - assert (List.length names = 1); - let name = List.hd names in - F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); - F.pp_print_cut fmt () - -(** See {!start_fun_decl_group}. *) -let end_fun_decl_group (fmt : F.formatter) (is_rec : bool) - (dg : Pure.fun_decl list) = - match !backend with - | FStar -> () - | Coq -> - (* For aesthetic reasons, we print the Coq end group delimiter directly - in {!extract_fun_decl}. *) - () - | Lean -> - (* We must add the "end" keyword to groups of mutually recursive functions *) - if is_rec && List.length dg > 1 then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "end"; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - else () - | HOL4 -> - (* In HOL4, opaque functions have a special treatment *) - if is_single_opaque_fun_decl_group dg then () - else ( - (* Close the box for the definitions *) - F.pp_close_box fmt (); - (* Print the end delimiter *) - F.pp_print_cut fmt (); - F.pp_print_string fmt "’"; - (* Close the box for the delimiters *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - -(** See {!start_fun_decl_group}: similar usage, but for the type declarations. *) -let start_type_decl_group (ctx : extraction_ctx) (fmt : F.formatter) - (is_rec : bool) (dg : Pure.type_decl list) = - match !backend with - | FStar | Coq -> () - | Lean -> - if is_rec && List.length dg > 1 then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "mutual"; - F.pp_print_space fmt ()) - | HOL4 -> - (* In HOL4, opaque types and empty records have a special treatment *) - if - is_single_opaque_type_decl_group dg - || is_empty_record_type_decl_group dg - then () - else ( - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open the box for the delimiters *) - F.pp_open_vbox fmt 0; - (* Open the box for the definitions themselves *) - F.pp_open_vbox fmt ctx.indent_incr; - (* Print the delimiters *) - F.pp_print_string fmt "Datatype:"; - F.pp_print_cut fmt ()) - -(** See {!start_fun_decl_group}. *) -let end_type_decl_group (fmt : F.formatter) (is_rec : bool) - (dg : Pure.type_decl list) = - match !backend with - | FStar -> () - | Coq -> - (* For aesthetic reasons, we print the Coq end group delimiter directly - in {!extract_fun_decl}. *) - () - | Lean -> - (* We must add the "end" keyword to groups of mutually recursive functions *) - if is_rec && List.length dg > 1 then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "end"; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - else () - | HOL4 -> - (* In HOL4, opaque types and empty records have a special treatment *) - if - is_single_opaque_type_decl_group dg - || is_empty_record_type_decl_group dg - then () - else ( - (* Close the box for the definitions *) - F.pp_close_box fmt (); - (* Print the end delimiter *) - F.pp_print_cut fmt (); - F.pp_print_string fmt "End"; - (* Close the box for the delimiters *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0) - -let unit_name () = - match !backend with Lean -> "Unit" | Coq | FStar | HOL4 -> "unit" - -(** Small helper *) -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 (ctx : extraction_ctx) (fmt : F.formatter) - (inside : bool) (cg : const_generic) : unit = - match cg with - | ConstGenericGlobal id -> - let s = ctx_get_global id ctx in - F.pp_print_string fmt s - | ConstGenericValue v -> ctx.fmt.extract_literal fmt inside v - | ConstGenericVar id -> - let s = ctx_get_const_generic_var id ctx in - F.pp_print_string fmt s - -let extract_literal_type (ctx : extraction_ctx) (fmt : F.formatter) - (ty : literal_type) : unit = - match ty with - | Bool -> F.pp_print_string fmt ctx.fmt.bool_name - | Char -> F.pp_print_string fmt ctx.fmt.char_name - | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) - -(** [inside] constrols whether we should add parentheses or not around type - applications (if [true] we add parentheses). - - [no_params_tys]: for all the types inside this set, do not print the type parameters. - This is used for HOL4. As polymorphism is uniform in HOL4, printing the - type parameters in the recursive definitions is useless (and actually - forbidden). - - For instance, where in F* we would write: - {[ - type list a = | Nil : list a | Cons : a -> list a -> list a - ]} - - In HOL4 we would simply write: - {[ - Datatype: - list = Nil 'a | Cons 'a list - End - ]} - *) -let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = - let extract_rec = extract_ty ctx fmt no_params_tys in - match ty with - | Adt (type_id, generics) -> ( - let has_params = generics <> empty_generic_args in - match type_id with - | Tuple -> - (* This is a bit annoying, but in F*/Coq/HOL4 [()] is not the unit type: - * we have to write [unit]... *) - if generics.types = [] then F.pp_print_string fmt (unit_name ()) - else ( - F.pp_print_string fmt "("; - Collections.List.iter_link - (fun () -> - F.pp_print_space fmt (); - let product = - match !backend with - | FStar -> "&" - | Coq -> "*" - | Lean -> "×" - | HOL4 -> "#" - in - F.pp_print_string fmt product; - F.pp_print_space fmt ()) - (extract_rec true) generics.types; - F.pp_print_string fmt ")") - | AdtId _ | Assumed _ -> ( - (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: - `tree a b` - - In HOL4 we would write: - `('a, 'b) tree` - *) - match !backend with - | FStar | Coq | Lean -> - let print_paren = inside && has_params in - if print_paren then F.pp_print_string fmt "("; - (* TODO: for now, only the opaque *functions* are extracted in the - opaque module. The opaque *types* are assumed. *) - F.pp_print_string fmt (ctx_get_type type_id ctx); - (* We might need to filter the type arguments, if the type - is builtin (for instance, we filter the global allocator type - argument for `Vec`). *) - let generics = - match type_id with - | AdtId id -> ( - match - TypeDeclId.Map.find_opt id ctx.types_filter_type_args_map - with - | None -> generics - | Some filter -> - let types = List.combine filter generics.types in - let types = - List.filter_map - (fun (b, ty) -> if b then Some ty else None) - types - in - { generics with types }) - | _ -> generics - in - extract_generic_args ctx fmt no_params_tys generics; - if print_paren then F.pp_print_string fmt ")" - | HOL4 -> - let { types; const_generics; trait_refs } = generics in - (* Const generics are not supported in HOL4 *) - assert (const_generics = []); - let print_tys = - match type_id with - | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) - | Assumed _ -> true - | _ -> raise (Failure "Unreachable") - in - if types <> [] && print_tys then ( - let print_paren = List.length types > 1 in - if print_paren then F.pp_print_string fmt "("; - Collections.List.iter_link - (fun () -> - F.pp_print_string fmt ","; - F.pp_print_space fmt ()) - (extract_rec true) types; - if print_paren then F.pp_print_string fmt ")"; - F.pp_print_space fmt ()); - F.pp_print_string fmt (ctx_get_type type_id ctx); - if trait_refs <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_trait_ref ctx fmt no_params_tys true) - trait_refs))) - | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) - | Literal lty -> extract_literal_type ctx fmt lty - | Arrow (arg_ty, ret_ty) -> - if inside then F.pp_print_string fmt "("; - extract_rec false arg_ty; - F.pp_print_space fmt (); - extract_arrow fmt (); - F.pp_print_space fmt (); - extract_rec false ret_ty; - if inside then F.pp_print_string fmt ")" - | TraitType (trait_ref, generics, type_name) -> - if !parameterize_trait_types then raise (Failure "Unimplemented") - else if trait_ref.trait_id <> Self then ( - (* HOL4 doesn't have 1st class types *) - assert (!backend <> HOL4); - let use_brackets = generics <> empty_generic_args in - if use_brackets then F.pp_print_string fmt "("; - extract_trait_ref ctx fmt no_params_tys false trait_ref; - extract_generic_args ctx fmt no_params_tys generics; - let name = - ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name - ctx - in - if use_brackets then F.pp_print_string fmt ")"; - F.pp_print_string fmt ("." ^ name)) - else - (* There are two situations: - - we are extracting a declared item (typically a function signature) - for a trait declaration. We directly refer to the item (we extract - trait declarations as structures, so we can refer to their fields) - - we are extracting a provided method for a trait declaration. We - refer to the item in the self trait clause (see {!SelfTraitClauseId}). - - Remark: we can't get there for trait *implementations* because then the - types should have been normalized. - *) - let trait_decl_id = Option.get ctx.trait_decl_id in - let item_name = ctx_get_trait_type trait_decl_id type_name ctx in - assert (generics = empty_generic_args); - if ctx.is_provided_method then - (* Provided method: use the trait self clause *) - let self_clause = ctx_get_trait_self_clause ctx in - F.pp_print_string fmt (self_clause ^ "." ^ item_name) - else - (* Declaration: directly refer to the item *) - F.pp_print_string fmt item_name - -and extract_trait_ref (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 "("; - extract_trait_instance_id ctx fmt no_params_tys inside tr.trait_id; - extract_generic_args ctx fmt no_params_tys tr.generics; - if use_brackets then F.pp_print_string fmt ")" - -and extract_trait_decl_ref (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 tr.trait_decl_id ctx in - if use_brackets then F.pp_print_string fmt "("; - F.pp_print_string fmt name; - (* There is something subtle here: the trait obligations for the implemented - trait are put inside the parent clauses, so we must ignore them here *) - let generics = { tr.decl_generics with trait_refs = [] } in - extract_generic_args ctx fmt no_params_tys generics; - if use_brackets then F.pp_print_string fmt ")" - -and extract_generic_args (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 ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_ty ctx fmt no_params_tys true) - types); - if const_generics <> [] then ( - assert (!backend <> HOL4); - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_const_generic ctx fmt true) - const_generics)); - if trait_refs <> [] then ( - F.pp_print_space fmt (); - Collections.List.iter_link (F.pp_print_space fmt) - (extract_trait_ref ctx fmt no_params_tys true) - trait_refs) - -and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) - : unit = - match id with - | Self -> - (* This has specific treatment depending on the item we're extracting - (associated type, etc.). We should have caught this elsewhere. *) - raise (Failure "Unexpected") - | TraitImpl id -> - let name = ctx_get_trait_impl id ctx in - F.pp_print_string fmt name - | Clause id -> - let name = ctx_get_local_trait_clause id ctx in - F.pp_print_string fmt name - | ParentClause (inst_id, decl_id, clause_id) -> - (* Use the trait decl id to lookup the name *) - let name = ctx_get_trait_parent_clause decl_id clause_id ctx in - extract_trait_instance_id ctx fmt no_params_tys true inst_id; - F.pp_print_string fmt ("." ^ 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 decl_id item_name clause_id ctx in - extract_trait_instance_id ctx fmt no_params_tys true inst_id; - F.pp_print_string fmt ("." ^ name) - | TraitRef trait_ref -> - extract_trait_ref ctx fmt no_params_tys inside trait_ref - | UnknownTrait _ -> - (* This is an error case *) - raise (Failure "Unexpected") - -(** Compute the names for all the top-level identifiers used in a type - definition (type name, variant names, field names, etc. but not type - parameters). - - We need to do this preemptively, beforce extracting any definition, - because of recursive definitions. - *) -let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : - extraction_ctx = - (* Lookup the builtin information, if there is *) - let open ExtractBuiltin in - let sname = name_to_simple_name def.name in - let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in - (* Register the filtering information, if there is *) - let ctx = - match info with - | Some { keep_params = Some keep; _ } -> - { - ctx with - types_filter_type_args_map = - TypeDeclId.Map.add def.def_id keep ctx.types_filter_type_args_map; - } - | _ -> ctx - in - (* Compute and register the type def name *) - let def_name = - match info with - | None -> ctx.fmt.type_name def.name - | Some info -> info.extract_name - in - let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in - (* Compute and register: - * - the variant names, if this is an enumeration - * - the field names, if this is a structure - *) - let ctx = - match def.kind with - | Struct fields -> - (* Compute the names *) - let field_names, cons_name = - match info with - | None | Some { body_info = None; _ } -> - let field_names = - FieldId.mapi - (fun fid (field : field) -> - (fid, ctx.fmt.field_name def.name fid field.field_name)) - fields - in - let cons_name = ctx.fmt.struct_constructor def.name in - (field_names, cons_name) - | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> - let field_names = - FieldId.mapi - (fun fid (_, name) -> (fid, name)) - (List.combine fields field_names) - in - (field_names, cons_name) - | Some info -> - raise - (Failure - ("Invalid builtin information: " - ^ show_builtin_type_info info)) - in - (* Add the fields *) - let ctx = - List.fold_left - (fun ctx (fid, name) -> - ctx_add (FieldId (AdtId def.def_id, fid)) name ctx) - ctx field_names - in - (* Add the constructor name *) - ctx_add (StructId (AdtId def.def_id)) cons_name ctx - | Enum variants -> - let variant_names = - match info with - | None -> - VariantId.mapi - (fun variant_id (variant : variant) -> - let name = - ctx.fmt.variant_name def.name variant.variant_name - in - (* Add the type name prefix for Lean *) - let name = - if !Config.backend = Lean then - let type_name = ctx.fmt.type_name def.name in - type_name ^ "." ^ name - else name - in - (variant_id, name)) - variants - | Some { body_info = Some (Enum variant_infos); _ } -> - (* We need to compute the map from variant to variant *) - let variant_map = - StringMap.of_list - (List.map - (fun (info : builtin_enum_variant_info) -> - (info.rust_variant_name, info.extract_variant_name)) - variant_infos) - in - VariantId.mapi - (fun variant_id (variant : variant) -> - (variant_id, StringMap.find variant.variant_name variant_map)) - variants - | _ -> raise (Failure "Invalid builtin information") - in - List.fold_left - (fun ctx (vid, vname) -> - ctx_add (VariantId (AdtId def.def_id, vid)) vname ctx) - ctx variant_names - | Opaque -> - (* Nothing to do *) - ctx - in - (* Return *) - ctx - -(** Print the variants *) -let extract_type_decl_variant (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; - (* [| Cons :] - * Note that we really don't want any break above so we print everything - * at once. *) - let opt_colon = if !backend <> HOL4 then " :" else "" in - F.pp_print_string fmt ("| " ^ cons_name ^ opt_colon); - let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : - extraction_ctx = - F.pp_print_space fmt (); - (* Open the field box *) - F.pp_open_box fmt ctx.indent_incr; - (* Print the field names, if the backend accepts it. - * [ x :] - * Note that when printing fields, we register the field names as - * *variables*: they don't need to be unique at the top level. *) - let ctx = - match !backend with - | FStar -> ( - match f.field_name with - | None -> ctx - | Some field_name -> - let var_id = VarId.of_int (FieldId.to_int fid) in - let field_name = - ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) - f.field_ty - in - let ctx, field_name = ctx_add_var field_name var_id ctx in - F.pp_print_string fmt (field_name ^ " :"); - F.pp_print_space fmt (); - ctx) - | Coq | Lean | HOL4 -> ctx - in - (* Print the field type *) - let inside = !backend = HOL4 in - extract_ty ctx fmt type_decl_group inside f.field_ty; - (* Print the arrow [->] *) - if !backend <> HOL4 then ( - F.pp_print_space fmt (); - extract_arrow fmt ()); - (* Close the field box *) - F.pp_close_box fmt (); - (* Return *) - ctx - in - (* Print the fields *) - let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in - let _ = - List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields - in - (* Sanity check: HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); - (* Print the final type *) - if !backend <> HOL4 then ( - F.pp_print_space fmt (); - F.pp_open_hovbox fmt 0; - F.pp_print_string fmt type_name; - List.iter - (fun p -> - F.pp_print_space fmt (); - F.pp_print_string fmt p) - (List.append type_params cg_params); - F.pp_close_box fmt ()); - (* Close the variant box *) - F.pp_close_box fmt () - -(* TODO: we don' need the [def_name] paramter: it can be retrieved from the context *) -let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (def : type_decl) (def_name : string) - (type_params : string list) (cg_params : string list) - (variants : variant list) : unit = - (* We want to generate a definition which looks like this (taking F* as example): - {[ - type list a = | Cons : a -> list a -> list a | Nil : list a - ]} - - If there isn't enough space on one line: - {[ - type s = - | Cons : a -> list a -> list a - | Nil : list a - ]} - - And if we need to write the type of a variant on several lines: - {[ - type s = - | Cons : - a -> - list a -> - list a - | Nil : list a - ]} - - Finally, it is possible to give names to the variant fields in Rust. - In this situation, we generate a definition like this: - {[ - type s = - | Cons : hd:a -> tl:list a -> list a - | Nil : list a - ]} - - Note that we already printed: [type s =] - *) - 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.fmt.variant_name def.name v.variant_name in - let fields = v.fields in - extract_type_decl_variant 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 - -let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) - (type_params : string list) (cg_params : string list) (fields : field list) - : unit = - (* We want to generate a definition which looks like this (taking F* as example): - {[ - type t = { x : int; y : bool; } - ]} - - If there isn't enough space on one line: - {[ - type t = - { - x : int; y : bool; - } - ]} - - And if there is even less space: - {[ - type t = - { - x : int; - y : bool; - } - ]} - - Also, in case there are no fields, we need to define the type as [unit] - ([type t = {}] doesn't work in F* ). - - Coq: - ==== - We need to define the constructor name upon defining the struct (record, in Coq). - The syntex is: - {[ - Record Foo = mkFoo { x : int; y : bool; }. - }] - - Also, Coq doesn't support groups of mutually recursive inductives and records. - This is fine, because we can then define records as inductives, and leverage - the fact that when record fields are accessed, the records are symbolically - expanded which introduces let bindings of the form: [let RecordCons ... = x in ...]. - As a consequence, we never use the record projectors (unless we reconstruct - them in the micro passes of course). - - HOL4: - ===== - Type definitions are written as follows: - {[ - Datatype: - tree = - TLeaf 'a - | TNode node ; - - node = - Node (tree list) - End - ]} - *) - (* Note that we already printed: [type t =] *) - let is_rec = decl_is_from_rec_group kind in - let _ = - if !backend = FStar && fields = [] then ( - F.pp_print_space fmt (); - F.pp_print_string fmt (unit_name ())) - else if !backend = Lean && fields = [] then () - (* If the definition is recursive, we may need to extract it as an inductive - (instead of a record). We start with the "normal" case: we extract it - as a record. *) - else if (not is_rec) || (!backend <> Coq && !backend <> Lean) then ( - if !backend <> Lean then F.pp_print_space fmt (); - (* If Coq: print the constructor name *) - (* TODO: remove superfluous test not is_rec below *) - if !backend = Coq && not is_rec then ( - F.pp_print_string fmt (ctx_get_struct (AdtId def.def_id) ctx); - F.pp_print_string fmt " "); - (match !backend with - | Lean -> () - | FStar | Coq -> F.pp_print_string fmt "{" - | HOL4 -> F.pp_print_string fmt "<|"); - F.pp_print_break fmt 1 ctx.indent_incr; - (* The body itself *) - (* Open a box for the body *) - (match !backend with - | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 - | 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 (AdtId 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; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_ty ctx fmt type_decl_group false f.field_ty; - if !backend <> Lean then F.pp_print_string fmt ";"; - (* Close the box for the field *) - F.pp_close_box fmt () - in - let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in - Collections.List.iter_link (F.pp_print_space fmt) - (fun (fid, f) -> print_field fid f) - fields; - (* Close the box for the body *) - F.pp_close_box fmt (); - match !backend with - | Lean -> () - | FStar | Coq -> - F.pp_print_space fmt (); - F.pp_print_string fmt "}" - | HOL4 -> - F.pp_print_space fmt (); - F.pp_print_string fmt "|>") - 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 *) - assert (is_rec && (!backend = Coq || !backend = Lean)); - (* 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 (AdtId def.def_id) ctx - in - let def_name = ctx_get_local_type def.def_id ctx in - extract_type_decl_variant ctx fmt type_decl_group def_name type_params - cg_params cons_name fields) - in - () - -(** Extract a nestable, muti-line comment *) -let extract_comment (fmt : F.formatter) (sl : string list) : unit = - (* Delimiters, space after we break a line *) - let ld, space, rd = - match !backend with - | Coq | FStar | HOL4 -> ("(** ", 4, " *)") - | Lean -> ("/- ", 3, " -/") - in - F.pp_open_vbox fmt space; - F.pp_print_string fmt ld; - (match sl with - | [] -> () - | s :: sl -> - F.pp_print_string fmt s; - List.iter - (fun s -> - F.pp_print_space fmt (); - F.pp_print_string fmt s) - sl); - F.pp_print_string fmt rd; - F.pp_close_box fmt () - -let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = - let trait_name = ctx_get_trait_decl clause.trait_id ctx in - F.pp_print_string fmt trait_name; - extract_generic_args ctx fmt no_params_tys clause.generics - -(** Insert a space, if necessary *) -let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = - if !space then space := false else F.pp_print_space fmt () - -(** Extract the trait self clause. - - We add the trait self clause for provided methods (see {!TraitSelfClauseId}). - *) -let extract_trait_self_clause (insert_req_space : unit -> unit) - (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : trait_decl) - (params : string list) : unit = - insert_req_space (); - F.pp_print_string fmt "("; - let self_clause = ctx_get_trait_self_clause ctx in - F.pp_print_string fmt self_clause; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - let trait_id = ctx_get_trait_decl trait_decl.def_id ctx in - F.pp_print_string fmt trait_id; - List.iter - (fun p -> - F.pp_print_space fmt (); - F.pp_print_string fmt p) - params; - F.pp_print_string fmt ")" - -(** - - [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 (ctx : extraction_ctx) (fmt : F.formatter) - (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) - ?(use_forall_use_sep = true) ?(as_implicits : bool = false) - ?(space : bool ref option = None) ?(trait_decl : trait_decl option = None) - (generics : generic_params) (type_params : string list) - (cg_params : string list) (trait_clauses : string list) : unit = - let all_params = List.concat [ type_params; cg_params; trait_clauses ] in - (* HOL4 doesn't support const generics *) - assert (cg_params = [] || !backend <> HOL4); - let left_bracket (implicit : bool) = - if implicit then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" - in - let right_bracket (implicit : bool) = - if implicit then F.pp_print_string fmt "}" else F.pp_print_string fmt ")" - in - let insert_req_space () = - match space with - | None -> F.pp_print_space fmt () - | Some space -> insert_req_space fmt space - in - (* Print the type/const generic parameters *) - if all_params <> [] then ( - if use_forall then ( - if use_forall_use_sep then ( - insert_req_space (); - F.pp_print_string fmt ":"); - insert_req_space (); - F.pp_print_string fmt "forall"); - (* Small helper - we may need to split the parameters *) - let print_generics (as_implicits : bool) (type_params : string list) - (const_generics : const_generic_var list) - (trait_clauses : trait_clause list) : unit = - (* Note that in HOL4 we don't print the type parameters. *) - if !backend <> HOL4 then ( - (* Print the type parameters *) - if type_params <> [] then ( - insert_req_space (); - (* ( *) - left_bracket as_implicits; - List.iter - (fun s -> - F.pp_print_string fmt s; - F.pp_print_space fmt ()) - type_params; - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ()); - (* ) *) - right_bracket as_implicits); - (* Print the const generic parameters *) - List.iter - (fun (var : const_generic_var) -> - insert_req_space (); - (* ( *) - left_bracket as_implicits; - let n = ctx_get_const_generic_var var.index ctx in - F.pp_print_string fmt n; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_literal_type ctx fmt var.ty; - (* ) *) - right_bracket as_implicits) - const_generics); - (* Print the trait clauses *) - List.iter - (fun (clause : trait_clause) -> - insert_req_space (); - (* ( *) - left_bracket as_implicits; - let n = ctx_get_local_trait_clause clause.clause_id ctx in - F.pp_print_string fmt n; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt no_params_tys clause; - (* ) *) - right_bracket as_implicits) - trait_clauses - in - (* If we extract the generics for a provided method for a trait declaration - (indicated by the trait decl given as input), we need to split the generics: - - we print the generics for the trait decl - - we print the trait self clause - - we print the generics for the trait method - *) - match trait_decl with - | None -> - print_generics as_implicits type_params generics.const_generics - generics.trait_clauses - | Some trait_decl -> - (* Split the generics between the generics specific to the trait decl - and those specific to the trait method *) - let open Collections.List in - let dtype_params, mtype_params = - split_at type_params (length trait_decl.generics.types) - in - let dcgs, mcgs = - split_at generics.const_generics - (length trait_decl.generics.const_generics) - in - let dtrait_clauses, mtrait_clauses = - split_at generics.trait_clauses - (length trait_decl.generics.trait_clauses) - in - (* Extract the trait decl generics - note that we can always deduce - those parameters from the trait self clause: for this reason - they are always implicit *) - print_generics true dtype_params dcgs dtrait_clauses; - (* Extract the trait self clause *) - let params = - concat - [ - dtype_params; - map - (fun (cg : const_generic_var) -> - ctx_get_const_generic_var cg.index ctx) - dcgs; - map - (fun c -> ctx_get_local_trait_clause c.clause_id ctx) - dtrait_clauses; - ] - in - extract_trait_self_clause insert_req_space ctx fmt trait_decl params; - (* Extract the method generics *) - print_generics as_implicits mtype_params mcgs mtrait_clauses) - -(** Extract a type declaration. - - This function is for all type declarations and all backends **at the exception** - of opaque (assumed/declared) types format4 HOL4. - - See {!extract_type_decl}. - *) -let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) - (extract_body : bool) : unit = - (* Sanity check *) - assert (extract_body || !backend <> HOL4); - let type_kind = - if extract_body then - match def.kind with - | Struct _ -> Some Struct - | Enum _ -> Some Enum - | Opaque -> None - else None - in - (* If in Coq and the declaration is opaque, it must have the shape: - [Axiom Ident : forall (T0 ... Tn : Type) (N0 : ...) ... (Nn : ...), ... -> ... -> ...]. - - The boolean [is_opaque_coq] is used to detect this case. - *) - let is_opaque = type_kind = None in - let is_opaque_coq = !backend = Coq && is_opaque in - let use_forall = is_opaque_coq && def.generics <> empty_generic_params in - (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in - (* 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.generics ctx - in - (* Add a break before *) - if !backend <> HOL4 || not (decl_is_first_from_group kind) then - F.pp_print_break fmt 0 0; - (* Print a comment to link the extracted type to its original rust definition *) - extract_comment fmt [ "[" ^ Print.name_to_string def.name ^ "]" ]; - F.pp_print_break fmt 0 0; - (* Open a box for the definition, so that whenever possible it gets printed on - * one line. Note however that in the case of Lean line breaks are important - * for parsing: we thus use a hovbox. *) - (match !backend with - | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 - | Lean -> F.pp_open_vbox fmt 0); - (* Open a box for "type TYPE_NAME (TYPE_PARAMS CONST_GEN_PARAMS) =" *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* > "type TYPE_NAME" *) - let qualif = ctx.fmt.type_decl_kind_to_qualif kind type_kind in - (match qualif with - | Some qualif -> F.pp_print_string fmt (qualif ^ " " ^ def_name) - | None -> F.pp_print_string fmt def_name); - (* HOL4 doesn't support const generics, and type definitions in HOL4 don't - support trait clauses *) - assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); - (* Print the generic parameters *) - extract_generic_params 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 (); - let eq = - match !backend with - | FStar -> "=" - | Coq -> ":=" - | Lean -> - if type_kind = Some Struct && kind = SingleNonRec then "where" - else ":=" - | HOL4 -> "=" - in - F.pp_print_string fmt eq) - else ( - (* Otherwise print ": Type", unless it is the HOL4 backend (in - which case we declare the type with `new_type`) *) - if use_forall then F.pp_print_string fmt "," - else ( - F.pp_print_space fmt (); - F.pp_print_string fmt ":"); - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ())); - (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) - F.pp_close_box fmt (); - (if extract_body then - match def.kind with - | Struct fields -> - extract_type_decl_struct_body ctx_body fmt type_decl_group kind def - type_params cg_params fields - | Enum variants -> - extract_type_decl_enum_body ctx_body fmt type_decl_group def def_name - type_params cg_params variants - | Opaque -> raise (Failure "Unreachable")); - (* Add the definition end delimiter *) - if !backend = HOL4 && decl_is_not_last_from_group kind then ( - F.pp_print_space fmt (); - F.pp_print_string fmt ";") - else if !backend = Coq && decl_is_last_from_group kind then ( - (* This is actually an end of group delimiter. For aesthetic reasons - we print it here instead of in {!end_type_decl_group}. *) - F.pp_print_cut fmt (); - F.pp_print_string fmt "."); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - if !backend <> HOL4 || decl_is_not_last_from_group kind then - F.pp_print_break fmt 0 0 - -(** Extract an opaque type declaration to HOL4. - - Remark (SH): having to treat this specific case separately is very annoying, - but I could not find a better way. - *) -let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) - (def : type_decl) : unit = - (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in - (* Generic parameters are unsupported *) - assert (def.generics.const_generics = []); - (* Trait clauses on type definitions are unsupported *) - assert (def.generics.trait_clauses = []); - (* Types *) - (* Count the number of parameters *) - let num_params = List.length def.generics.types in - (* Generate the declaration *) - F.pp_print_space fmt (); - F.pp_print_string fmt - ("val _ = new_type (\"" ^ def_name ^ "\", " ^ string_of_int num_params ^ ")"); - F.pp_print_space fmt () - -(** Extract an empty record type declaration to HOL4. - - Empty records are not supported in HOL4, so we extract them as type - abbreviations to the unit type. - - Remark (SH): having to treat this specific case separately is very annoying, - but I could not find a better way. - *) -let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) - (fmt : F.formatter) (def : type_decl) : unit = - (* Retrieve the definition name *) - let def_name = ctx_get_local_type def.def_id ctx in - (* Sanity check *) - assert (def.generics = empty_generic_params); - (* Generate the declaration *) - F.pp_print_space fmt (); - F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); - F.pp_print_space fmt () - -(** Extract a type declaration. - - Note that all the names used for extraction should already have been - registered. - - This function should be inserted between calls to {!start_type_decl_group} - and {!end_type_decl_group}. - *) -let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) - (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) : - unit = - let extract_body = - match kind with - | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> true - | Assumed | Declared -> false - in - if extract_body then - if !backend = HOL4 && is_empty_record_type_decl def then - extract_type_decl_hol4_empty_record ctx fmt def - else extract_type_decl_gen ctx fmt type_decl_group kind def extract_body - else - match !backend with - | FStar | Coq | Lean -> - extract_type_decl_gen ctx fmt type_decl_group kind def extract_body - | HOL4 -> extract_type_decl_hol4_opaque ctx fmt def - -(** Auxiliary function. - - Generate [Arguments] instructions in Coq. - *) -let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) - (kind : decl_kind) (decl : type_decl) : unit = - assert (!backend = Coq); - (* Generating the [Arguments] instructions is useful only if there are type parameters *) - if decl.generics.types = [] && decl.generics.const_generics = [] then () - else - (* Add the type params - note that we need those bindings only for the - * body translation (they are not top-level) *) - let _ctx_body, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.generics ctx - in - (* Auxiliary function to extract an [Arguments Cons {T} _ _.] instruction *) - let extract_arguments_info (cons_name : string) (fields : 'a list) : unit = - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open a box *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_break fmt 0 0; - F.pp_print_string fmt "Arguments"; - F.pp_print_space fmt (); - F.pp_print_string fmt cons_name; - (* Print the type/const params and the trait clauses (`{T}`) *) - List.iter - (fun (var : string) -> - F.pp_print_space fmt (); - F.pp_print_string fmt ("{" ^ var ^ "}")) - (List.concat [ type_params; cg_params; trait_clauses ]); - (* Print the fields (`_`) *) - List.iter - (fun _ -> - F.pp_print_space fmt (); - F.pp_print_string fmt "_") - fields; - F.pp_print_string fmt "."; - - (* Close the box *) - F.pp_close_box fmt () - in - - (* Generate the [Arguments] instruction *) - match decl.kind with - | Opaque -> () - | Struct fields -> - let adt_id = AdtId decl.def_id in - (* Generate the instruction for the record constructor *) - let cons_name = ctx_get_struct adt_id ctx in - extract_arguments_info cons_name fields; - (* Generate the instruction for the record projectors, if there are *) - let is_rec = decl_is_from_rec_group kind in - if not is_rec then - FieldId.iteri - (fun fid _ -> - let cons_name = ctx_get_field adt_id fid ctx in - extract_arguments_info cons_name []) - fields; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - | Enum variants -> - (* Generate the instructions *) - VariantId.iteri - (fun vid (v : variant) -> - let cons_name = ctx_get_variant (AdtId decl.def_id) vid ctx in - extract_arguments_info cons_name v.fields) - variants; - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - -(** Auxiliary function. - - Generate field projectors in Coq. - - Sometimes we extract records as inductives in Coq: when this happens we - have to define the field projectors afterwards. - *) -let extract_type_decl_record_field_projectors (ctx : extraction_ctx) - (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = - assert (!backend = Coq); - match decl.kind with - | Opaque | Enum _ -> () - | Struct fields -> - (* Records are extracted as inductives only if they are recursive *) - let is_rec = decl_is_from_rec_group kind in - if is_rec then - (* Add the type params *) - let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.generics ctx - in - let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in - let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in - let def_name = ctx_get_local_type decl.def_id ctx in - let cons_name = ctx_get_struct (AdtId decl.def_id) ctx in - let extract_field_proj (field_id : FieldId.id) (_ : field) : unit = - F.pp_print_space fmt (); - (* Outer box for the projector definition *) - F.pp_open_hvbox fmt 0; - (* Inner box for the projector definition *) - F.pp_open_hvbox fmt ctx.indent_incr; - (* Open a box for the [Definition PROJ ... :=] *) - 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 (AdtId 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 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 "("; - F.pp_print_string fmt record_var; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt def_name; - List.iter - (fun p -> - F.pp_print_space fmt (); - F.pp_print_string fmt p) - type_params; - F.pp_print_string fmt ")"; - (* *) - F.pp_print_space fmt (); - F.pp_print_string fmt ":="; - (* Close the box for the [Definition PROJ ... :=] *) - F.pp_close_box fmt (); - F.pp_print_space fmt (); - (* Open a box for the whole match *) - F.pp_open_hvbox fmt 0; - (* Open a box for the [match ... with] *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_string fmt "match"; - F.pp_print_space fmt (); - F.pp_print_string fmt record_var; - F.pp_print_space fmt (); - F.pp_print_string fmt "with"; - (* Close the box for the [match ... with] *) - F.pp_close_box fmt (); - - (* Open a box for the branch *) - F.pp_open_hovbox fmt ctx.indent_incr; - (* Print the match branch *) - F.pp_print_space fmt (); - F.pp_print_string fmt "|"; - F.pp_print_space fmt (); - F.pp_print_string fmt cons_name; - FieldId.iteri - (fun id _ -> - F.pp_print_space fmt (); - if field_id = id then F.pp_print_string fmt field_var - else F.pp_print_string fmt "_") - fields; - F.pp_print_space fmt (); - F.pp_print_string fmt "=>"; - F.pp_print_space fmt (); - F.pp_print_string fmt field_var; - (* Close the box for the branch *) - F.pp_close_box fmt (); - (* Print the [end] *) - F.pp_print_space fmt (); - F.pp_print_string fmt "end"; - (* Close the box for the whole match *) - F.pp_close_box fmt (); - (* Close the inner box projector *) - F.pp_close_box fmt (); - (* If Coq: end the definition with a "." *) - if !backend = Coq then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "."); - (* Close the outer box projector *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - in - - let extract_proj_notation (field_id : FieldId.id) (_ : field) : unit = - F.pp_print_space fmt (); - (* Outer box for the projector definition *) - 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 "x" (VarId.of_int 0) ctx in - F.pp_print_string fmt "Notation"; - F.pp_print_space fmt (); - let field_name = ctx_get_field (AdtId 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 ":="; - F.pp_print_space fmt (); - F.pp_print_string fmt "("; - F.pp_print_string fmt field_name; - F.pp_print_space fmt (); - F.pp_print_string fmt record_var; - F.pp_print_string fmt ")"; - F.pp_print_space fmt (); - F.pp_print_string fmt "(at level 9)"; - (* Close the inner box projector *) - F.pp_close_box fmt (); - (* If Coq: end the definition with a "." *) - if !backend = Coq then ( - F.pp_print_cut fmt (); - F.pp_print_string fmt "."); - (* Close the outer box projector *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 - in - - let extract_field_proj_and_notation (field_id : FieldId.id) - (field : field) : unit = - extract_field_proj field_id field; - extract_proj_notation field_id field - in - - FieldId.iteri extract_field_proj_and_notation fields - -(** Extract extra information for a type (e.g., [Arguments] instructions in Coq). - - Note that all the names used for extraction should already have been - registered. - *) -let extract_type_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) - (kind : decl_kind) (decl : type_decl) : unit = - match !backend with - | FStar | Lean | HOL4 -> () - | Coq -> - extract_type_decl_coq_arguments ctx fmt kind decl; - extract_type_decl_record_field_projectors ctx fmt kind decl - -(** Extract the state type declaration. *) -let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) - (kind : decl_kind) : unit = - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Print a comment *) - extract_comment fmt [ "The state type used in the state-error monad" ]; - F.pp_print_break fmt 0 0; - (* Open a box for the definition, so that whenever possible it gets printed on - * one line *) - F.pp_open_hvbox fmt 0; - (* Retrieve the name *) - let state_name = ctx_get_assumed_type State ctx in - (* The syntax for Lean and Coq is almost identical. *) - let print_axiom () = - let axiom = - match !backend with - | Coq -> "Axiom" - | Lean -> "axiom" - | FStar | HOL4 -> raise (Failure "Unexpected") - in - F.pp_print_string fmt axiom; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type"; - if !backend = Coq then F.pp_print_string fmt "." - in - (* The kind should be [Assumed] or [Declared] *) - (match kind with - | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> - raise (Failure "Unexpected") - | Assumed -> ( - match !backend with - | FStar -> - F.pp_print_string fmt "assume"; - F.pp_print_space fmt (); - F.pp_print_string fmt "type"; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0" - | HOL4 -> - F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") - | Coq | Lean -> print_axiom ()) - | Declared -> ( - match !backend with - | FStar -> - F.pp_print_string fmt "val"; - F.pp_print_space fmt (); - F.pp_print_string fmt state_name; - F.pp_print_space fmt (); - F.pp_print_string fmt ":"; - F.pp_print_space fmt (); - F.pp_print_string fmt "Type0" - | HOL4 -> - F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") - | Coq | Lean -> print_axiom ())); - (* Close the box for the definition *) - F.pp_close_box fmt (); - (* Add breaks to insert new lines between definitions *) - F.pp_print_break fmt 0 0 +include ExtractTypes (** Compute the names for all the pure functions generated from a rust function (forward function and backward functions). @@ -2415,13 +53,23 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) let fun_id = (Pure.FunId (Regular f.def_id), f.loop_id, f.back_id) in - let fun_name = - (List.find - (fun (x : builtin_fun_info) -> x.rg = f.back_id) - info) - .extract_name + let fun_info = + List.find_opt + (fun (x : builtin_fun_info) -> x.rg = f.back_id) + info in - ctx_add (FunId (FromLlbc fun_id)) fun_name ctx) + match fun_info with + | Some fun_info -> + ctx_add (FunId (FromLlbc fun_id)) fun_info.extract_name ctx + | None -> + raise + (Failure + ("Not found: " + ^ Names.name_to_string f.basename + ^ ", " + ^ Print.option_to_string Pure.show_loop_id f.loop_id + ^ Print.option_to_string Pure.show_region_group_id + f.back_id))) ctx funs | None -> let fwd = def.fwd in @@ -2554,6 +202,32 @@ let extract_global (ctx : extraction_ctx) (fmt : F.formatter) (id : A.GlobalDeclId.id) : unit = F.pp_print_string fmt (ctx_get_global id ctx) +(* Filter the generics of a function if it is builtin *) +let fun_builtin_filter_types (id : FunDeclId.id) (types : 'a list) + (ctx : extraction_ctx) : ('a list, 'a list * string) Result.result = + match FunDeclId.Map.find_opt id ctx.funs_filter_type_args_map with + | None -> Result.Ok types + | Some filter -> + if List.length filter <> List.length types then ( + let decl = FunDeclId.Map.find id ctx.trans_funs in + let err = + "Ill-formed builtin information for function " + ^ Names.name_to_string decl.fwd.f.basename + ^ ": " + ^ string_of_int (List.length filter) + ^ " filtering arguments provided for " + ^ string_of_int (List.length types) + ^ " type arguments" + in + log#serror err; + Result.Error (types, err)) + else + let types = List.combine filter types in + let types = + List.filter_map (fun (b, ty) -> if b then Some ty else None) types + in + Result.Ok types + (** [inside]: see {!extract_ty}. As a pattern can introduce new variables, we return an extraction context @@ -2785,22 +459,24 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) is builtin (for instance, we filter the global allocator type argument for `Vec::new`). *) - let generics = + let types = match fun_id with - | FromLlbc (FunId (Regular id), _, _) -> ( - match FunDeclId.Map.find_opt id ctx.funs_filter_type_args_map with - | None -> generics - | Some filter -> - let types = List.combine filter generics.types in - let types = - List.filter_map - (fun (b, ty) -> if b then Some ty else None) - types - in - { generics with types }) - | _ -> generics + | FromLlbc (FunId (Regular id), _, _) -> + fun_builtin_filter_types id generics.types ctx + | _ -> Result.Ok generics.types in - extract_generic_args ctx fmt TypeDeclId.Set.empty generics; + (match types with + | Ok types -> + extract_generic_args ctx fmt TypeDeclId.Set.empty + { generics with types } + | Error (types, err) -> + extract_generic_args ctx fmt TypeDeclId.Set.empty + { generics with types }; + if !Config.extract_fail_hard then raise (Failure err) + else + F.pp_print_string fmt + "(\"ERROR: ill-formed builtin: invalid number of filtering \ + arguments\")"); (* Print the arguments *) List.iter (fun ve -> @@ -4353,10 +2029,8 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) (** Similar to {!extract_type_decl_register_names} *) let extract_trait_impl_register_names (ctx : extraction_ctx) (trait_impl : trait_impl) : extraction_ctx = - let trait_decl = - TraitDeclId.Map.find trait_impl.impl_trait.trait_decl_id - ctx.trans_trait_decls - in + let decl_id = trait_impl.impl_trait.trait_decl_id in + let trait_decl = TraitDeclId.Map.find decl_id ctx.trans_trait_decls in (* Check if the trait implementation is builtin *) let builtin_info = let open ExtractBuiltin in @@ -4365,6 +2039,24 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) SimpleNamePairMap.find_opt (type_sname, trait_sname) (builtin_trait_impls_map ()) in + (* Register some builtin information (if necessary) *) + let ctx, builtin_info = + match builtin_info with + | None -> (ctx, None) + | Some (filter, info) -> + let ctx = + match filter with + | None -> ctx + | Some filter -> + { + ctx with + trait_impls_filter_type_args_map = + TraitImplId.Map.add trait_impl.def_id filter + ctx.trait_impls_filter_type_args_map; + } + in + (ctx, Some info) + in (* For now we do not support overriding provided methods *) assert (trait_impl.provided_methods = []); @@ -4596,12 +2288,36 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let f = f.f in let fun_name = ctx_get_trait_method trait_decl_id item_name f.back_id ctx in let ty () = + (* Filter the generics if the method is a builtin *) + let i_tys, _, _ = impl_generics in + let impl_types, i_tys, f_tys = + match FunDeclId.Map.find_opt f.def_id ctx.funs_filter_type_args_map with + | None -> (impl.generics.types, i_tys, f.signature.generics.types) + | Some filter -> + let filter_list filter ls = + let ls = List.combine filter ls in + List.filter_map (fun (b, ty) -> if b then Some ty else None) ls + in + let impl_types = impl.generics.types in + let impl_filter = + Collections.List.prefix (List.length impl_types) filter + in + let i_tys = i_tys in + let i_filter = Collections.List.prefix (List.length i_tys) filter in + ( filter_list impl_filter impl_types, + filter_list i_filter i_tys, + filter_list filter f.signature.generics.types ) + in + let f_generics = { f.signature.generics with types = f_tys } in (* Extract the generics - we need to quantify over the generics which are specific to the method, and call it will all the generics (trait impl + method generics) *) let f_generics = - generic_params_drop_prefix impl.generics f.signature.generics + generic_params_drop_prefix + { impl.generics with types = impl_types } + f_generics in + (* Register and print the quantified generics *) let ctx, f_tys, f_cgs, f_tcs = ctx_add_generic_params f_generics ctx in let use_forall = f_generics <> empty_generic_params in extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall f_generics @@ -4609,12 +2325,14 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) if use_forall then F.pp_print_string fmt ","; (* Extract the function call *) F.pp_print_space fmt (); - let id = ctx_get_local_function f.def_id None f.back_id ctx in - F.pp_print_string fmt id; + let fun_name = ctx_get_local_function f.def_id None f.back_id ctx in + F.pp_print_string fmt fun_name; let all_generics = - let i_tys, i_cgs, i_tcs = impl_generics in + let _, i_cgs, i_tcs = impl_generics in List.concat [ i_tys; f_tys; i_cgs; f_cgs; i_tcs; f_tcs ] in + + (* Filter the generics if the function is builtin *) List.iter (fun p -> F.pp_print_space fmt (); diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 3eef6b3b..7e8e4ffc 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -653,6 +653,8 @@ type extraction_ctx = { *) funs_filter_type_args_map : bool list FunDeclId.Map.t; (** Same as {!types_filter_type_args_map}, but for functions *) + trait_impls_filter_type_args_map : bool list TraitImplId.Map.t; + (** Same as {!types_filter_type_args_map}, but for trait implementations *) } (** Debugging function, used when communicating name collisions to the user, diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index c781463e..fa873c6a 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -122,7 +122,7 @@ let builtin_types () : builtin_type_info list = extract_name = (match !backend with | Lean -> "alloc.alloc.Global" - | Coq | FStar | HOL4 -> "alloc_global"); + | Coq | FStar | HOL4 -> "alloc_alloc_Global"); keep_params = None; body_info = None; }; @@ -130,7 +130,9 @@ let builtin_types () : builtin_type_info list = { rust_name = [ "alloc"; "vec"; "Vec" ]; extract_name = - (match !backend with Lean -> "Vec" | Coq | FStar | HOL4 -> "vec"); + (match !backend with + | Lean -> "alloc.vec.Vec" + | Coq | FStar | HOL4 -> "alloc_vec_Vec"); keep_params = Some [ true; false ]; body_info = None; }; @@ -170,15 +172,17 @@ let builtin_types () : builtin_type_info list = { rust_name = [ "core"; "ops"; "range"; "Range" ]; extract_name = - (match !backend with Lean -> "Range" | Coq | FStar | HOL4 -> "range"); + (match !backend with + | Lean -> "core.ops.range.Range" + | Coq | FStar | HOL4 -> "core_ops_range_Range"); keep_params = None; body_info = Some (Struct ( (match !backend with - | Lean -> "Range.mk" - | Coq | HOL4 -> "mk_range" - | FStar -> "Mkrange"), + | Lean -> "core.ops.range.Range.mk" + | Coq | HOL4 -> "mk_core_ops_range_Range" + | FStar -> "Mkcore_ops_range_Range"), [ "start"; "end_" ] )); }; ] @@ -204,340 +208,118 @@ type builtin_fun_info = { let builtin_funs () : (string list * bool list option * builtin_fun_info list) list = let rg0 = Some Types.RegionGroupId.zero in + (* Small utility *) + let mk_fun (name : string list) (extract_name : string list option) + (filter : bool list option) (with_back : bool) (back_no_suffix : bool) : + string list * bool list option * builtin_fun_info list = + let extract_name = + match extract_name with None -> name | Some name -> name + in + let fwd_name = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" extract_name + | Lean -> String.concat "." extract_name + in + let fwd_suffix = if with_back && back_no_suffix then "_fwd" else "" in + let fwd = [ { rg = None; extract_name = fwd_name ^ fwd_suffix } ] in + let back_suffix = if with_back && back_no_suffix then "" else "_back" in + let back = + if with_back then [ { rg = rg0; extract_name = fwd_name ^ back_suffix } ] + else [] + in + (name, filter, fwd @ back) + in [ - ( [ "core"; "mem"; "replace" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_mem_replace_fwd" - | Lean -> "core.mem.replace"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_mem_replace_back" - | Lean -> "core.mem.replace_back"); - }; - ] ); - ( [ "alloc"; "vec"; "Vec"; "new" ], - Some [ true; false ], - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_new" - | Lean -> "Vec.new"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_new_back" - | Lean -> "Vec.new_back"); - }; - ] ); - ( [ "alloc"; "vec"; "Vec"; "push" ], - Some [ true; false ], - [ - (* The forward function shouldn't be used *) - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_push_fwd" - | Lean -> "Vec.push_fwd"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_push_back" - | Lean -> "Vec.push"); - }; - ] ); - ( [ "alloc"; "vec"; "Vec"; "insert" ], - Some [ true; false ], - [ - (* The forward function shouldn't be used *) - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_insert_fwd" - | Lean -> "Vec.insert_fwd"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_insert_back" - | Lean -> "Vec.insert"); - }; - ] ); - ( [ "alloc"; "vec"; "Vec"; "len" ], - Some [ true; false ], - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_len" - | Lean -> "Vec.len"); - }; - ] ); - ( [ "alloc"; "vec"; "Vec"; "index" ], - Some [ true; false ], - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_index_fwd" - | Lean -> "Vec.index_shared"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_index_back" - | Lean -> "Vec.index_shared_back"); - }; - ] ); - ( [ "alloc"; "vec"; "Vec"; "index_mut" ], - Some [ true; false ], - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_index_mut_fwd" - | Lean -> "Vec.index_mut"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "vec_index_mut_back" - | Lean -> "Vec.index_mut_back"); - }; - ] ); - ( [ "alloc"; "boxed"; "Box"; "deref" ], - Some [ true; false ], - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_Box_deref" - | Lean -> "alloc.boxed.Box.deref"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_Box_deref_back" - | Lean -> "alloc.boxed.Box.deref_back"); - }; - ] ); - ( [ "alloc"; "boxed"; "Box"; "deref_mut" ], - Some [ true; false ], - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_Box_deref_mut" - | Lean -> "alloc.boxed.Box.deref_mut"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "alloc_boxed_box_deref_mut_back" - | Lean -> "alloc.boxed.Box.deref_mut_back"); - }; - ] ); + mk_fun [ "core"; "mem"; "replace" ] None None true false; + mk_fun [ "alloc"; "vec"; "Vec"; "new" ] None None false false; + mk_fun + [ "alloc"; "vec"; "Vec"; "push" ] + None + (Some [ true; false ]) + true true; + mk_fun + [ "alloc"; "vec"; "Vec"; "insert" ] + None + (Some [ true; false ]) + true true; + mk_fun + [ "alloc"; "vec"; "Vec"; "len" ] + None + (Some [ true; false ]) + true false; + mk_fun + [ "alloc"; "vec"; "Vec"; "index" ] + None + (Some [ true; true; false ]) + true false; + mk_fun + [ "alloc"; "vec"; "Vec"; "index_mut" ] + None + (Some [ true; true; false ]) + true false; + mk_fun + [ "alloc"; "boxed"; "Box"; "deref" ] + None + (Some [ true; false ]) + true false; + mk_fun + [ "alloc"; "boxed"; "Box"; "deref_mut" ] + None + (Some [ true; false ]) + true false; (* TODO: fix the same like "[T]" below *) - ( [ "core"; "slice"; "index"; "[T]"; "index" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Slice_index" - | Lean -> "core.slice.index.Slice.index"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Slice_index_back" - | Lean -> "core.slice.index.Slice.index_back"); - }; - ] ); - ( [ "core"; "slice"; "index"; "[T]"; "index_mut" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Slice_index_mut" - | Lean -> "core.slice.index.Slice.index_mut"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Slice_index_mut_back" - | Lean -> "core.slice.index.Slice.index_mut_back"); - }; - ] ); - ( [ "core"; "array"; "[T; N]"; "index" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_array_Array_index" - | Lean -> "core.array.Array.index"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_array_Array_index_back" - | Lean -> "core.array.Array.index_back"); - }; - ] ); - ( [ "core"; "array"; "[T; N]"; "index_mut" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_array_Array_index_mut" - | Lean -> "core.array.Array.index_mut"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_array_Array_index_mut_back" - | Lean -> "core.array.Array.index_mut_back"); - }; - ] ); - ( [ "core"; "slice"; "index"; "Range"; "get" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_get" - | Lean -> "core.slice.index.Range.get"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_get_back" - | Lean -> "core.slice.index.Range.get_back"); - }; - ] ); - ( [ "core"; "slice"; "index"; "Range"; "get_mut" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_get_mut" - | Lean -> "core.slice.index.Range.get_mut"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_get_mut_back" - | Lean -> "core.slice.index.Range.get_mut_back"); - }; - ] ); - ( [ "core"; "slice"; "index"; "Range"; "index" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_index" - | Lean -> "core.slice.index.Range.index"); - }; - (* The backward function shouldn't be used *) - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_index_back" - | Lean -> "core.slice.index.Range.index_back"); - }; - ] ); - ( [ "core"; "slice"; "index"; "Range"; "index_mut" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_index_mut" - | Lean -> "core.slice.index.Range.index_mut"); - }; - { - rg = rg0; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_index_mut_back" - | Lean -> "core.slice.index.Range.index_mut_back"); - }; - ] ); - ( [ "core"; "slice"; "index"; "Range"; "get_unchecked" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_get_unchecked" - | Lean -> "core.slice.index.Range.get_unchecked"); - }; - ] ); - ( [ "core"; "slice"; "index"; "Range"; "get_unchecked_mut" ], - None, - [ - { - rg = None; - extract_name = - (match !backend with - | FStar | Coq | HOL4 -> "core_slice_index_Range_get_unchecked_mut" - | Lean -> "core.slice.index.Range.get_unchecked_mut"); - }; - ] ); + mk_fun + [ "core"; "slice"; "index"; "[T]"; "index" ] + (Some [ "core"; "slice"; "index"; "Slice"; "index" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "[T]"; "index_mut" ] + (Some [ "core"; "slice"; "index"; "Slice"; "index_mut" ]) + None true false; + mk_fun + [ "core"; "array"; "[T; N]"; "index" ] + (Some [ "core"; "array"; "Array"; "index" ]) + None true false; + mk_fun + [ "core"; "array"; "[T; N]"; "index_mut" ] + (Some [ "core"; "array"; "Array"; "index_mut" ]) + None true false; + mk_fun [ "core"; "slice"; "index"; "Range"; "get" ] None None true false; + mk_fun [ "core"; "slice"; "index"; "Range"; "get_mut" ] None None true false; + mk_fun [ "core"; "slice"; "index"; "Range"; "index" ] None None true false; + mk_fun + [ "core"; "slice"; "index"; "Range"; "index_mut" ] + None None true false; + mk_fun + [ "core"; "slice"; "index"; "Range"; "get_unchecked" ] + None None false false; + mk_fun + [ "core"; "slice"; "index"; "Range"; "get_unchecked_mut" ] + None None false false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get_mut" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get_mut" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get_unchecked" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get_unchecked" ]) + None false false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "get_unchecked_mut" ] + (Some [ "core"; "slice"; "index"; "Usize"; "get_unchecked_mut" ]) + None false false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "index" ] + (Some [ "core"; "slice"; "index"; "Usize"; "index" ]) + None true false; + mk_fun + [ "core"; "slice"; "index"; "usize"; "index_mut" ] + (Some [ "core"; "slice"; "index"; "Usize"; "index_mut" ]) + None true false; ] let mk_builtin_funs_map () = @@ -576,6 +358,8 @@ let builtin_non_fallible_funs = in let int_funs = List.concat int_funs in [ + "alloc::vec::Vec::new"; + "alloc::vec::Vec::len"; "alloc::boxed::Box::deref"; "alloc::boxed::Box::deref_mut"; "core::mem::replace"; @@ -847,37 +631,68 @@ end module SimpleNamePairMap = Collections.MakeMap (SimpleNamePairOrd) -let builtin_trait_impls_info () : ((string list * string list) * string) list = +let builtin_trait_impls_info () : + ((string list * string list) * (bool list option * string)) list = + let fmt ?(filter : bool list option = None) (name : string) : + bool list option * string = + let name = + match !backend with + | Lean -> name + | FStar | Coq | HOL4 -> + let name = String.split_on_char '.' name in + String.concat "_" name + in + (filter, name) + in (* TODO: fix the names like "[T]" below *) [ (* core::ops::Deref> *) ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "Deref" ]), - "alloc.boxed.Box.coreOpsDerefInst" ); + fmt "alloc.boxed.Box.coreOpsDerefInst" ); (* core::ops::DerefMut> *) ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "DerefMut" ]), - "alloc.boxed.Box.coreOpsDerefMutInst" ); + fmt "alloc.boxed.Box.coreOpsDerefMutInst" ); (* core::ops::index::Index<[T], I> *) ( ([ "core"; "slice"; "index"; "[T]" ], [ "core"; "ops"; "index"; "Index" ]), - "core.slice.index.Slice.coreopsindexIndexInst" ); + fmt "core.slice.index.Slice.coreopsindexIndexInst" ); (* core::slice::index::private_slice_index::Sealed> *) ( ( [ "core"; "slice"; "index"; "private_slice_index"; "Range" ], [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] ), - "core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst" + fmt + "core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst" ); (* core::slice::index::SliceIndex, [T]> *) ( ( [ "core"; "slice"; "index"; "Range" ], [ "core"; "slice"; "index"; "SliceIndex" ] ), - "core.slice.index.Range.coresliceindexSliceIndexInst" ); + fmt "core.slice.index.Range.coresliceindexSliceIndexInst" ); (* core::ops::index::IndexMut<[T], I> *) ( ( [ "core"; "slice"; "index"; "[T]" ], [ "core"; "ops"; "index"; "IndexMut" ] ), - "core.slice.index.Slice.coreopsindexIndexMutInst" ); + fmt "core.slice.index.Slice.coreopsindexIndexMutInst" ); (* core::ops::index::Index<[T; N], I> *) ( ([ "core"; "array"; "[T; N]" ], [ "core"; "ops"; "index"; "Index" ]), - "core.array.Array.coreopsindexIndexInst" ); + fmt "core.array.Array.coreopsindexIndexInst" ); (* core::ops::index::IndexMut<[T; N], I> *) ( ([ "core"; "array"; "[T; N]" ], [ "core"; "ops"; "index"; "IndexMut" ]), - "core.array.Array.coreopsindexIndexMutInst" ); + fmt "core.array.Array.coreopsindexIndexMutInst" ); + (* core::slice::index::private_slice_index::Sealed *) + ( ( [ "core"; "slice"; "index"; "private_slice_index"; "usize" ], + [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] ), + fmt + "core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst" + ); + (* core::slice::index::SliceIndex *) + ( ( [ "core"; "slice"; "index"; "usize" ], + [ "core"; "slice"; "index"; "SliceIndex" ] ), + fmt "core.slice.index.usize.coresliceindexSliceIndexInst" ); + (* core::ops::index::Index, T> *) + ( ([ "alloc"; "vec"; "Vec" ], [ "core"; "ops"; "index"; "Index" ]), + let filter = Some [ true; true; false ] in + fmt ~filter "alloc.vec.Vec.coreopsindexIndexInst" ); + (* core::ops::index::IndexMut, T> *) + ( ([ "alloc"; "vec"; "Vec" ], [ "core"; "ops"; "index"; "IndexMut" ]), + let filter = Some [ true; true; false ] in + fmt ~filter "alloc.vec.Vec.coreopsindexIndexMutInst" ); ] let mk_builtin_trait_impls_map () = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml new file mode 100644 index 00000000..219f273f --- /dev/null +++ b/compiler/ExtractTypes.ml @@ -0,0 +1,2390 @@ +(** The generic extraction *) +(* Turn the whole module into a functor: it is very annoying to carry the + the formatter everywhere... +*) + +open Pure +open PureUtils +open TranslateCore +open ExtractBase +open StringUtils +open Config +module F = Format + +(** Small helper to compute the name of an int type *) +let int_name (int_ty : integer_type) = + let isize, usize, i_format, u_format = + match !backend with + | FStar | Coq | HOL4 -> + ("isize", "usize", format_of_string "i%d", format_of_string "u%d") + | Lean -> ("Isize", "Usize", format_of_string "I%d", format_of_string "U%d") + in + match int_ty with + | Isize -> isize + | I8 -> Printf.sprintf i_format 8 + | I16 -> Printf.sprintf i_format 16 + | I32 -> Printf.sprintf i_format 32 + | I64 -> Printf.sprintf i_format 64 + | I128 -> Printf.sprintf i_format 128 + | Usize -> usize + | U8 -> Printf.sprintf u_format 8 + | U16 -> Printf.sprintf u_format 16 + | U32 -> Printf.sprintf u_format 32 + | U64 -> Printf.sprintf u_format 64 + | U128 -> Printf.sprintf u_format 128 + +(** Small helper to compute the name of a unary operation *) +let unop_name (unop : unop) : string = + match unop with + | Not -> ( + match !backend with FStar | Lean -> "not" | Coq -> "negb" | HOL4 -> "~") + | Neg (int_ty : integer_type) -> ( + match !backend with Lean -> "-" | _ -> int_name int_ty ^ "_neg") + | Cast _ -> + (* We never directly use the unop name in this case *) + raise (Failure "Unsupported") + +(** Small helper to compute the name of a binary operation (note that many + binary operations like "less than" are extracted to primitive operations, + like [<]). + *) +let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = + let binop = + match binop with + | Div -> "div" + | Rem -> "rem" + | Add -> "add" + | Sub -> "sub" + | Mul -> "mul" + | Lt -> "lt" + | Le -> "le" + | Ge -> "ge" + | Gt -> "gt" + | BitXor -> "xor" + | BitAnd -> "and" + | BitOr -> "or" + | Shl -> "lsl" + | 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 *) + match !backend with + | Lean -> int_name int_ty ^ "." ^ binop + | FStar | Coq | HOL4 -> int_name int_ty ^ "_" ^ binop + +(** A list of keywords/identifiers used by the backend and with which we + want to check collision. + + Remark: this is useful mostly to look for collisions when generating + names for *variables*. + *) +let keywords () = + let named_unops = + unop_name Not + :: List.map (fun it -> unop_name (Neg it)) T.all_signed_int_types + in + let named_binops = [ E.Div; Rem; Add; Sub; Mul ] in + let named_binops = + List.concat_map + (fun bn -> List.map (fun it -> named_binop_name bn it) T.all_int_types) + named_binops + in + let misc = + match !backend with + | FStar -> + [ + "assert"; + "assert_norm"; + "assume"; + "else"; + "fun"; + "fn"; + "FStar"; + "FStar.Mul"; + "if"; + "in"; + "include"; + "int"; + "let"; + "list"; + "match"; + "not"; + "open"; + "rec"; + "scalar_cast"; + "then"; + "type"; + "Type0"; + "Type"; + "unit"; + "val"; + "with"; + ] + | Coq -> + [ + "assert"; + "Arguments"; + "Axiom"; + "char_of_byte"; + "Check"; + "Declare"; + "Definition"; + "else"; + "End"; + "fun"; + "Fixpoint"; + "if"; + "in"; + "int"; + "Inductive"; + "Import"; + "let"; + "Lemma"; + "match"; + "Module"; + "not"; + "Notation"; + "Proof"; + "Qed"; + "rec"; + "Record"; + "Require"; + "Scope"; + "Search"; + "SearchPattern"; + "Set"; + "then"; + (* [tt] is unit *) + "tt"; + "type"; + "Type"; + "unit"; + "with"; + ] + | Lean -> + [ + "by"; + "class"; + "decreasing_by"; + "def"; + "deriving"; + "do"; + "else"; + "end"; + "for"; + "have"; + "if"; + "inductive"; + "instance"; + "import"; + "let"; + "macro"; + "match"; + "namespace"; + "opaque"; + "open"; + "run_cmd"; + "set_option"; + "simp"; + "structure"; + "syntax"; + "termination_by"; + "then"; + "Type"; + "unsafe"; + "where"; + "with"; + "opaque_defs"; + ] + | HOL4 -> + [ + "Axiom"; + "case"; + "Definition"; + "else"; + "End"; + "fix"; + "fix_exec"; + "fn"; + "fun"; + "if"; + "in"; + "int"; + "Inductive"; + "let"; + "of"; + "Proof"; + "QED"; + "then"; + "Theorem"; + ] + in + List.concat [ named_unops; named_binops; misc ] + +let assumed_adts () : (assumed_ty * string) list = + match !backend with + | Lean -> + [ + (State, "State"); + (Result, "Result"); + (Error, "Error"); + (Fuel, "Nat"); + (Array, "Array"); + (Slice, "Slice"); + (Str, "Str"); + (RawPtr Mut, "MutRawPtr"); + (RawPtr Const, "ConstRawPtr"); + ] + | Coq | FStar | HOL4 -> + [ + (State, "state"); + (Result, "result"); + (Error, "error"); + (Fuel, if !backend = HOL4 then "num" else "nat"); + (Array, "array"); + (Slice, "slice"); + (Str, "str"); + (RawPtr Mut, "mut_raw_ptr"); + (RawPtr Const, "const_raw_ptr"); + ] + +let assumed_struct_constructors () : (assumed_ty * string) list = + match !backend with + | Lean -> [ (Array, "Array.make") ] + | Coq -> [ (Array, "mk_array") ] + | FStar -> [ (Array, "mk_array") ] + | HOL4 -> [ (Array, "mk_array") ] + +let assumed_variants () : (assumed_ty * VariantId.id * string) list = + match !backend with + | FStar -> + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail"); + (Error, error_failure_id, "Failure"); + (Error, error_out_of_fuel_id, "OutOfFuel"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + | Coq -> + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail_"); + (Error, error_failure_id, "Failure"); + (Error, error_out_of_fuel_id, "OutOfFuel"); + (Fuel, fuel_zero_id, "O"); + (Fuel, fuel_succ_id, "S"); + ] + | Lean -> + [ + (Result, result_return_id, "ret"); + (Result, result_fail_id, "fail"); + (Error, error_failure_id, "panic"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + | HOL4 -> + [ + (Result, result_return_id, "Return"); + (Result, result_fail_id, "Fail"); + (Error, error_failure_id, "Failure"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + +let assumed_llbc_functions () : + (A.assumed_fun_id * T.RegionGroupId.id option * string) list = + let rg0 = Some T.RegionGroupId.zero in + match !backend with + | FStar | Coq | HOL4 -> + [ + (ArrayIndexShared, None, "array_index_shared"); + (ArrayIndexMut, None, "array_index_mut_fwd"); + (ArrayIndexMut, rg0, "array_index_mut_back"); + (ArrayToSliceShared, None, "array_to_slice_shared"); + (ArrayToSliceMut, None, "array_to_slice_mut_fwd"); + (ArrayToSliceMut, rg0, "array_to_slice_mut_back"); + (ArrayRepeat, None, "array_repeat"); + (SliceIndexShared, None, "slice_index_shared"); + (SliceIndexMut, None, "slice_index_mut_fwd"); + (SliceIndexMut, rg0, "slice_index_mut_back"); + (SliceLen, None, "slice_len"); + ] + | Lean -> + [ + (ArrayIndexShared, None, "Array.index_shared"); + (ArrayIndexMut, None, "Array.index_mut"); + (ArrayIndexMut, rg0, "Array.index_mut_back"); + (ArrayToSliceShared, None, "Array.to_slice_shared"); + (ArrayToSliceMut, None, "Array.to_slice_mut"); + (ArrayToSliceMut, rg0, "Array.to_slice_mut_back"); + (ArrayRepeat, None, "Array.repeat"); + (SliceIndexShared, None, "Slice.index_shared"); + (SliceIndexMut, None, "Slice.index_mut"); + (SliceIndexMut, rg0, "Slice.index_mut_back"); + (SliceLen, None, "Slice.len"); + ] + +let assumed_pure_functions () : (pure_assumed_fun_id * string) list = + match !backend with + | FStar -> + [ + (Return, "return"); + (Fail, "fail"); + (Assert, "massert"); + (FuelDecrease, "decrease"); + (FuelEqZero, "is_zero"); + ] + | Coq -> + (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) + [ (Return, "return_"); (Fail, "fail_"); (Assert, "massert") ] + | Lean -> + (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) + [ (Return, "return"); (Fail, "fail_"); (Assert, "massert") ] + | HOL4 -> + (* We don't provide [FuelDecrease] and [FuelEqZero] on purpose *) + [ (Return, "return"); (Fail, "fail"); (Assert, "massert") ] + +let names_map_init () : names_map_init = + { + keywords = keywords (); + assumed_adts = assumed_adts (); + assumed_structs = assumed_struct_constructors (); + assumed_variants = assumed_variants (); + assumed_llbc_functions = assumed_llbc_functions (); + assumed_pure_functions = assumed_pure_functions (); + } + +let extract_unop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit + = + match unop with + | Not | Neg _ -> + let unop = unop_name unop in + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt unop; + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")" + | Cast (src, tgt) -> ( + (* HOL4 has a special treatment: because it doesn't support dependent + types, we don't have a specific operator for the cast *) + match !backend with + | HOL4 -> + (* Casting, say, an u32 to an i32 would be done as follows: + {[ + mk_i32 (u32_to_int x) + ]} + *) + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt ("mk_" ^ int_name tgt); + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + F.pp_print_string fmt (int_name src ^ "_to_int"); + F.pp_print_space fmt (); + extract_expr true arg; + F.pp_print_string fmt ")"; + if inside then F.pp_print_string fmt ")" + | FStar | Coq | Lean -> + (* Rem.: the source type is an implicit parameter *) + if inside then F.pp_print_string fmt "("; + let cast_str = + match !backend with + | Coq | FStar -> "scalar_cast" + | Lean -> (* TODO: I8.cast, I16.cast, etc.*) "Scalar.cast" + | HOL4 -> raise (Failure "Unreachable") + in + F.pp_print_string fmt cast_str; + F.pp_print_space fmt (); + if !backend <> Lean then ( + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string src)); + F.pp_print_space fmt ()); + if !backend = Lean then F.pp_print_string fmt ("." ^ int_name tgt) + else + F.pp_print_string fmt + (StringUtils.capitalize_first_letter + (PrintPure.integer_type_to_string tgt)); + F.pp_print_space fmt (); + extract_expr true arg; + if inside then F.pp_print_string fmt ")") + +(** [extract_expr] : the boolean argument is [inside] *) +let extract_binop (extract_expr : bool -> texpression -> unit) + (fmt : F.formatter) (inside : bool) (binop : E.binop) + (int_ty : integer_type) (arg0 : texpression) (arg1 : texpression) : unit = + if inside then F.pp_print_string fmt "("; + (* Some binary operations have a special notation depending on the backend *) + (match (!backend, binop) with + | HOL4, (Eq | Ne) + | (FStar | Coq | Lean), (Eq | Lt | Le | Ne | Ge | Gt) + | Lean, (Div | Rem | Add | Sub | Mul) -> + let binop = + match binop with + | Eq -> "=" + | Lt -> "<" + | Le -> "<=" + | Ne -> if !backend = Lean then "!=" else "<>" + | Ge -> ">=" + | Gt -> ">" + | Div -> "/" + | Rem -> "%" + | Add -> "+" + | Sub -> "-" + | Mul -> "*" + | _ -> raise (Failure "Unreachable") + in + let binop = + match !backend with FStar | Lean | HOL4 -> binop | Coq -> "s" ^ binop + in + extract_expr false arg0; + F.pp_print_space fmt (); + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr false arg1 + | _ -> + let binop = named_binop_name binop int_ty in + F.pp_print_string fmt binop; + F.pp_print_space fmt (); + extract_expr true arg0; + F.pp_print_space fmt (); + extract_expr true arg1); + if inside then F.pp_print_string fmt ")" + +let type_decl_kind_to_qualif (kind : decl_kind) + (type_kind : type_decl_kind option) : string option = + match !backend with + | FStar -> ( + match kind with + | SingleNonRec -> Some "type" + | SingleRec -> Some "type" + | MutRecFirst -> Some "type" + | MutRecInner -> Some "and" + | MutRecLast -> Some "and" + | Assumed -> Some "assume type" + | Declared -> Some "val") + | Coq -> ( + match (kind, type_kind) with + | SingleNonRec, Some Enum -> Some "Inductive" + | SingleNonRec, Some Struct -> Some "Record" + | (SingleRec | MutRecFirst), Some _ -> Some "Inductive" + | (MutRecInner | MutRecLast), Some _ -> + (* Coq doesn't support groups of mutually recursive definitions which mix + * records and inducties: we convert everything to records if this happens + *) + Some "with" + | (Assumed | Declared), None -> Some "Axiom" + | SingleNonRec, None -> + (* This is for traits *) + Some "Record" + | _ -> + raise + (Failure + ("Unexpected: (" ^ show_decl_kind kind ^ ", " + ^ Print.option_to_string show_type_decl_kind type_kind + ^ ")"))) + | Lean -> ( + match kind with + | SingleNonRec -> + if type_kind = Some Struct then Some "structure" else Some "inductive" + | SingleRec -> Some "inductive" + | MutRecFirst -> Some "inductive" + | MutRecInner -> Some "inductive" + | MutRecLast -> Some "inductive" + | Assumed -> Some "axiom" + | Declared -> Some "axiom") + | HOL4 -> None + +let fun_decl_kind_to_qualif (kind : decl_kind) : string option = + match !backend with + | FStar -> ( + match kind with + | SingleNonRec -> Some "let" + | SingleRec -> Some "let rec" + | MutRecFirst -> Some "let rec" + | MutRecInner -> Some "and" + | MutRecLast -> Some "and" + | Assumed -> Some "assume val" + | Declared -> Some "val") + | Coq -> ( + match kind with + | SingleNonRec -> Some "Definition" + | SingleRec -> Some "Fixpoint" + | MutRecFirst -> Some "Fixpoint" + | MutRecInner -> Some "with" + | MutRecLast -> Some "with" + | Assumed -> Some "Axiom" + | Declared -> Some "Axiom") + | Lean -> ( + match kind with + | SingleNonRec -> Some "def" + | SingleRec -> Some "divergent def" + | MutRecFirst -> Some "mutual divergent def" + | MutRecInner -> Some "divergent def" + | MutRecLast -> Some "divergent def" + | Assumed -> Some "axiom" + | Declared -> Some "axiom") + | HOL4 -> None + +(** The type of types. + + TODO: move inside the formatter? + *) +let type_keyword () = + match !backend with + | FStar -> "Type0" + | Coq | Lean -> "Type" + | HOL4 -> raise (Failure "Unexpected") + +(** + [ctx]: we use the context to lookup type definitions, to retrieve type names. + This is used to compute variable names, when they have no basenames: in this + case we use the first letter of the type name. + + [variant_concatenate_type_name]: if true, add the type name as a prefix + to the variant names. + Ex.: + In Rust: + {[ + enum List = { + Cons(u32, Box),x + Nil, + } + ]} + + F*, if option activated: + {[ + type list = + | ListCons : u32 -> list -> list + | ListNil : list + ]} + + F*, if option not activated: + {[ + type list = + | Cons : u32 -> list -> list + | Nil : list + ]} + + Rk.: this should be true by default, because in Rust all the variant names + are actively uniquely identifier by the type name [List::Cons(...)], while + in other languages it is not necessarily the case, and thus clashes can mess + up type checking. Note that some languages actually forbids the name clashes + (it is the case of F* ). + *) +let mk_formatter (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter = + let int_name = int_name in + + (* Prepare a name. + * The first id elem is always the crate: if it is the local crate, + * we remove it. + * We also remove all the disambiguators, then convert everything to strings. + * **Rmk:** because we remove the disambiguators, there may be name collisions + * (which is ok, because we check for name collisions and fail if there is any). + *) + let get_name (name : name) : string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + let name = Names.filter_disambiguators name in + match name with + | Ident crate :: name -> + let name = if crate = crate_name then name else Ident crate :: name in + let name = + List.map + (function + | Names.Ident s -> s + | Disambiguator d -> Names.Disambiguator.to_string d) + name + in + name + | _ -> + raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) + in + let flatten_name (name : string list) : string = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" name + | Lean -> String.concat "." name + in + let get_type_name = get_name in + let type_name_to_camel_case name = + let name = get_type_name name in + let name = List.map to_camel_case name in + String.concat "" name + in + let type_name_to_snake_case name = + let name = get_type_name name in + let name = List.map to_snake_case name in + let name = String.concat "_" name in + match !backend with + | FStar | Lean | HOL4 -> name + | Coq -> capitalize_first_letter name + in + let type_name name = + match !backend with + | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_t" + | Lean -> String.concat "." (get_type_name name) + in + let field_name (def_name : name) (field_id : FieldId.id) + (field_name : string option) : string = + let field_name_s = + match field_name with + | Some field_name -> field_name + | None -> + (* TODO: extract structs with no field names to tuples *) + FieldId.to_string field_id + in + if !Config.record_fields_short_names then + if field_name = None then (* TODO: this is a bit ugly *) + "_" ^ field_name_s + else field_name_s + else + let def_name = type_name_to_snake_case def_name ^ "_" in + def_name ^ field_name_s + in + let variant_name (def_name : name) (variant : string) : string = + match !backend with + | FStar | Coq | HOL4 -> + let variant = to_camel_case variant in + if variant_concatenate_type_name then + type_name_to_camel_case def_name ^ variant + else variant + | Lean -> variant + in + let struct_constructor (basename : name) : string = + let tname = type_name basename in + let prefix = + match !backend with FStar -> "Mk" | Coq | HOL4 -> "mk" | Lean -> "" + in + let suffix = + match !backend with FStar | Coq | HOL4 -> "" | Lean -> ".mk" + in + prefix ^ tname ^ suffix + in + let get_fun_name fname = + let fname = get_name fname in + (* TODO: don't convert to snake case for Coq, HOL4, F* *) + flatten_name fname + in + let global_name (name : global_name) : string = + (* Converting to snake case also lowercases the letters (in Rust, global + * names are written in capital letters). *) + let parts = List.map to_snake_case (get_name name) in + String.concat "_" parts + in + let fun_name (fname : fun_name) (num_loops : int) (loop_id : LoopId.id option) + (num_rgs : int) (rg : region_group_info option) (filter_info : bool * int) + : string = + let fname = get_fun_name fname in + (* Compute the suffix *) + let suffix = default_fun_suffix num_loops loop_id num_rgs rg filter_info in + (* Concatenate *) + fname ^ suffix + in + + let trait_decl_name (trait_decl : trait_decl) : string = + type_name trait_decl.name + in + + let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : + string = + (* TODO: provisional: we concatenate the trait impl name (which is its type) + with the trait decl name *) + let trait_decl = + let name = trait_decl.name in + match !backend with + | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_inst" + | Lean -> String.concat "" (get_type_name name) ^ "Inst" + in + flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) + in + + let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) + : string = + (* TODO: improve - it would be better to not use indices *) + let clause = "parent_clause_" ^ TraitClauseId.to_string clause.clause_id in + if !Config.record_fields_short_names then clause + else trait_decl_name trait_decl ^ "_" ^ clause + in + let trait_type_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_const_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_method_name (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + let trait_type_clause_name (trait_decl : trait_decl) (item : string) + (clause : trait_clause) : string = + (* TODO: improve - it would be better to not use indices *) + trait_type_name trait_decl item + ^ "_clause_" + ^ TraitClauseId.to_string clause.clause_id + in + + let termination_measure_name (_fid : A.FunDeclId.id) (fname : fun_name) + (num_loops : int) (loop_id : LoopId.id option) : string = + let fname = get_fun_name fname in + let lp_suffix = default_fun_loop_suffix num_loops loop_id in + (* Compute the suffix *) + let suffix = + match !Config.backend with + | FStar -> "_decreases" + | Lean -> "_terminates" + | Coq | HOL4 -> raise (Failure "Unexpected") + in + (* Concatenate *) + fname ^ lp_suffix ^ suffix + in + + let decreases_proof_name (_fid : A.FunDeclId.id) (fname : fun_name) + (num_loops : int) (loop_id : LoopId.id option) : string = + let fname = get_fun_name fname in + let lp_suffix = default_fun_loop_suffix num_loops loop_id in + (* Compute the suffix *) + let suffix = + match !Config.backend with + | Lean -> "_decreases" + | FStar | Coq | HOL4 -> raise (Failure "Unexpected") + in + (* Concatenate *) + fname ^ lp_suffix ^ suffix + in + + let var_basename (_varset : StringSet.t) (basename : string option) (ty : ty) + : string = + (* Small helper to derive var names from ADT type names. + + We do the following: + - convert the type name to snake case + - take the first letter of every "letter group" + Ex.: "HashMap" -> "hash_map" -> "hm" + *) + let name_from_type_ident (name : string) : string = + let cl = to_snake_case name in + let cl = String.split_on_char '_' cl in + let cl = List.filter (fun s -> String.length s > 0) cl in + assert (List.length cl > 0); + let cl = List.map (fun s -> s.[0]) cl in + StringUtils.string_of_chars cl + in + (* If there is a basename, we use it *) + match basename with + | Some basename -> + (* This should be a no-op *) + to_snake_case basename + | None -> ( + (* No basename: we use the first letter of the type *) + match ty with + | Adt (type_id, generics) -> ( + match type_id with + | Tuple -> + (* The "pair" case is frequent enough to have its special treatment *) + if List.length generics.types = 2 then "p" else "t" + | Assumed Result -> "r" + | Assumed Error -> ConstStrings.error_basename + | Assumed Fuel -> ConstStrings.fuel_basename + | Assumed Array -> "a" + | Assumed Slice -> "s" + | Assumed Str -> "s" + | Assumed State -> ConstStrings.state_basename + | Assumed (RawPtr _) -> "p" + | 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 + * Ex.: ["hashmap"; "HashMap"] ~~> "HashMap" -> "hash_map" -> "hm" + *) + (* The name shouldn't be empty, and its last element should + * be an ident *) + let cl = List.nth def.name (List.length def.name - 1) in + name_from_type_ident (Names.as_ident cl)) + | TypeVar _ -> ( + (* TODO: use "t" also for F* *) + match !backend with + | FStar -> "x" (* lacking inspiration here... *) + | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) + | Literal lty -> ( + match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") + | Arrow _ -> "f" + | TraitType (_, _, name) -> name_from_type_ident name) + in + let type_var_basename (_varset : StringSet.t) (basename : string) : string = + (* Rust type variables are snake-case and start with a capital letter *) + match !backend with + | FStar -> + (* This is *not* a no-op: this removes the capital letter *) + to_snake_case basename + | HOL4 -> + (* In HOL4, type variable names must start with "'" *) + "'" ^ to_snake_case basename + | Coq | Lean -> basename + in + let const_generic_var_basename (_varset : StringSet.t) (basename : string) : + string = + (* Rust type variables are snake-case and start with a capital letter *) + match !backend with + | FStar | HOL4 -> + (* This is *not* a no-op: this removes the capital letter *) + to_snake_case basename + | Coq | Lean -> basename + in + let trait_clause_basename (_varset : StringSet.t) (_clause : trait_clause) : + string = + (* TODO: actually use the clause to derive the name *) + "inst" + in + let trait_self_clause_basename = "self_clause" in + let append_index (basename : string) (i : int) : string = + basename ^ string_of_int i + in + + let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit + = + match cv with + | Scalar sv -> ( + match !backend with + | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) + | Coq | HOL4 | Lean -> + let print_brackets = inside && !backend = HOL4 in + if print_brackets then F.pp_print_string fmt "("; + (match !backend with + | Coq | Lean -> () + | HOL4 -> + F.pp_print_string fmt ("int_to_" ^ int_name sv.PV.int_ty); + F.pp_print_space fmt () + | _ -> raise (Failure "Unreachable")); + (* We need to add parentheses if the value is negative *) + if sv.PV.value >= Z.of_int 0 then + F.pp_print_string fmt (Z.to_string sv.PV.value) + else if !backend = Lean then + (* TODO: parsing issues with Lean because there are ambiguous + interpretations between int values and nat values *) + F.pp_print_string fmt + ("(-(" ^ Z.to_string (Z.neg sv.PV.value) ^ ":Int))") + else F.pp_print_string fmt ("(" ^ Z.to_string sv.PV.value ^ ")"); + (match !backend with + | Coq -> + let iname = int_name sv.PV.int_ty in + F.pp_print_string fmt ("%" ^ iname) + | Lean -> + let iname = String.lowercase_ascii (int_name sv.PV.int_ty) in + F.pp_print_string fmt ("#" ^ iname) + | HOL4 -> () + | _ -> raise (Failure "Unreachable")); + if print_brackets then F.pp_print_string fmt ")") + | Bool b -> + let b = + match !backend with + | HOL4 -> if b then "T" else "F" + | Coq | FStar | Lean -> if b then "true" else "false" + in + F.pp_print_string fmt b + | Char c -> ( + match !backend with + | HOL4 -> + (* [#"a"] is a notation for [CHR 97] (97 is the ASCII code for 'a') *) + F.pp_print_string fmt ("#\"" ^ String.make 1 c ^ "\"") + | FStar | Lean -> F.pp_print_string fmt ("'" ^ String.make 1 c ^ "'") + | Coq -> + if inside then F.pp_print_string fmt "("; + F.pp_print_string fmt "char_of_byte"; + F.pp_print_space fmt (); + (* Convert the the char to ascii *) + let c = + let i = Char.code c in + let x0 = i / 16 in + let x1 = i mod 16 in + "Coq.Init.Byte.x" ^ string_of_int x0 ^ string_of_int x1 + in + F.pp_print_string fmt c; + if inside then F.pp_print_string fmt ")") + in + let bool_name = if !backend = Lean then "Bool" else "bool" in + let char_name = if !backend = Lean then "Char" else "char" in + let str_name = if !backend = Lean then "String" else "string" in + { + bool_name; + char_name; + int_name; + str_name; + type_decl_kind_to_qualif; + fun_decl_kind_to_qualif; + field_name; + variant_name; + struct_constructor; + type_name; + global_name; + fun_name; + termination_measure_name; + decreases_proof_name; + trait_decl_name; + trait_impl_name; + trait_parent_clause_name; + trait_const_name; + trait_type_name; + trait_method_name; + trait_type_clause_name; + var_basename; + type_var_basename; + const_generic_var_basename; + trait_self_clause_basename; + trait_clause_basename; + append_index; + extract_literal; + extract_unop; + extract_binop; + } + +let mk_formatter_and_names_map (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter * names_map = + let fmt = mk_formatter ctx crate_name variant_concatenate_type_name in + let names_map = initialize_names_map fmt (names_map_init ()) in + (fmt, names_map) + +let is_single_opaque_fun_decl_group (dg : Pure.fun_decl list) : bool = + match dg with [ d ] -> d.body = None | _ -> false + +let is_single_opaque_type_decl_group (dg : Pure.type_decl list) : bool = + match dg with [ d ] -> d.kind = Opaque | _ -> false + +let is_empty_record_type_decl (d : Pure.type_decl) : bool = d.kind = Struct [] + +let is_empty_record_type_decl_group (dg : Pure.type_decl list) : bool = + match dg with [ d ] -> is_empty_record_type_decl d | _ -> false + +(** In some provers, groups of definitions must be delimited. + + - in Coq, *every* group (including singletons) must end with "." + - in Lean, groups of mutually recursive definitions must end with "end" + - in HOL4 (in most situations) the whole group must be within a `Define` command + + Calls to {!extract_fun_decl} should be inserted between calls to + {!start_fun_decl_group} and {!end_fun_decl_group}. + + TODO: maybe those [{start/end}_decl_group] functions are not that much a good + idea and we should merge them with the corresponding [extract_decl] functions. + *) +let start_fun_decl_group (ctx : extraction_ctx) (fmt : F.formatter) + (is_rec : bool) (dg : Pure.fun_decl list) = + match !backend with + | FStar | Coq | Lean -> () + | HOL4 -> + (* In HOL4, opaque functions have a special treatment *) + if is_single_opaque_fun_decl_group dg then () + else + let compute_fun_def_name (def : Pure.fun_decl) : string = + ctx_get_local_function def.def_id def.loop_id def.back_id ctx ^ "_def" + in + let names = List.map compute_fun_def_name dg in + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open the box for the delimiters *) + F.pp_open_vbox fmt 0; + (* Open the box for the definitions themselves *) + F.pp_open_vbox fmt ctx.indent_incr; + (* Print the delimiters *) + if is_rec then + F.pp_print_string fmt + ("val [" ^ String.concat ", " names ^ "] = DefineDiv ‘") + else ( + assert (List.length names = 1); + let name = List.hd names in + F.pp_print_string fmt ("val " ^ name ^ " = Define ‘")); + F.pp_print_cut fmt () + +(** See {!start_fun_decl_group}. *) +let end_fun_decl_group (fmt : F.formatter) (is_rec : bool) + (dg : Pure.fun_decl list) = + match !backend with + | FStar -> () + | Coq -> + (* For aesthetic reasons, we print the Coq end group delimiter directly + in {!extract_fun_decl}. *) + () + | Lean -> + (* We must add the "end" keyword to groups of mutually recursive functions *) + if is_rec && List.length dg > 1 then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "end"; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + else () + | HOL4 -> + (* In HOL4, opaque functions have a special treatment *) + if is_single_opaque_fun_decl_group dg then () + else ( + (* Close the box for the definitions *) + F.pp_close_box fmt (); + (* Print the end delimiter *) + F.pp_print_cut fmt (); + F.pp_print_string fmt "’"; + (* Close the box for the delimiters *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + +(** See {!start_fun_decl_group}: similar usage, but for the type declarations. *) +let start_type_decl_group (ctx : extraction_ctx) (fmt : F.formatter) + (is_rec : bool) (dg : Pure.type_decl list) = + match !backend with + | FStar | Coq -> () + | Lean -> + if is_rec && List.length dg > 1 then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "mutual"; + F.pp_print_space fmt ()) + | HOL4 -> + (* In HOL4, opaque types and empty records have a special treatment *) + if + is_single_opaque_type_decl_group dg + || is_empty_record_type_decl_group dg + then () + else ( + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open the box for the delimiters *) + F.pp_open_vbox fmt 0; + (* Open the box for the definitions themselves *) + F.pp_open_vbox fmt ctx.indent_incr; + (* Print the delimiters *) + F.pp_print_string fmt "Datatype:"; + F.pp_print_cut fmt ()) + +(** See {!start_fun_decl_group}. *) +let end_type_decl_group (fmt : F.formatter) (is_rec : bool) + (dg : Pure.type_decl list) = + match !backend with + | FStar -> () + | Coq -> + (* For aesthetic reasons, we print the Coq end group delimiter directly + in {!extract_fun_decl}. *) + () + | Lean -> + (* We must add the "end" keyword to groups of mutually recursive functions *) + if is_rec && List.length dg > 1 then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "end"; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + else () + | HOL4 -> + (* In HOL4, opaque types and empty records have a special treatment *) + if + is_single_opaque_type_decl_group dg + || is_empty_record_type_decl_group dg + then () + else ( + (* Close the box for the definitions *) + F.pp_close_box fmt (); + (* Print the end delimiter *) + F.pp_print_cut fmt (); + F.pp_print_string fmt "End"; + (* Close the box for the delimiters *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0) + +let unit_name () = + match !backend with Lean -> "Unit" | Coq | FStar | HOL4 -> "unit" + +(** Small helper *) +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 (ctx : extraction_ctx) (fmt : F.formatter) + (inside : bool) (cg : const_generic) : unit = + match cg with + | ConstGenericGlobal id -> + let s = ctx_get_global id ctx in + F.pp_print_string fmt s + | ConstGenericValue v -> ctx.fmt.extract_literal fmt inside v + | ConstGenericVar id -> + let s = ctx_get_const_generic_var id ctx in + F.pp_print_string fmt s + +let extract_literal_type (ctx : extraction_ctx) (fmt : F.formatter) + (ty : literal_type) : unit = + match ty with + | Bool -> F.pp_print_string fmt ctx.fmt.bool_name + | Char -> F.pp_print_string fmt ctx.fmt.char_name + | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + +(** [inside] constrols whether we should add parentheses or not around type + applications (if [true] we add parentheses). + + [no_params_tys]: for all the types inside this set, do not print the type parameters. + This is used for HOL4. As polymorphism is uniform in HOL4, printing the + type parameters in the recursive definitions is useless (and actually + forbidden). + + For instance, where in F* we would write: + {[ + type list a = | Nil : list a | Cons : a -> list a -> list a + ]} + + In HOL4 we would simply write: + {[ + Datatype: + list = Nil 'a | Cons 'a list + End + ]} + *) +let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = + let extract_rec = extract_ty ctx fmt no_params_tys in + match ty with + | Adt (type_id, generics) -> ( + let has_params = generics <> empty_generic_args in + match type_id with + | Tuple -> + (* This is a bit annoying, but in F*/Coq/HOL4 [()] is not the unit type: + * we have to write [unit]... *) + if generics.types = [] then F.pp_print_string fmt (unit_name ()) + else ( + F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_space fmt (); + let product = + match !backend with + | FStar -> "&" + | Coq -> "*" + | Lean -> "×" + | HOL4 -> "#" + in + F.pp_print_string fmt product; + F.pp_print_space fmt ()) + (extract_rec true) generics.types; + F.pp_print_string fmt ")") + | AdtId _ | Assumed _ -> ( + (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: + `tree a b` + + In HOL4 we would write: + `('a, 'b) tree` + *) + match !backend with + | FStar | Coq | Lean -> + let print_paren = inside && has_params in + if print_paren then F.pp_print_string fmt "("; + (* TODO: for now, only the opaque *functions* are extracted in the + opaque module. The opaque *types* are assumed. *) + F.pp_print_string fmt (ctx_get_type type_id ctx); + (* We might need to filter the type arguments, if the type + is builtin (for instance, we filter the global allocator type + argument for `Vec`). *) + let generics = + match type_id with + | AdtId id -> ( + match + TypeDeclId.Map.find_opt id ctx.types_filter_type_args_map + with + | None -> generics + | Some filter -> + let types = List.combine filter generics.types in + let types = + List.filter_map + (fun (b, ty) -> if b then Some ty else None) + types + in + { generics with types }) + | _ -> generics + in + extract_generic_args ctx fmt no_params_tys generics; + if print_paren then F.pp_print_string fmt ")" + | HOL4 -> + let { types; const_generics; trait_refs } = generics in + (* Const generics are not supported in HOL4 *) + assert (const_generics = []); + let print_tys = + match type_id with + | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) + | Assumed _ -> true + | _ -> raise (Failure "Unreachable") + in + if types <> [] && print_tys then ( + let print_paren = List.length types > 1 in + if print_paren then F.pp_print_string fmt "("; + Collections.List.iter_link + (fun () -> + F.pp_print_string fmt ","; + F.pp_print_space fmt ()) + (extract_rec true) types; + if print_paren then F.pp_print_string fmt ")"; + F.pp_print_space fmt ()); + F.pp_print_string fmt (ctx_get_type type_id ctx); + if trait_refs <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_trait_ref ctx fmt no_params_tys true) + trait_refs))) + | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) + | Literal lty -> extract_literal_type ctx fmt lty + | Arrow (arg_ty, ret_ty) -> + if inside then F.pp_print_string fmt "("; + extract_rec false arg_ty; + F.pp_print_space fmt (); + extract_arrow fmt (); + F.pp_print_space fmt (); + extract_rec false ret_ty; + if inside then F.pp_print_string fmt ")" + | TraitType (trait_ref, generics, type_name) -> + if !parameterize_trait_types then raise (Failure "Unimplemented") + else if trait_ref.trait_id <> Self then ( + (* HOL4 doesn't have 1st class types *) + assert (!backend <> HOL4); + let use_brackets = generics <> empty_generic_args in + if use_brackets then F.pp_print_string fmt "("; + extract_trait_ref ctx fmt no_params_tys false trait_ref; + extract_generic_args ctx fmt no_params_tys generics; + let name = + ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name + ctx + in + if use_brackets then F.pp_print_string fmt ")"; + F.pp_print_string fmt ("." ^ name)) + else + (* There are two situations: + - we are extracting a declared item (typically a function signature) + for a trait declaration. We directly refer to the item (we extract + trait declarations as structures, so we can refer to their fields) + - we are extracting a provided method for a trait declaration. We + refer to the item in the self trait clause (see {!SelfTraitClauseId}). + + Remark: we can't get there for trait *implementations* because then the + types should have been normalized. + *) + let trait_decl_id = Option.get ctx.trait_decl_id in + let item_name = ctx_get_trait_type trait_decl_id type_name ctx in + assert (generics = empty_generic_args); + if ctx.is_provided_method then + (* Provided method: use the trait self clause *) + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt (self_clause ^ "." ^ item_name) + else + (* Declaration: directly refer to the item *) + F.pp_print_string fmt item_name + +and extract_trait_ref (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 *) + let generics = + match tr.trait_id with + | TraitImpl id -> ( + match + TraitImplId.Map.find_opt id ctx.trait_impls_filter_type_args_map + with + | None -> tr.generics + | Some filter -> + let types = + List.filter_map + (fun (b, x) -> if b then Some x else None) + (List.combine filter tr.generics.types) + in + { tr.generics with types }) + | _ -> tr.generics + in + extract_trait_instance_id ctx fmt no_params_tys inside tr.trait_id; + extract_generic_args ctx fmt no_params_tys generics; + if use_brackets then F.pp_print_string fmt ")" + +and extract_trait_decl_ref (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 tr.trait_decl_id ctx in + if use_brackets then F.pp_print_string fmt "("; + F.pp_print_string fmt name; + (* There is something subtle here: the trait obligations for the implemented + trait are put inside the parent clauses, so we must ignore them here *) + let generics = { tr.decl_generics with trait_refs = [] } in + extract_generic_args ctx fmt no_params_tys generics; + if use_brackets then F.pp_print_string fmt ")" + +and extract_generic_args (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 ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_ty ctx fmt no_params_tys true) + types); + if const_generics <> [] then ( + assert (!backend <> HOL4); + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_const_generic ctx fmt true) + const_generics)); + if trait_refs <> [] then ( + F.pp_print_space fmt (); + Collections.List.iter_link (F.pp_print_space fmt) + (extract_trait_ref ctx fmt no_params_tys true) + trait_refs) + +and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) + : unit = + match id with + | Self -> + (* This has specific treatment depending on the item we're extracting + (associated type, etc.). We should have caught this elsewhere. *) + raise (Failure "Unexpected") + | TraitImpl id -> + let name = ctx_get_trait_impl id ctx in + F.pp_print_string fmt name + | Clause id -> + let name = ctx_get_local_trait_clause id ctx in + F.pp_print_string fmt name + | ParentClause (inst_id, decl_id, clause_id) -> + (* Use the trait decl id to lookup the name *) + let name = ctx_get_trait_parent_clause decl_id clause_id ctx in + extract_trait_instance_id ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt ("." ^ 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 decl_id item_name clause_id ctx in + extract_trait_instance_id ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt ("." ^ name) + | TraitRef trait_ref -> + extract_trait_ref ctx fmt no_params_tys inside trait_ref + | UnknownTrait _ -> + (* This is an error case *) + raise (Failure "Unexpected") + +(** Compute the names for all the top-level identifiers used in a type + definition (type name, variant names, field names, etc. but not type + parameters). + + We need to do this preemptively, beforce extracting any definition, + because of recursive definitions. + *) +let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : + extraction_ctx = + (* Lookup the builtin information, if there is *) + let open ExtractBuiltin in + let sname = name_to_simple_name def.name in + let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in + (* Register the filtering information, if there is *) + let ctx = + match info with + | Some { keep_params = Some keep; _ } -> + { + ctx with + types_filter_type_args_map = + TypeDeclId.Map.add def.def_id keep ctx.types_filter_type_args_map; + } + | _ -> ctx + in + (* Compute and register the type def name *) + let def_name = + match info with + | None -> ctx.fmt.type_name def.name + | Some info -> info.extract_name + in + let ctx = ctx_add (TypeId (AdtId def.def_id)) def_name ctx in + (* Compute and register: + * - the variant names, if this is an enumeration + * - the field names, if this is a structure + *) + let ctx = + match def.kind with + | Struct fields -> + (* Compute the names *) + let field_names, cons_name = + match info with + | None | Some { body_info = None; _ } -> + let field_names = + FieldId.mapi + (fun fid (field : field) -> + (fid, ctx.fmt.field_name def.name fid field.field_name)) + fields + in + let cons_name = ctx.fmt.struct_constructor def.name in + (field_names, cons_name) + | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> + let field_names = + FieldId.mapi + (fun fid (_, name) -> (fid, name)) + (List.combine fields field_names) + in + (field_names, cons_name) + | Some info -> + raise + (Failure + ("Invalid builtin information: " + ^ show_builtin_type_info info)) + in + (* Add the fields *) + let ctx = + List.fold_left + (fun ctx (fid, name) -> + ctx_add (FieldId (AdtId def.def_id, fid)) name ctx) + ctx field_names + in + (* Add the constructor name *) + ctx_add (StructId (AdtId def.def_id)) cons_name ctx + | Enum variants -> + let variant_names = + match info with + | None -> + VariantId.mapi + (fun variant_id (variant : variant) -> + let name = + ctx.fmt.variant_name def.name variant.variant_name + in + (* Add the type name prefix for Lean *) + let name = + if !Config.backend = Lean then + let type_name = ctx.fmt.type_name def.name in + type_name ^ "." ^ name + else name + in + (variant_id, name)) + variants + | Some { body_info = Some (Enum variant_infos); _ } -> + (* We need to compute the map from variant to variant *) + let variant_map = + StringMap.of_list + (List.map + (fun (info : builtin_enum_variant_info) -> + (info.rust_variant_name, info.extract_variant_name)) + variant_infos) + in + VariantId.mapi + (fun variant_id (variant : variant) -> + (variant_id, StringMap.find variant.variant_name variant_map)) + variants + | _ -> raise (Failure "Invalid builtin information") + in + List.fold_left + (fun ctx (vid, vname) -> + ctx_add (VariantId (AdtId def.def_id, vid)) vname ctx) + ctx variant_names + | Opaque -> + (* Nothing to do *) + ctx + in + (* Return *) + ctx + +(** Print the variants *) +let extract_type_decl_variant (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; + (* [| Cons :] + * Note that we really don't want any break above so we print everything + * at once. *) + let opt_colon = if !backend <> HOL4 then " :" else "" in + F.pp_print_string fmt ("| " ^ cons_name ^ opt_colon); + let print_field (fid : FieldId.id) (f : field) (ctx : extraction_ctx) : + extraction_ctx = + F.pp_print_space fmt (); + (* Open the field box *) + F.pp_open_box fmt ctx.indent_incr; + (* Print the field names, if the backend accepts it. + * [ x :] + * Note that when printing fields, we register the field names as + * *variables*: they don't need to be unique at the top level. *) + let ctx = + match !backend with + | FStar -> ( + match f.field_name with + | None -> ctx + | Some field_name -> + let var_id = VarId.of_int (FieldId.to_int fid) in + let field_name = + ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) + f.field_ty + in + let ctx, field_name = ctx_add_var field_name var_id ctx in + F.pp_print_string fmt (field_name ^ " :"); + F.pp_print_space fmt (); + ctx) + | Coq | Lean | HOL4 -> ctx + in + (* Print the field type *) + let inside = !backend = HOL4 in + extract_ty ctx fmt type_decl_group inside f.field_ty; + (* Print the arrow [->] *) + if !backend <> HOL4 then ( + F.pp_print_space fmt (); + extract_arrow fmt ()); + (* Close the field box *) + F.pp_close_box fmt (); + (* Return *) + ctx + in + (* Print the fields *) + let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in + let _ = + List.fold_left (fun ctx (fid, f) -> print_field fid f ctx) ctx fields + in + (* Sanity check: HOL4 doesn't support const generics *) + assert (cg_params = [] || !backend <> HOL4); + (* Print the final type *) + if !backend <> HOL4 then ( + F.pp_print_space fmt (); + F.pp_open_hovbox fmt 0; + F.pp_print_string fmt type_name; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + (List.append type_params cg_params); + F.pp_close_box fmt ()); + (* Close the variant box *) + F.pp_close_box fmt () + +(* TODO: we don' need the [def_name] paramter: it can be retrieved from the context *) +let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (def : type_decl) (def_name : string) + (type_params : string list) (cg_params : string list) + (variants : variant list) : unit = + (* We want to generate a definition which looks like this (taking F* as example): + {[ + type list a = | Cons : a -> list a -> list a | Nil : list a + ]} + + If there isn't enough space on one line: + {[ + type s = + | Cons : a -> list a -> list a + | Nil : list a + ]} + + And if we need to write the type of a variant on several lines: + {[ + type s = + | Cons : + a -> + list a -> + list a + | Nil : list a + ]} + + Finally, it is possible to give names to the variant fields in Rust. + In this situation, we generate a definition like this: + {[ + type s = + | Cons : hd:a -> tl:list a -> list a + | Nil : list a + ]} + + Note that we already printed: [type s =] + *) + 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.fmt.variant_name def.name v.variant_name in + let fields = v.fields in + extract_type_decl_variant 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 + +let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) + (type_params : string list) (cg_params : string list) (fields : field list) + : unit = + (* We want to generate a definition which looks like this (taking F* as example): + {[ + type t = { x : int; y : bool; } + ]} + + If there isn't enough space on one line: + {[ + type t = + { + x : int; y : bool; + } + ]} + + And if there is even less space: + {[ + type t = + { + x : int; + y : bool; + } + ]} + + Also, in case there are no fields, we need to define the type as [unit] + ([type t = {}] doesn't work in F* ). + + Coq: + ==== + We need to define the constructor name upon defining the struct (record, in Coq). + The syntex is: + {[ + Record Foo = mkFoo { x : int; y : bool; }. + }] + + Also, Coq doesn't support groups of mutually recursive inductives and records. + This is fine, because we can then define records as inductives, and leverage + the fact that when record fields are accessed, the records are symbolically + expanded which introduces let bindings of the form: [let RecordCons ... = x in ...]. + As a consequence, we never use the record projectors (unless we reconstruct + them in the micro passes of course). + + HOL4: + ===== + Type definitions are written as follows: + {[ + Datatype: + tree = + TLeaf 'a + | TNode node ; + + node = + Node (tree list) + End + ]} + *) + (* Note that we already printed: [type t =] *) + let is_rec = decl_is_from_rec_group kind in + let _ = + if !backend = FStar && fields = [] then ( + F.pp_print_space fmt (); + F.pp_print_string fmt (unit_name ())) + else if !backend = Lean && fields = [] then () + (* If the definition is recursive, we may need to extract it as an inductive + (instead of a record). We start with the "normal" case: we extract it + as a record. *) + else if (not is_rec) || (!backend <> Coq && !backend <> Lean) then ( + if !backend <> Lean then F.pp_print_space fmt (); + (* If Coq: print the constructor name *) + (* TODO: remove superfluous test not is_rec below *) + if !backend = Coq && not is_rec then ( + F.pp_print_string fmt (ctx_get_struct (AdtId def.def_id) ctx); + F.pp_print_string fmt " "); + (match !backend with + | Lean -> () + | FStar | Coq -> F.pp_print_string fmt "{" + | HOL4 -> F.pp_print_string fmt "<|"); + F.pp_print_break fmt 1 ctx.indent_incr; + (* The body itself *) + (* Open a box for the body *) + (match !backend with + | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 + | 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 (AdtId 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; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_ty ctx fmt type_decl_group false f.field_ty; + if !backend <> Lean then F.pp_print_string fmt ";"; + (* Close the box for the field *) + F.pp_close_box fmt () + in + let fields = FieldId.mapi (fun fid f -> (fid, f)) fields in + Collections.List.iter_link (F.pp_print_space fmt) + (fun (fid, f) -> print_field fid f) + fields; + (* Close the box for the body *) + F.pp_close_box fmt (); + match !backend with + | Lean -> () + | FStar | Coq -> + F.pp_print_space fmt (); + F.pp_print_string fmt "}" + | HOL4 -> + F.pp_print_space fmt (); + F.pp_print_string fmt "|>") + 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 *) + assert (is_rec && (!backend = Coq || !backend = Lean)); + (* 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 (AdtId def.def_id) ctx + in + let def_name = ctx_get_local_type def.def_id ctx in + extract_type_decl_variant ctx fmt type_decl_group def_name type_params + cg_params cons_name fields) + in + () + +(** Extract a nestable, muti-line comment *) +let extract_comment (fmt : F.formatter) (sl : string list) : unit = + (* Delimiters, space after we break a line *) + let ld, space, rd = + match !backend with + | Coq | FStar | HOL4 -> ("(** ", 4, " *)") + | Lean -> ("/- ", 3, " -/") + in + F.pp_open_vbox fmt space; + F.pp_print_string fmt ld; + (match sl with + | [] -> () + | s :: sl -> + F.pp_print_string fmt s; + List.iter + (fun s -> + F.pp_print_space fmt (); + F.pp_print_string fmt s) + sl); + F.pp_print_string fmt rd; + F.pp_close_box fmt () + +let extract_trait_clause_type (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) (clause : trait_clause) : unit = + let trait_name = ctx_get_trait_decl clause.trait_id ctx in + F.pp_print_string fmt trait_name; + extract_generic_args ctx fmt no_params_tys clause.generics + +(** Insert a space, if necessary *) +let insert_req_space (fmt : F.formatter) (space : bool ref) : unit = + if !space then space := false else F.pp_print_space fmt () + +(** Extract the trait self clause. + + We add the trait self clause for provided methods (see {!TraitSelfClauseId}). + *) +let extract_trait_self_clause (insert_req_space : unit -> unit) + (ctx : extraction_ctx) (fmt : F.formatter) (trait_decl : trait_decl) + (params : string list) : unit = + insert_req_space (); + F.pp_print_string fmt "("; + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt self_clause; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + let trait_id = ctx_get_trait_decl trait_decl.def_id ctx in + F.pp_print_string fmt trait_id; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + params; + F.pp_print_string fmt ")" + +(** + - [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 (ctx : extraction_ctx) (fmt : F.formatter) + (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) + ?(use_forall_use_sep = true) ?(as_implicits : bool = false) + ?(space : bool ref option = None) ?(trait_decl : trait_decl option = None) + (generics : generic_params) (type_params : string list) + (cg_params : string list) (trait_clauses : string list) : unit = + let all_params = List.concat [ type_params; cg_params; trait_clauses ] in + (* HOL4 doesn't support const generics *) + assert (cg_params = [] || !backend <> HOL4); + let left_bracket (implicit : bool) = + if implicit then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" + in + let right_bracket (implicit : bool) = + if implicit then F.pp_print_string fmt "}" else F.pp_print_string fmt ")" + in + let insert_req_space () = + match space with + | None -> F.pp_print_space fmt () + | Some space -> insert_req_space fmt space + in + (* Print the type/const generic parameters *) + if all_params <> [] then ( + if use_forall then ( + if use_forall_use_sep then ( + insert_req_space (); + F.pp_print_string fmt ":"); + insert_req_space (); + F.pp_print_string fmt "forall"); + (* Small helper - we may need to split the parameters *) + let print_generics (as_implicits : bool) (type_params : string list) + (const_generics : const_generic_var list) + (trait_clauses : trait_clause list) : unit = + (* Note that in HOL4 we don't print the type parameters. *) + if !backend <> HOL4 then ( + (* Print the type parameters *) + if type_params <> [] then ( + insert_req_space (); + (* ( *) + left_bracket as_implicits; + List.iter + (fun s -> + F.pp_print_string fmt s; + F.pp_print_space fmt ()) + type_params; + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()); + (* ) *) + right_bracket as_implicits); + (* Print the const generic parameters *) + List.iter + (fun (var : const_generic_var) -> + insert_req_space (); + (* ( *) + left_bracket as_implicits; + let n = ctx_get_const_generic_var var.index ctx in + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_literal_type ctx fmt var.ty; + (* ) *) + right_bracket as_implicits) + const_generics); + (* Print the trait clauses *) + List.iter + (fun (clause : trait_clause) -> + insert_req_space (); + (* ( *) + left_bracket as_implicits; + let n = ctx_get_local_trait_clause clause.clause_id ctx in + F.pp_print_string fmt n; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt no_params_tys clause; + (* ) *) + right_bracket as_implicits) + trait_clauses + in + (* If we extract the generics for a provided method for a trait declaration + (indicated by the trait decl given as input), we need to split the generics: + - we print the generics for the trait decl + - we print the trait self clause + - we print the generics for the trait method + *) + match trait_decl with + | None -> + print_generics as_implicits type_params generics.const_generics + generics.trait_clauses + | Some trait_decl -> + (* Split the generics between the generics specific to the trait decl + and those specific to the trait method *) + let open Collections.List in + let dtype_params, mtype_params = + split_at type_params (length trait_decl.generics.types) + in + let dcgs, mcgs = + split_at generics.const_generics + (length trait_decl.generics.const_generics) + in + let dtrait_clauses, mtrait_clauses = + split_at generics.trait_clauses + (length trait_decl.generics.trait_clauses) + in + (* Extract the trait decl generics - note that we can always deduce + those parameters from the trait self clause: for this reason + they are always implicit *) + print_generics true dtype_params dcgs dtrait_clauses; + (* Extract the trait self clause *) + let params = + concat + [ + dtype_params; + map + (fun (cg : const_generic_var) -> + ctx_get_const_generic_var cg.index ctx) + dcgs; + map + (fun c -> ctx_get_local_trait_clause c.clause_id ctx) + dtrait_clauses; + ] + in + extract_trait_self_clause insert_req_space ctx fmt trait_decl params; + (* Extract the method generics *) + print_generics as_implicits mtype_params mcgs mtrait_clauses) + +(** Extract a type declaration. + + This function is for all type declarations and all backends **at the exception** + of opaque (assumed/declared) types format4 HOL4. + + See {!extract_type_decl}. + *) +let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) + (extract_body : bool) : unit = + (* Sanity check *) + assert (extract_body || !backend <> HOL4); + let type_kind = + if extract_body then + match def.kind with + | Struct _ -> Some Struct + | Enum _ -> Some Enum + | Opaque -> None + else None + in + (* If in Coq and the declaration is opaque, it must have the shape: + [Axiom Ident : forall (T0 ... Tn : Type) (N0 : ...) ... (Nn : ...), ... -> ... -> ...]. + + The boolean [is_opaque_coq] is used to detect this case. + *) + let is_opaque = type_kind = None in + let is_opaque_coq = !backend = Coq && is_opaque in + let use_forall = is_opaque_coq && def.generics <> empty_generic_params in + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* 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.generics ctx + in + (* Add a break before *) + if !backend <> HOL4 || not (decl_is_first_from_group kind) then + F.pp_print_break fmt 0 0; + (* Print a comment to link the extracted type to its original rust definition *) + extract_comment fmt [ "[" ^ Print.name_to_string def.name ^ "]" ]; + F.pp_print_break fmt 0 0; + (* Open a box for the definition, so that whenever possible it gets printed on + * one line. Note however that in the case of Lean line breaks are important + * for parsing: we thus use a hovbox. *) + (match !backend with + | Coq | FStar | HOL4 -> F.pp_open_hvbox fmt 0 + | Lean -> F.pp_open_vbox fmt 0); + (* Open a box for "type TYPE_NAME (TYPE_PARAMS CONST_GEN_PARAMS) =" *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* > "type TYPE_NAME" *) + let qualif = ctx.fmt.type_decl_kind_to_qualif kind type_kind in + (match qualif with + | Some qualif -> F.pp_print_string fmt (qualif ^ " " ^ def_name) + | None -> F.pp_print_string fmt def_name); + (* HOL4 doesn't support const generics, and type definitions in HOL4 don't + support trait clauses *) + assert ((cg_params = [] && trait_clauses = []) || !backend <> HOL4); + (* Print the generic parameters *) + extract_generic_params 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 (); + let eq = + match !backend with + | FStar -> "=" + | Coq -> ":=" + | Lean -> + if type_kind = Some Struct && kind = SingleNonRec then "where" + else ":=" + | HOL4 -> "=" + in + F.pp_print_string fmt eq) + else ( + (* Otherwise print ": Type", unless it is the HOL4 backend (in + which case we declare the type with `new_type`) *) + if use_forall then F.pp_print_string fmt "," + else ( + F.pp_print_space fmt (); + F.pp_print_string fmt ":"); + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ())); + (* Close the box for "type TYPE_NAME (TYPE_PARAMS) =" *) + F.pp_close_box fmt (); + (if extract_body then + match def.kind with + | Struct fields -> + extract_type_decl_struct_body ctx_body fmt type_decl_group kind def + type_params cg_params fields + | Enum variants -> + extract_type_decl_enum_body ctx_body fmt type_decl_group def def_name + type_params cg_params variants + | Opaque -> raise (Failure "Unreachable")); + (* Add the definition end delimiter *) + if !backend = HOL4 && decl_is_not_last_from_group kind then ( + F.pp_print_space fmt (); + F.pp_print_string fmt ";") + else if !backend = Coq && decl_is_last_from_group kind then ( + (* This is actually an end of group delimiter. For aesthetic reasons + we print it here instead of in {!end_type_decl_group}. *) + F.pp_print_cut fmt (); + F.pp_print_string fmt "."); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + if !backend <> HOL4 || decl_is_not_last_from_group kind then + F.pp_print_break fmt 0 0 + +(** Extract an opaque type declaration to HOL4. + + Remark (SH): having to treat this specific case separately is very annoying, + but I could not find a better way. + *) +let extract_type_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) + (def : type_decl) : unit = + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Generic parameters are unsupported *) + assert (def.generics.const_generics = []); + (* Trait clauses on type definitions are unsupported *) + assert (def.generics.trait_clauses = []); + (* Types *) + (* Count the number of parameters *) + let num_params = List.length def.generics.types in + (* Generate the declaration *) + F.pp_print_space fmt (); + F.pp_print_string fmt + ("val _ = new_type (\"" ^ def_name ^ "\", " ^ string_of_int num_params ^ ")"); + F.pp_print_space fmt () + +(** Extract an empty record type declaration to HOL4. + + Empty records are not supported in HOL4, so we extract them as type + abbreviations to the unit type. + + Remark (SH): having to treat this specific case separately is very annoying, + but I could not find a better way. + *) +let extract_type_decl_hol4_empty_record (ctx : extraction_ctx) + (fmt : F.formatter) (def : type_decl) : unit = + (* Retrieve the definition name *) + let def_name = ctx_get_local_type def.def_id ctx in + (* Sanity check *) + assert (def.generics = empty_generic_params); + (* Generate the declaration *) + F.pp_print_space fmt (); + F.pp_print_string fmt ("Type " ^ def_name ^ " = “: unit”"); + F.pp_print_space fmt () + +(** Extract a type declaration. + + Note that all the names used for extraction should already have been + registered. + + This function should be inserted between calls to {!start_type_decl_group} + and {!end_type_decl_group}. + *) +let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) + (type_decl_group : TypeDeclId.Set.t) (kind : decl_kind) (def : type_decl) : + unit = + let extract_body = + match kind with + | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> true + | Assumed | Declared -> false + in + if extract_body then + if !backend = HOL4 && is_empty_record_type_decl def then + extract_type_decl_hol4_empty_record ctx fmt def + else extract_type_decl_gen ctx fmt type_decl_group kind def extract_body + else + match !backend with + | FStar | Coq | Lean -> + extract_type_decl_gen ctx fmt type_decl_group kind def extract_body + | HOL4 -> extract_type_decl_hol4_opaque ctx fmt def + +(** Auxiliary function. + + Generate [Arguments] instructions in Coq. + *) +let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) + (kind : decl_kind) (decl : type_decl) : unit = + assert (!backend = Coq); + (* Generating the [Arguments] instructions is useful only if there are type parameters *) + if decl.generics.types = [] && decl.generics.const_generics = [] then () + else + (* Add the type params - note that we need those bindings only for the + * body translation (they are not top-level) *) + let _ctx_body, type_params, cg_params, trait_clauses = + ctx_add_generic_params decl.generics ctx + in + (* Auxiliary function to extract an [Arguments Cons {T} _ _.] instruction *) + let extract_arguments_info (cons_name : string) (fields : 'a list) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open a box *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_break fmt 0 0; + F.pp_print_string fmt "Arguments"; + F.pp_print_space fmt (); + F.pp_print_string fmt cons_name; + (* Print the type/const params and the trait clauses (`{T}`) *) + List.iter + (fun (var : string) -> + F.pp_print_space fmt (); + F.pp_print_string fmt ("{" ^ var ^ "}")) + (List.concat [ type_params; cg_params; trait_clauses ]); + (* Print the fields (`_`) *) + List.iter + (fun _ -> + F.pp_print_space fmt (); + F.pp_print_string fmt "_") + fields; + F.pp_print_string fmt "."; + + (* Close the box *) + F.pp_close_box fmt () + in + + (* Generate the [Arguments] instruction *) + match decl.kind with + | Opaque -> () + | Struct fields -> + let adt_id = AdtId decl.def_id in + (* Generate the instruction for the record constructor *) + let cons_name = ctx_get_struct adt_id ctx in + extract_arguments_info cons_name fields; + (* Generate the instruction for the record projectors, if there are *) + let is_rec = decl_is_from_rec_group kind in + if not is_rec then + FieldId.iteri + (fun fid _ -> + let cons_name = ctx_get_field adt_id fid ctx in + extract_arguments_info cons_name []) + fields; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + | Enum variants -> + (* Generate the instructions *) + VariantId.iteri + (fun vid (v : variant) -> + let cons_name = ctx_get_variant (AdtId decl.def_id) vid ctx in + extract_arguments_info cons_name v.fields) + variants; + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + +(** Auxiliary function. + + Generate field projectors in Coq. + + Sometimes we extract records as inductives in Coq: when this happens we + have to define the field projectors afterwards. + *) +let extract_type_decl_record_field_projectors (ctx : extraction_ctx) + (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = + assert (!backend = Coq); + match decl.kind with + | Opaque | Enum _ -> () + | Struct fields -> + (* Records are extracted as inductives only if they are recursive *) + let is_rec = decl_is_from_rec_group kind in + if is_rec then + (* Add the type params *) + let ctx, type_params, cg_params, trait_clauses = + ctx_add_generic_params decl.generics ctx + in + let ctx, record_var = ctx_add_var "x" (VarId.of_int 0) ctx in + let ctx, field_var = ctx_add_var "x" (VarId.of_int 1) ctx in + let def_name = ctx_get_local_type decl.def_id ctx in + let cons_name = ctx_get_struct (AdtId decl.def_id) ctx in + let extract_field_proj (field_id : FieldId.id) (_ : field) : unit = + F.pp_print_space fmt (); + (* Outer box for the projector definition *) + F.pp_open_hvbox fmt 0; + (* Inner box for the projector definition *) + F.pp_open_hvbox fmt ctx.indent_incr; + (* Open a box for the [Definition PROJ ... :=] *) + 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 (AdtId 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 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 "("; + F.pp_print_string fmt record_var; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt def_name; + List.iter + (fun p -> + F.pp_print_space fmt (); + F.pp_print_string fmt p) + type_params; + F.pp_print_string fmt ")"; + (* *) + F.pp_print_space fmt (); + F.pp_print_string fmt ":="; + (* Close the box for the [Definition PROJ ... :=] *) + F.pp_close_box fmt (); + F.pp_print_space fmt (); + (* Open a box for the whole match *) + F.pp_open_hvbox fmt 0; + (* Open a box for the [match ... with] *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_string fmt "match"; + F.pp_print_space fmt (); + F.pp_print_string fmt record_var; + F.pp_print_space fmt (); + F.pp_print_string fmt "with"; + (* Close the box for the [match ... with] *) + F.pp_close_box fmt (); + + (* Open a box for the branch *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print the match branch *) + F.pp_print_space fmt (); + F.pp_print_string fmt "|"; + F.pp_print_space fmt (); + F.pp_print_string fmt cons_name; + FieldId.iteri + (fun id _ -> + F.pp_print_space fmt (); + if field_id = id then F.pp_print_string fmt field_var + else F.pp_print_string fmt "_") + fields; + F.pp_print_space fmt (); + F.pp_print_string fmt "=>"; + F.pp_print_space fmt (); + F.pp_print_string fmt field_var; + (* Close the box for the branch *) + F.pp_close_box fmt (); + (* Print the [end] *) + F.pp_print_space fmt (); + F.pp_print_string fmt "end"; + (* Close the box for the whole match *) + F.pp_close_box fmt (); + (* Close the inner box projector *) + F.pp_close_box fmt (); + (* If Coq: end the definition with a "." *) + if !backend = Coq then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "."); + (* Close the outer box projector *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + in + + let extract_proj_notation (field_id : FieldId.id) (_ : field) : unit = + F.pp_print_space fmt (); + (* Outer box for the projector definition *) + 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 "x" (VarId.of_int 0) ctx in + F.pp_print_string fmt "Notation"; + F.pp_print_space fmt (); + let field_name = ctx_get_field (AdtId 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 ":="; + F.pp_print_space fmt (); + F.pp_print_string fmt "("; + F.pp_print_string fmt field_name; + F.pp_print_space fmt (); + F.pp_print_string fmt record_var; + F.pp_print_string fmt ")"; + F.pp_print_space fmt (); + F.pp_print_string fmt "(at level 9)"; + (* Close the inner box projector *) + F.pp_close_box fmt (); + (* If Coq: end the definition with a "." *) + if !backend = Coq then ( + F.pp_print_cut fmt (); + F.pp_print_string fmt "."); + (* Close the outer box projector *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 + in + + let extract_field_proj_and_notation (field_id : FieldId.id) + (field : field) : unit = + extract_field_proj field_id field; + extract_proj_notation field_id field + in + + FieldId.iteri extract_field_proj_and_notation fields + +(** Extract extra information for a type (e.g., [Arguments] instructions in Coq). + + Note that all the names used for extraction should already have been + registered. + *) +let extract_type_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) + (kind : decl_kind) (decl : type_decl) : unit = + match !backend with + | FStar | Lean | HOL4 -> () + | Coq -> + extract_type_decl_coq_arguments ctx fmt kind decl; + extract_type_decl_record_field_projectors ctx fmt kind decl + +(** Extract the state type declaration. *) +let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) + (kind : decl_kind) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Print a comment *) + extract_comment fmt [ "The state type used in the state-error monad" ]; + F.pp_print_break fmt 0 0; + (* Open a box for the definition, so that whenever possible it gets printed on + * one line *) + F.pp_open_hvbox fmt 0; + (* Retrieve the name *) + let state_name = ctx_get_assumed_type State ctx in + (* The syntax for Lean and Coq is almost identical. *) + let print_axiom () = + let axiom = + match !backend with + | Coq -> "Axiom" + | Lean -> "axiom" + | FStar | HOL4 -> raise (Failure "Unexpected") + in + F.pp_print_string fmt axiom; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type"; + if !backend = Coq then F.pp_print_string fmt "." + in + (* The kind should be [Assumed] or [Declared] *) + (match kind with + | SingleNonRec | SingleRec | MutRecFirst | MutRecInner | MutRecLast -> + raise (Failure "Unexpected") + | Assumed -> ( + match !backend with + | FStar -> + F.pp_print_string fmt "assume"; + F.pp_print_space fmt (); + F.pp_print_string fmt "type"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0" + | HOL4 -> + F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") + | Coq | Lean -> print_axiom ()) + | Declared -> ( + match !backend with + | FStar -> + F.pp_print_string fmt "val"; + F.pp_print_space fmt (); + F.pp_print_string fmt state_name; + F.pp_print_space fmt (); + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + F.pp_print_string fmt "Type0" + | HOL4 -> + F.pp_print_string fmt ("val _ = new_type (\"" ^ state_name ^ "\", 0)") + | Coq | Lean -> print_axiom ())); + (* Close the box for the definition *) + F.pp_close_box fmt (); + (* Add breaks to insert new lines between definitions *) + F.pp_print_break fmt 0 0 diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 9a3654b8..a5aa0edd 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -24,8 +24,6 @@ module TraitClauseId = T.TraitClauseId module LoopId = IdGen () -type loop_id = LoopId.id [@@deriving show, ord] - (** We give an identifier to every phase of the synthesis (forward, backward for group of regions 0, etc.) *) module SynthPhaseId = @@ -47,6 +45,8 @@ 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 loop_id = LoopId.id [@@deriving show, ord] +type region_group_id = T.region_group_id [@@deriving show, ord] type mutability = Mut | Const [@@deriving show, ord] (** The assumed types for the pure AST. diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 019a5c35..c5ac4e96 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -1076,6 +1076,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : functions_with_decreases_clause = rec_functions; types_filter_type_args_map = Pure.TypeDeclId.Map.empty; funs_filter_type_args_map = Pure.FunDeclId.Map.empty; + trait_impls_filter_type_args_map = Pure.TraitImplId.Map.empty; } in diff --git a/compiler/dune b/compiler/dune index a4b09df4..648c7325 100644 --- a/compiler/dune +++ b/compiler/dune @@ -24,6 +24,7 @@ Extract ExtractBase ExtractBuiltin + ExtractTypes FunsAnalysis Identifiers InterpreterBorrowsCore -- cgit v1.2.3 From 4a164d24f1ecfb04ada3881e200cb9be16e611dc Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 11:03:39 +0200 Subject: Fix more issues at extraction and factor out defs in ExtractBuiltin --- compiler/Extract.ml | 29 +++- compiler/ExtractBuiltin.ml | 403 ++++++++++++++++----------------------------- 2 files changed, 166 insertions(+), 266 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index caa4835f..fdcd82d9 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1969,17 +1969,34 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) in List.map (fun (name, id) -> compute_item_names name id) required_methods | Some info -> - let funs_map = StringMap.of_list info.funs in + let funs_map = StringMap.of_list info.methods in List.map (fun (item_name, fun_id) -> + let open ExtractBuiltin in let info = StringMap.find item_name funs_map in let trans_funs = get_funs_for_id fun_id in - let rg_with_name_list = - List.map - (fun (trans_fun : fun_decl) -> - List.find (fun (rg, _) -> rg = trans_fun.back_id) info) - trans_funs + let find (trans_fun : fun_decl) = + let info = + List.find_opt + (fun (info : builtin_fun_info) -> info.rg = trans_fun.back_id) + info + in + match info with + | Some info -> (info.rg, info.extract_name) + | None -> + let err = + "Ill-formed builtin information for trait decl \"" + ^ Names.name_to_string trait_decl.name + ^ "\", method \"" ^ item_name + ^ "\": could not find name for region " + ^ Print.option_to_string Pure.show_region_group_id + trans_fun.back_id + in + log#serror err; + if !Config.extract_fail_hard then raise (Failure err) + else (trans_fun.back_id, "%ERROR_BUILTIN_NAME_NOT_FOUND%") in + let rg_with_name_list = List.map find trans_funs in (item_name, rg_with_name_list)) required_methods in diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index fa873c6a..510de583 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -44,6 +44,14 @@ let mk_memoized (f : unit -> 'a) : unit -> 'a = in g +(** Switch between two values depending on the target backend. + + We often compute the same value (typically: a name) if the target + is F*, Coq or HOL4, and a different value if the target is Lean. + *) +let backend_choice (fstar_coq_hol4 : 'a) (lean : 'a) : 'a = + match !backend with Coq | FStar | HOL4 -> fstar_coq_hol4 | Lean -> lean + let builtin_globals : (string * string) list = [ (* Min *) @@ -215,16 +223,16 @@ let builtin_funs () : let extract_name = match extract_name with None -> name | Some name -> name in - let fwd_name = + let basename = match !backend with | FStar | Coq | HOL4 -> String.concat "_" extract_name | Lean -> String.concat "." extract_name in let fwd_suffix = if with_back && back_no_suffix then "_fwd" else "" in - let fwd = [ { rg = None; extract_name = fwd_name ^ fwd_suffix } ] in + let fwd = [ { rg = None; extract_name = basename ^ fwd_suffix } ] in let back_suffix = if with_back && back_no_suffix then "" else "_back" in let back = - if with_back then [ { rg = rg0; extract_name = fwd_name ^ back_suffix } ] + if with_back then [ { rg = rg0; extract_name = basename ^ back_suffix } ] else [] in (name, filter, fwd @ back) @@ -381,227 +389,102 @@ type builtin_trait_decl_info = { - a Rust name - an extraction name - a list of clauses *) - funs : (string * (Types.RegionGroupId.id option * string) list) list; + methods : (string * builtin_fun_info list) list; } [@@deriving show] let builtin_trait_decls_info () = let rg0 = Some Types.RegionGroupId.zero in + let mk_trait (rust_name : string list) ?(extract_name : string option = None) + ?(parent_clauses : string list = []) ?(types : string list = []) + ?(methods : (string * bool) list = []) () : builtin_trait_decl_info = + let extract_name = + match extract_name with + | Some n -> n + | None -> ( + match !backend with + | Coq | FStar | HOL4 -> String.concat "_" rust_name + | Lean -> String.concat "." rust_name) + in + let consts = [] in + let types = + let mk_type item_name = + let type_name = + match !backend with + | Coq | FStar | HOL4 -> extract_name ^ "_" ^ item_name + | Lean -> item_name + in + let clauses = [] in + (item_name, (type_name, clauses)) + in + List.map mk_type types + in + let methods = + let mk_method (item_name, with_back) = + (* TODO: factor out with builtin_funs_info *) + let basename = + match !backend with + | Coq | FStar | HOL4 -> extract_name ^ "_" ^ item_name + | Lean -> item_name + in + let back_no_suffix = false in + let fwd_suffix = if with_back && back_no_suffix then "_fwd" else "" in + let fwd = [ { rg = None; extract_name = basename ^ fwd_suffix } ] in + let back_suffix = if with_back && back_no_suffix then "" else "_back" in + let back = + if with_back then + [ { rg = rg0; extract_name = basename ^ back_suffix } ] + else [] + in + (item_name, fwd @ back) + in + List.map mk_method methods + in + let rust_name = String.concat "::" rust_name in + { rust_name; extract_name; parent_clauses; consts; types; methods } + in [ - { - (* Deref *) - rust_name = "core::ops::deref::Deref"; - extract_name = - (match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_Deref" - | Lean -> "core.ops.deref.Deref"); - parent_clauses = []; - consts = []; - types = + (* Deref *) + mk_trait + [ "core"; "ops"; "deref"; "Deref" ] + ~types:[ "Target" ] + ~methods:[ ("deref", true) ] + (); + (* DerefMut *) + mk_trait + [ "core"; "ops"; "deref"; "DerefMut" ] + ~parent_clauses:[ backend_choice "deref_inst" "derefInst" ] + ~methods:[ ("deref_mut", true) ] + (); + (* Index *) + mk_trait + [ "core"; "ops"; "index"; "Index" ] + ~types:[ "Output" ] + ~methods:[ ("index", true) ] + (); + (* IndexMut *) + mk_trait + [ "core"; "ops"; "index"; "IndexMut" ] + ~parent_clauses:[ backend_choice "index_inst" "indexInst" ] + ~methods:[ ("index_mut", true) ] + (); + (* Sealed *) + mk_trait [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] (); + (* SliceIndex *) + mk_trait + [ "core"; "slice"; "index"; "SliceIndex" ] + ~parent_clauses:[ backend_choice "sealed_inst" "sealedInst" ] + ~types:[ "Output" ] + ~methods: [ - ( "Target", - ( (match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_Deref_Target" - | Lean -> "Target"), - [] ) ); - ]; - funs = - [ - ( "deref", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_Deref_deref" - | Lean -> "deref" ); - ] ); - ]; - }; - { - (* DerefMut *) - rust_name = "core::ops::deref::DerefMut"; - extract_name = - (match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut" - | Lean -> "core.ops.deref.DerefMut"); - parent_clauses = - [ - (match !backend with - | Coq | FStar | HOL4 -> "deref_inst" - | Lean -> "derefInst"); - ]; - consts = []; - types = []; - funs = - [ - ( "deref_mut", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut" - | Lean -> "deref_mut" ); - ( rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_deref_DerefMut_deref_mut_back" - | Lean -> "deref_mut_back" ); - ] ); - ]; - }; - { - (* Index *) - rust_name = "core::ops::index::Index"; - extract_name = - (match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_Index" - | Lean -> "core.ops.index.Index"); - parent_clauses = []; - consts = []; - types = - [ - ( "Output", - ( (match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_Index_Output" - | Lean -> "Output"), - [] ) ); - ]; - funs = - [ - ( "index", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_Index_index" - | Lean -> "index" ); - ] ); - ]; - }; - { - (* IndexMut *) - rust_name = "core::ops::index::IndexMut"; - extract_name = - (match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_IndexMut" - | Lean -> "core.ops.index.IndexMut"); - parent_clauses = - [ - (match !backend with - | Coq | FStar | HOL4 -> "index_inst" - | Lean -> "indexInst"); - ]; - consts = []; - types = []; - funs = - [ - ( "index_mut", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut" - | Lean -> "index_mut" ); - ( rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_ops_index_IndexMut_mut_back" - | Lean -> "index_mut_back" ); - ] ); - ]; - }; - { - (* Sealed *) - rust_name = "core::slice::index::private_slice_index::Sealed"; - extract_name = - (match !backend with - | Coq | FStar | HOL4 -> "core_slice_index_sealed" - | Lean -> "core.slice.index.private_slice_index.Sealed"); - parent_clauses = []; - consts = []; - types = []; - funs = []; - }; - { - (* SliceIndex *) - rust_name = "core::slice::index::SliceIndex"; - extract_name = - (match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex" - | Lean -> "core.slice.index.SliceIndex"); - parent_clauses = - [ - (match !backend with - | Coq | FStar | HOL4 -> "sealed_inst" - | Lean -> "sealedInst"); - ]; - consts = []; - types = - [ - ( "Output", - ( (match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_Output" - | Lean -> "Output"), - [] ) ); - ]; - funs = - [ - ( "get", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_get" - | Lean -> "get" ); - (* The backward function shouldn't be used *) - ( rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_get_back" - | Lean -> "get_back" ); - ] ); - ( "get_mut", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_get_mut" - | Lean -> "get_mut" ); - ( rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_get_mut_back" - | Lean -> "get_mut_back" ); - ] ); - ( "get_unchecked", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_get_unchecked" - | Lean -> "get_unchecked" ); - ] ); - ( "get_unchecked_mut", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_get_unchecked_mut" - | Lean -> "get_unchecked_mut" ); - ] ); - ( "index", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_index" - | Lean -> "index" ); - (* The backward function shouldn't be used *) - ( rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_index_back" - | Lean -> "index_back" ); - ] ); - ( "index_mut", - [ - ( None, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_index_mut" - | Lean -> "index_mut" ); - ( rg0, - match !backend with - | Coq | FStar | HOL4 -> "core_SliceIndex_index_mut_back" - | Lean -> "index_mut_back" ); - ] ); - ]; - }; + ("get", true); + ("get_mut", true); + ("get_unchecked", false); + ("get_unchecked_mut", false); + ("index", true); + ("index_mut", true); + ] + (); ] let mk_builtin_trait_decls_map () = @@ -633,66 +516,66 @@ module SimpleNamePairMap = Collections.MakeMap (SimpleNamePairOrd) let builtin_trait_impls_info () : ((string list * string list) * (bool list option * string)) list = - let fmt ?(filter : bool list option = None) (name : string) : - bool list option * string = + let fmt (type_name : string list) (trait_name : string list) + ?(filter : bool list option = None) () : + (string list * string list) * (bool list option * string) = let name = - match !backend with - | Lean -> name - | FStar | Coq | HOL4 -> - let name = String.split_on_char '.' name in - String.concat "_" name + let trait_name = String.concat "" trait_name ^ "Inst" in + let sep = backend_choice "_" "." in + String.concat sep type_name ^ sep ^ trait_name in - (filter, name) + ((type_name, trait_name), (filter, name)) in (* TODO: fix the names like "[T]" below *) [ (* core::ops::Deref> *) - ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "Deref" ]), - fmt "alloc.boxed.Box.coreOpsDerefInst" ); + fmt [ "alloc"; "boxed"; "Box" ] [ "core"; "ops"; "deref"; "Deref" ] (); (* core::ops::DerefMut> *) - ( ([ "alloc"; "boxed"; "Box" ], [ "core"; "ops"; "deref"; "DerefMut" ]), - fmt "alloc.boxed.Box.coreOpsDerefMutInst" ); + fmt [ "alloc"; "boxed"; "Box" ] [ "core"; "ops"; "deref"; "DerefMut" ] (); (* core::ops::index::Index<[T], I> *) - ( ([ "core"; "slice"; "index"; "[T]" ], [ "core"; "ops"; "index"; "Index" ]), - fmt "core.slice.index.Slice.coreopsindexIndexInst" ); + fmt + [ "core"; "slice"; "index"; "[T]" ] + [ "core"; "ops"; "index"; "Index" ] + (); (* core::slice::index::private_slice_index::Sealed> *) - ( ( [ "core"; "slice"; "index"; "private_slice_index"; "Range" ], - [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] ), - fmt - "core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst" - ); + fmt + [ "core"; "slice"; "index"; "private_slice_index"; "Range" ] + [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] + (); (* core::slice::index::SliceIndex, [T]> *) - ( ( [ "core"; "slice"; "index"; "Range" ], - [ "core"; "slice"; "index"; "SliceIndex" ] ), - fmt "core.slice.index.Range.coresliceindexSliceIndexInst" ); + fmt + [ "core"; "slice"; "index"; "Range" ] + [ "core"; "slice"; "index"; "SliceIndex" ] + (); (* core::ops::index::IndexMut<[T], I> *) - ( ( [ "core"; "slice"; "index"; "[T]" ], - [ "core"; "ops"; "index"; "IndexMut" ] ), - fmt "core.slice.index.Slice.coreopsindexIndexMutInst" ); + fmt + [ "core"; "slice"; "index"; "[T]" ] + [ "core"; "ops"; "index"; "IndexMut" ] + (); (* core::ops::index::Index<[T; N], I> *) - ( ([ "core"; "array"; "[T; N]" ], [ "core"; "ops"; "index"; "Index" ]), - fmt "core.array.Array.coreopsindexIndexInst" ); + fmt [ "core"; "array"; "[T; N]" ] [ "core"; "ops"; "index"; "Index" ] (); (* core::ops::index::IndexMut<[T; N], I> *) - ( ([ "core"; "array"; "[T; N]" ], [ "core"; "ops"; "index"; "IndexMut" ]), - fmt "core.array.Array.coreopsindexIndexMutInst" ); + fmt [ "core"; "array"; "[T; N]" ] [ "core"; "ops"; "index"; "IndexMut" ] (); (* core::slice::index::private_slice_index::Sealed *) - ( ( [ "core"; "slice"; "index"; "private_slice_index"; "usize" ], - [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] ), - fmt - "core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst" - ); + fmt + [ "core"; "slice"; "index"; "private_slice_index"; "usize" ] + [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] + (); (* core::slice::index::SliceIndex *) - ( ( [ "core"; "slice"; "index"; "usize" ], - [ "core"; "slice"; "index"; "SliceIndex" ] ), - fmt "core.slice.index.usize.coresliceindexSliceIndexInst" ); + fmt + [ "core"; "slice"; "index"; "usize" ] + [ "core"; "slice"; "index"; "SliceIndex" ] + (); (* core::ops::index::Index, T> *) - ( ([ "alloc"; "vec"; "Vec" ], [ "core"; "ops"; "index"; "Index" ]), - let filter = Some [ true; true; false ] in - fmt ~filter "alloc.vec.Vec.coreopsindexIndexInst" ); + fmt [ "alloc"; "vec"; "Vec" ] + [ "core"; "ops"; "index"; "Index" ] + ~filter:(Some [ true; true; false ]) + (); (* core::ops::index::IndexMut, T> *) - ( ([ "alloc"; "vec"; "Vec" ], [ "core"; "ops"; "index"; "IndexMut" ]), - let filter = Some [ true; true; false ] in - fmt ~filter "alloc.vec.Vec.coreopsindexIndexMutInst" ); + fmt [ "alloc"; "vec"; "Vec" ] + [ "core"; "ops"; "index"; "IndexMut" ] + ~filter:(Some [ true; true; false ]) + (); ] let mk_builtin_trait_impls_map () = -- cgit v1.2.3 From ca24c351f97a3f8989a6866de0868ef54241b194 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 12:07:50 +0200 Subject: Make progress on fixing the extraction for Lean --- compiler/Extract.ml | 2 +- compiler/ExtractBase.ml | 165 +++++++++++++++++++++++++++++------------------ compiler/ExtractTypes.ml | 48 +++++++------- compiler/Translate.ml | 21 +----- 4 files changed, 130 insertions(+), 106 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index fdcd82d9..574602c7 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -241,7 +241,7 @@ let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) ctx | PatVar (v, _) -> let vname = - ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty + ctx.fmt.var_basename ctx.names_maps.names_map.names_set v.basename v.ty in let ctx, vname = ctx_add_var vname v.id ctx in F.pp_print_string fmt vname; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 7e8e4ffc..8f71116c 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -520,23 +520,6 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) let names_set = StringSet.add name nm.names_set in { id_to_name; name_to_id; names_set } -let names_map_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (TypeId (Assumed id)) name nm - -let names_map_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (StructId (Assumed id)) name nm - -let names_map_add_assumed_variant (id_to_string : id -> string) - (id : assumed_ty) (variant_id : VariantId.id) (name : string) - (nm : names_map) : names_map = - names_map_add id_to_string (VariantId (Assumed id, variant_id)) name nm - -let names_map_add_function (id_to_string : id -> string) (fid : fun_id) - (name : string) (nm : names_map) : names_map = - names_map_add id_to_string (FunId fid) name nm - (** The unsafe names map stores mappings from identifiers to names which might collide. For some backends and some names, it might be acceptable to have collisions. For instance, in Lean, different records can have fields with @@ -547,6 +530,8 @@ let names_map_add_function (id_to_string : id -> string) (fid : fun_id) *) type unsafe_names_map = { id_to_name : string IdMap.t } +let empty_unsafe_names_map = { id_to_name = IdMap.empty } + let unsafe_names_map_add (id : id) (name : string) (nm : unsafe_names_map) : unsafe_names_map = { id_to_name = IdMap.add id name nm.id_to_name } @@ -585,16 +570,7 @@ let basename_to_unique (names_set : StringSet.t) type fun_name_info = { keep_fwd : bool; num_backs : int } -(** Extraction context. - - Note that the extraction context contains information coming from the - LLBC AST (not only the pure AST). This is useful for naming, for instance: - we use the region information to generate the names of the backward - functions, etc. - *) -type extraction_ctx = { - crate : A.crate; - trans_ctx : trans_ctx; +type names_maps = { names_map : names_map; (** The map for id to names, where we forbid name collisions (ex.: we always forbid function name collisions). *) @@ -610,6 +586,19 @@ type extraction_ctx = { the name "u32", and another field of the same record refers to "u32" (for instance in its type). *) +} + +(** Extraction context. + + Note that the extraction context contains information coming from the + LLBC AST (not only the pure AST). This is useful for naming, for instance: + we use the region information to generate the names of the backward + functions, etc. + *) +type extraction_ctx = { + crate : A.crate; + trans_ctx : trans_ctx; + names_maps : names_maps; fmt : formatter; indent_incr : int; (** The indent increment we insert whenever we need to indent more *) @@ -836,12 +825,15 @@ let allow_collisions (id : id) : bool = | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ | TraitMethodId _ -> !Config.record_fields_short_names + | FunId (Pure _ | FromLlbc (FunId (Assumed _), _, _)) -> + (* We map several assumed functions to the same id *) + true | _ -> false -let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = - (* The id_to_string function to print nice debugging messages if there are - * collisions *) - let id_to_string (id : id) : string = id_to_string id ctx in +(** The [id_to_string] function to print nice debugging messages if there are + collisions *) +let names_maps_add (id_to_string : id -> string) (id : id) (name : string) + (nm : names_maps) : names_maps = (* We do not use the same name map if we allow/disallow collisions. We notably use it for field names: some backends like Lean can use the type information to disambiguate field projections. @@ -856,59 +848,90 @@ let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = *) if allow_collisions id then ( (* Check with the ids which are considered to be strict on collisions *) - names_map_check_collision id_to_string id name ctx.strict_names_map; + names_map_check_collision id_to_string id name nm.strict_names_map; { - ctx with - unsafe_names_map = unsafe_names_map_add id name ctx.unsafe_names_map; + nm with + unsafe_names_map = unsafe_names_map_add id name nm.unsafe_names_map; }) else (* Remark: if we are strict on collisions: - we add the id to the strict collisions map - we check that the id doesn't collide with the unsafe map + TODO: we might not check that: + - a user defined function doesn't collide with an assumed function + - two trait decl items don't collide with each other *) let strict_names_map = if strict_collisions id then - names_map_add id_to_string id name ctx.strict_names_map - else ctx.strict_names_map + names_map_add id_to_string id name nm.strict_names_map + else nm.strict_names_map in - let names_map = names_map_add id_to_string id name ctx.names_map in - { ctx with strict_names_map; names_map } + let names_map = names_map_add id_to_string id name nm.names_map in + { nm with strict_names_map; names_map } -let ctx_get (id : id) (ctx : extraction_ctx) : string = +let ctx_add (id : id) (name : string) (ctx : extraction_ctx) : extraction_ctx = + let id_to_string (id : id) : string = id_to_string id ctx in + let names_maps = names_maps_add id_to_string id name ctx.names_maps in + { ctx with names_maps } + +(** The [id_to_string] function to print nice debugging messages if there are + collisions *) +let names_maps_get (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" ^ String.concat "," (List.map - (fun (id, n) -> "\n " ^ id_to_string id ctx ^ " -> " ^ n) + (fun (id, n) -> "\n " ^ id_to_string id ^ " -> " ^ n) (IdMap.bindings m)) ^ "\n]" in if allow_collisions id then ( - let m = ctx.unsafe_names_map.id_to_name in + let m = nm.unsafe_names_map.id_to_name in match IdMap.find_opt id m with | Some s -> s | None -> let err = - "Could not find: " ^ id_to_string id ctx ^ "\nNames map:\n" + "Could not find: " ^ id_to_string id ^ "\nNames map:\n" ^ map_to_string m in log#serror err; if !Config.extract_fail_hard then raise (Failure err) - else - "(%%%ERROR: unknown identifier\": " ^ id_to_string id ctx ^ "\"%%%)") + else "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else - let m = ctx.names_map.id_to_name in + let m = nm.names_map.id_to_name in match IdMap.find_opt id m with | Some s -> s | None -> let err = - "Could not find: " ^ id_to_string id ctx ^ "\nNames map:\n" + "Could not find: " ^ id_to_string id ^ "\nNames map:\n" ^ map_to_string m in log#serror err; if !Config.extract_fail_hard then raise (Failure err) - else "(ERROR: \"" ^ id_to_string id ctx ^ "\")" + else "(ERROR: \"" ^ id_to_string id ^ "\")" + +let ctx_get (id : id) (ctx : extraction_ctx) : string = + let id_to_string (id : id) : string = id_to_string id ctx in + names_maps_get id_to_string id ctx.names_maps + +let names_maps_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) + (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (TypeId (Assumed id)) name nm + +let names_maps_add_assumed_struct (id_to_string : id -> string) + (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (StructId (Assumed id)) name nm + +let names_maps_add_assumed_variant (id_to_string : id -> string) + (id : assumed_ty) (variant_id : VariantId.id) (name : string) + (nm : names_maps) : names_maps = + names_maps_add id_to_string (VariantId (Assumed id, variant_id)) name nm + +let names_maps_add_function (id_to_string : id -> string) (fid : fun_id) + (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (FunId fid) name nm let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = ctx_get (GlobalId id) ctx @@ -999,9 +1022,12 @@ let ctx_get_termination_measure (def_id : A.FunDeclId.id) (** Generate a unique type variable name and add it to the context *) let ctx_add_type_var (basename : string) (id : TypeVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = - let name = ctx.fmt.type_var_basename ctx.names_map.names_set basename in let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name + ctx.fmt.type_var_basename ctx.names_maps.names_map.names_set basename + in + let name = + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + name in let ctx = ctx_add (TypeVarId id) name ctx in (ctx, name) @@ -1010,10 +1036,12 @@ let ctx_add_type_var (basename : string) (id : TypeVarId.id) let ctx_add_const_generic_var (basename : string) (id : ConstGenericVarId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = - ctx.fmt.const_generic_var_basename ctx.names_map.names_set basename + ctx.fmt.const_generic_var_basename ctx.names_maps.names_map.names_set + basename in let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index name + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + name in let ctx = ctx_add (ConstGenericVarId id) name ctx in (ctx, name) @@ -1029,7 +1057,8 @@ let ctx_add_type_vars (vars : (string * TypeVarId.id) list) let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename in let ctx = ctx_add (VarId id) name ctx in (ctx, name) @@ -1038,7 +1067,8 @@ let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : let ctx_add_trait_self_clause (ctx : extraction_ctx) : extraction_ctx * string = let basename = ctx.fmt.trait_self_clause_basename in let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename in let ctx = ctx_add TraitSelfClauseId name ctx in (ctx, name) @@ -1047,7 +1077,8 @@ let ctx_add_trait_self_clause (ctx : extraction_ctx) : extraction_ctx * string = let ctx_add_local_trait_clause (basename : string) (id : TraitClauseId.id) (ctx : extraction_ctx) : extraction_ctx * string = let name = - basename_to_unique ctx.names_map.names_set ctx.fmt.append_index basename + basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename in let ctx = ctx_add (LocalTraitClauseId id) name ctx in (ctx, name) @@ -1057,7 +1088,9 @@ let ctx_add_vars (vars : var list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (v : var) -> - let name = ctx.fmt.var_basename ctx.names_map.names_set v.basename v.ty in + let name = + ctx.fmt.var_basename ctx.names_maps.names_map.names_set v.basename v.ty + in ctx_add_var name v.id ctx) ctx vars @@ -1078,7 +1111,9 @@ let ctx_add_local_trait_clauses (clauses : trait_clause list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (c : trait_clause) -> - let basename = ctx.fmt.trait_clause_basename ctx.names_map.names_set c in + let basename = + ctx.fmt.trait_clause_basename ctx.names_maps.names_map.names_set c + in ctx_add_local_trait_clause basename c.clause_id ctx) ctx clauses @@ -1189,9 +1224,10 @@ type names_map_init = { assumed_pure_functions : (pure_assumed_fun_id * string) list; } -(** Initialize a names map with a proper set of keywords/names coming from the +(** Initialize names maps with a proper set of keywords/names coming from the target language/prover. *) -let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = +let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps + = let int_names = List.map fmt.int_name T.all_int_types in let keywords = List.concat @@ -1207,7 +1243,10 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = * Also note that we don't need this mapping for keywords: we insert keywords only * to check collisions. *) let id_to_name = IdMap.empty in - let nm = { id_to_name; name_to_id; names_set } in + let names_map = { id_to_name; name_to_id; names_set } in + let unsafe_names_map = empty_unsafe_names_map in + let strict_names_map = empty_names_map in + let nm = { names_map; unsafe_names_map; strict_names_map } in (* For debugging - we are creating bindings for assumed types and functions, so * it is ok if we simply use the "show" function (those aren't simply identified * by numbers) *) @@ -1221,19 +1260,19 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = let nm = List.fold_left (fun nm (type_id, name) -> - names_map_add_assumed_type id_to_string type_id name nm) + names_maps_add_assumed_type id_to_string type_id name nm) nm init.assumed_adts in let nm = List.fold_left (fun nm (type_id, name) -> - names_map_add_assumed_struct id_to_string type_id name nm) + names_maps_add_assumed_struct id_to_string type_id name nm) nm init.assumed_structs in let nm = List.fold_left (fun nm (type_id, variant_id, name) -> - names_map_add_assumed_variant id_to_string type_id variant_id name nm) + names_maps_add_assumed_variant id_to_string type_id variant_id name nm) nm init.assumed_variants in let assumed_functions = @@ -1245,7 +1284,7 @@ let initialize_names_map (fmt : formatter) (init : names_map_init) : names_map = in let nm = List.fold_left - (fun nm (fid, name) -> names_map_add_function id_to_string fid name nm) + (fun nm (fid, name) -> names_maps_add_function id_to_string fid name nm) nm assumed_functions in (* Return *) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 219f273f..fd3baf0d 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -300,30 +300,30 @@ let assumed_llbc_functions () : match !backend with | FStar | Coq | HOL4 -> [ - (ArrayIndexShared, None, "array_index_shared"); - (ArrayIndexMut, None, "array_index_mut_fwd"); - (ArrayIndexMut, rg0, "array_index_mut_back"); - (ArrayToSliceShared, None, "array_to_slice_shared"); - (ArrayToSliceMut, None, "array_to_slice_mut_fwd"); - (ArrayToSliceMut, rg0, "array_to_slice_mut_back"); + (ArrayIndexShared, None, "array_index_usize"); + (ArrayIndexMut, None, "array_index_usize"); + (ArrayIndexMut, rg0, "array_update_usize"); + (ArrayToSliceShared, None, "array_to_slice"); + (ArrayToSliceMut, None, "array_to_slice"); + (ArrayToSliceMut, rg0, "array_from_slice"); (ArrayRepeat, None, "array_repeat"); - (SliceIndexShared, None, "slice_index_shared"); - (SliceIndexMut, None, "slice_index_mut_fwd"); - (SliceIndexMut, rg0, "slice_index_mut_back"); + (SliceIndexShared, None, "slice_index_usize"); + (SliceIndexMut, None, "slice_index_usize"); + (SliceIndexMut, rg0, "slice_update_usize"); (SliceLen, None, "slice_len"); ] | Lean -> [ - (ArrayIndexShared, None, "Array.index_shared"); - (ArrayIndexMut, None, "Array.index_mut"); - (ArrayIndexMut, rg0, "Array.index_mut_back"); - (ArrayToSliceShared, None, "Array.to_slice_shared"); - (ArrayToSliceMut, None, "Array.to_slice_mut"); - (ArrayToSliceMut, rg0, "Array.to_slice_mut_back"); + (ArrayIndexShared, None, "Array.index_usize"); + (ArrayIndexMut, None, "Array.index_usize"); + (ArrayIndexMut, rg0, "Array.update_usize"); + (ArrayToSliceShared, None, "Array.to_slice"); + (ArrayToSliceMut, None, "Array.to_slice"); + (ArrayToSliceMut, rg0, "Array.from_slice"); (ArrayRepeat, None, "Array.repeat"); - (SliceIndexShared, None, "Slice.index_shared"); - (SliceIndexMut, None, "Slice.index_mut"); - (SliceIndexMut, rg0, "Slice.index_mut_back"); + (SliceIndexShared, None, "Slice.index_usize"); + (SliceIndexMut, None, "Slice.index_usize"); + (SliceIndexMut, rg0, "Slice.update_usize"); (SliceLen, None, "Slice.len"); ] @@ -941,11 +941,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) extract_binop; } -let mk_formatter_and_names_map (ctx : trans_ctx) (crate_name : string) - (variant_concatenate_type_name : bool) : formatter * names_map = +let mk_formatter_and_names_maps (ctx : trans_ctx) (crate_name : string) + (variant_concatenate_type_name : bool) : formatter * names_maps = let fmt = mk_formatter ctx crate_name variant_concatenate_type_name in - let names_map = initialize_names_map fmt (names_map_init ()) in - (fmt, names_map) + let names_maps = initialize_names_maps fmt (names_map_init ()) in + (fmt, names_maps) let is_single_opaque_fun_decl_group (dg : Pure.fun_decl list) : bool = match dg with [ d ] -> d.body = None | _ -> false @@ -1507,8 +1507,8 @@ let extract_type_decl_variant (ctx : extraction_ctx) (fmt : F.formatter) | Some field_name -> let var_id = VarId.of_int (FieldId.to_int fid) in let field_name = - ctx.fmt.var_basename ctx.names_map.names_set (Some field_name) - f.field_ty + ctx.fmt.var_basename ctx.names_maps.names_map.names_set + (Some field_name) f.field_ty in let ctx, field_name = ctx_add_var field_name var_id ctx in F.pp_print_string fmt (field_name ^ " :"); diff --git a/compiler/Translate.ml b/compiler/Translate.ml index c5ac4e96..cb23198a 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -990,23 +990,10 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : in (* Initialize the names map (we insert the names of the "primitives" declarations, and insert the names of the local declarations later) *) - let mk_formatter_and_names_map = Extract.mk_formatter_and_names_map in - let fmt, names_map = - mk_formatter_and_names_map trans_ctx crate.name + let fmt, names_maps = + Extract.mk_formatter_and_names_maps trans_ctx crate.name variant_concatenate_type_name in - let strict_names_map = - let open ExtractBase in - let ids = - List.filter - (fun (id, _) -> strict_collisions id) - (IdMap.bindings names_map.id_to_name) - in - List.fold_left - (* id_to_string: we shouldn't need to use it *) - (fun m (id, n) -> names_map_add show_id id n m) - empty_names_map ids - in (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) @@ -1060,9 +1047,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : { ExtractBase.crate; trans_ctx; - names_map; - unsafe_names_map = { id_to_name = ExtractBase.IdMap.empty }; - strict_names_map; + names_maps; fmt; indent_incr = 2; use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; -- cgit v1.2.3 From 7a65b74fb889e87a071b1cc2f0dbd355ebd3c1e5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 13:52:38 +0200 Subject: Improve ExtractBuiltin.ml --- compiler/ExtractBuiltin.ml | 86 ++++++++++++++++++++++++++-------------------- compiler/ExtractTypes.ml | 17 +++++---- 2 files changed, 57 insertions(+), 46 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 510de583..8fcdea56 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -97,7 +97,7 @@ type builtin_enum_variant_info = { [@@deriving show] type builtin_type_body_info = - | Struct of string * string list + | Struct of string * (string * string) list (* The constructor name and the map for the field names *) | Enum of builtin_enum_variant_info list (* For every variant, a map for the field names *) @@ -116,6 +116,19 @@ type builtin_type_info = { } [@@deriving show] +type type_variant_kind = + | KOpaque + | KStruct of (string * string) list + (* TODO: handle the tuple case *) + | KEnum (* TODO *) + +let mk_struct_constructor (type_name : string) : string = + let prefix = + match !backend with FStar -> "Mk" | Coq | HOL4 -> "mk" | Lean -> "" + in + let suffix = match !backend with FStar | Coq | HOL4 -> "" | Lean -> ".mk" in + prefix ^ type_name ^ suffix + (** The assumed types. The optional list of booleans is filtering information for the type @@ -123,28 +136,44 @@ type builtin_type_info = { a type parameter for the allocator to use, which we want to filter. *) let builtin_types () : builtin_type_info list = + let mk_type (rust_name : string list) ?(keep_params : bool list option = None) + ?(kind : type_variant_kind = KOpaque) () : builtin_type_info = + let extract_name = + let sep = backend_choice "_" "." in + String.concat sep rust_name + in + let body_info : builtin_type_body_info option = + match kind with + | KOpaque -> None + | KStruct fields -> + let fields = + List.map + (fun (rname, name) -> + (rname, backend_choice (extract_name ^ name) name)) + fields + in + let constructor = mk_struct_constructor extract_name in + Some (Struct (constructor, fields)) + | KEnum -> raise (Failure "TODO") + in + { rust_name; extract_name; keep_params; body_info } + in + [ (* Alloc *) - { - rust_name = [ "alloc"; "alloc"; "Global" ]; - extract_name = - (match !backend with - | Lean -> "alloc.alloc.Global" - | Coq | FStar | HOL4 -> "alloc_alloc_Global"); - keep_params = None; - body_info = None; - }; + mk_type [ "alloc"; "alloc"; "Global" ] (); (* Vec *) - { - rust_name = [ "alloc"; "vec"; "Vec" ]; - extract_name = - (match !backend with - | Lean -> "alloc.vec.Vec" - | Coq | FStar | HOL4 -> "alloc_vec_Vec"); - keep_params = Some [ true; false ]; - body_info = None; - }; - (* Option *) + mk_type [ "alloc"; "vec"; "Vec" ] ~keep_params:(Some [ true; false ]) (); + (* Range *) + mk_type + [ "core"; "ops"; "range"; "Range" ] + ~kind:(KStruct [ ("start", "start"); ("end", "end_") ]) + (); + (* Option + + This one is more custom because we use the standard "option" type from + the target backend. + *) { rust_name = [ "core"; "option"; "Option" ]; extract_name = @@ -176,23 +205,6 @@ let builtin_types () : builtin_type_info list = }; ]); }; - (* Range *) - { - rust_name = [ "core"; "ops"; "range"; "Range" ]; - extract_name = - (match !backend with - | Lean -> "core.ops.range.Range" - | Coq | FStar | HOL4 -> "core_ops_range_Range"); - keep_params = None; - body_info = - Some - (Struct - ( (match !backend with - | Lean -> "core.ops.range.Range.mk" - | Coq | HOL4 -> "mk_core_ops_range_Range" - | FStar -> "Mkcore_ops_range_Range"), - [ "start"; "end_" ] )); - }; ] let mk_builtin_types_map () = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index fd3baf0d..8ffbce41 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -655,13 +655,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) in let struct_constructor (basename : name) : string = let tname = type_name basename in - let prefix = - match !backend with FStar -> "Mk" | Coq | HOL4 -> "mk" | Lean -> "" - in - let suffix = - match !backend with FStar | Coq | HOL4 -> "" | Lean -> ".mk" - in - prefix ^ tname ^ suffix + ExtractBuiltin.mk_struct_constructor tname in let get_fun_name fname = let fname = get_name fname in @@ -1414,8 +1408,13 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> let field_names = FieldId.mapi - (fun fid (_, name) -> (fid, name)) - (List.combine fields field_names) + (fun fid (field : field) -> + let rust_name = Option.get field.field_name in + let name = + snd (List.find (fun (n, _) -> n = rust_name) field_names) + in + (fid, name)) + fields in (field_names, cons_name) | Some info -> -- cgit v1.2.3 From 442f0aede5da127b4828a90bcbade73a345340e3 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 14:10:57 +0200 Subject: Make progress on fixing the extraction --- compiler/ExtractBuiltin.ml | 32 ++++++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 8fcdea56..afa0dd6f 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -528,12 +528,18 @@ module SimpleNamePairMap = Collections.MakeMap (SimpleNamePairOrd) let builtin_trait_impls_info () : ((string list * string list) * (bool list option * string)) list = - let fmt (type_name : string list) (trait_name : string list) - ?(filter : bool list option = None) () : + let fmt (type_name : string list) + ?(extract_type_name : string list option = None) + (trait_name : string list) ?(filter : bool list option = None) () : (string list * string list) * (bool list option * string) = let name = let trait_name = String.concat "" trait_name ^ "Inst" in let sep = backend_choice "_" "." in + let type_name = + match extract_type_name with + | Some type_name -> type_name + | None -> type_name + in String.concat sep type_name ^ sep ^ trait_name in ((type_name, trait_name), (filter, name)) @@ -547,8 +553,15 @@ let builtin_trait_impls_info () : (* core::ops::index::Index<[T], I> *) fmt [ "core"; "slice"; "index"; "[T]" ] + ~extract_type_name:(Some [ "core"; "slice"; "index"; "Slice" ]) [ "core"; "ops"; "index"; "Index" ] (); + (* core::ops::index::IndexMut<[T], I> *) + fmt + [ "core"; "slice"; "index"; "[T]" ] + ~extract_type_name:(Some [ "core"; "slice"; "index"; "Slice" ]) + [ "core"; "ops"; "index"; "IndexMut" ] + (); (* core::slice::index::private_slice_index::Sealed> *) fmt [ "core"; "slice"; "index"; "private_slice_index"; "Range" ] @@ -559,15 +572,18 @@ let builtin_trait_impls_info () : [ "core"; "slice"; "index"; "Range" ] [ "core"; "slice"; "index"; "SliceIndex" ] (); - (* core::ops::index::IndexMut<[T], I> *) + (* core::ops::index::Index<[T; N], I> *) fmt - [ "core"; "slice"; "index"; "[T]" ] - [ "core"; "ops"; "index"; "IndexMut" ] + [ "core"; "array"; "[T; N]" ] + ~extract_type_name:(Some [ "core"; "array"; "Array" ]) + [ "core"; "ops"; "index"; "Index" ] (); - (* core::ops::index::Index<[T; N], I> *) - fmt [ "core"; "array"; "[T; N]" ] [ "core"; "ops"; "index"; "Index" ] (); (* core::ops::index::IndexMut<[T; N], I> *) - fmt [ "core"; "array"; "[T; N]" ] [ "core"; "ops"; "index"; "IndexMut" ] (); + fmt + [ "core"; "array"; "[T; N]" ] + ~extract_type_name:(Some [ "core"; "array"; "Array" ]) + [ "core"; "ops"; "index"; "IndexMut" ] + (); (* core::slice::index::private_slice_index::Sealed *) fmt [ "core"; "slice"; "index"; "private_slice_index"; "usize" ] -- cgit v1.2.3 From 005ad3cc03745bc9211defa481d5e45738a6d832 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 14:37:34 +0200 Subject: Improve the handling of saved function effects in ExtractBuiltin.ml --- compiler/ExtractBuiltin.ml | 40 +++++++++++++++++++++++++++------------- compiler/FunsAnalysis.ml | 28 +++++++++++++++++----------- 2 files changed, 44 insertions(+), 24 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index afa0dd6f..363955bf 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -350,7 +350,9 @@ let mk_builtin_funs_map () = let builtin_funs_map = mk_memoized mk_builtin_funs_map -let builtin_non_fallible_funs = +type effect_info = { can_fail : bool; stateful : bool } + +let builtin_fun_effects = let int_names = [ "usize"; @@ -377,19 +379,31 @@ let builtin_non_fallible_funs = int_names in let int_funs = List.concat int_funs in - [ - "alloc::vec::Vec::new"; - "alloc::vec::Vec::len"; - "alloc::boxed::Box::deref"; - "alloc::boxed::Box::deref_mut"; - "core::mem::replace"; - "core::mem::take"; - ] - @ int_funs + let no_fail_no_state_funs = + [ + "alloc::vec::Vec::new"; + "alloc::vec::Vec::len"; + "alloc::boxed::Box::deref"; + "alloc::boxed::Box::deref_mut"; + "core::mem::replace"; + "core::mem::take"; + ] + @ int_funs + in + let no_fail_no_state_funs = + List.map + (fun n -> (n, { can_fail = false; stateful = false })) + no_fail_no_state_funs + in + let no_state_funs = [ "alloc::vec::Vec::push" ] in + let no_state_funs = + List.map (fun n -> (n, { can_fail = true; stateful = false })) no_state_funs + in + no_fail_no_state_funs @ no_state_funs -let builtin_non_fallible_funs_set = - SimpleNameSet.of_list - (List.map string_to_simple_name builtin_non_fallible_funs) +let builtin_fun_effects_map = + SimpleNameMap.of_list + (List.map (fun (n, x) -> (string_to_simple_name n, x)) builtin_fun_effects) type builtin_trait_decl_info = { rust_name : string; diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 3ba5d35d..9eac3e6f 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -57,16 +57,16 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let stateful = ref false in let can_diverge = ref false in let is_rec = ref false in - let is_builtin_non_fallible_group = ref false in + let group_has_builtin_info = ref false in (* We have some specialized knowledge of some library functions; we don't have any more custom treatment than this, and these functions can be modeled suitably in Primitives.fst, rather than special-casing for them all the way. *) - let is_builtin_non_fallible (f : fun_decl) : bool = + let get_builtin_info (f : fun_decl) : ExtractBuiltin.effect_info option = let open ExtractBuiltin in let name = name_to_simple_name f.name in - SimpleNameSet.mem name builtin_non_fallible_funs_set + SimpleNameMap.find_opt name builtin_fun_effects_map in (* JP: Why not use a reduce visitor here with a tuple of the values to be @@ -119,16 +119,21 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) in (* Sanity check: global bodies don't contain stateful calls *) assert ((not f.is_global_decl_body) || not !stateful); - let is_builtin_non_fallible = is_builtin_non_fallible f in - is_builtin_non_fallible_group := - !is_builtin_non_fallible_group || is_builtin_non_fallible; + let builtin_info = get_builtin_info f in + let has_builtin_info = builtin_info <> None in + group_has_builtin_info := !group_has_builtin_info || has_builtin_info; match f.body with | None -> - obj#may_fail (not is_builtin_non_fallible); + let info_can_fail, info_stateful = + match builtin_info with + | None -> (true, false) + | Some { can_fail; stateful } -> (can_fail, stateful) + in + obj#may_fail info_can_fail; stateful := (not f.is_global_decl_body) && use_state - && not is_builtin_non_fallible + && not (has_builtin_info && not info_stateful) | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; @@ -136,7 +141,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) * groups containing globals contain exactly one declaration *) let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in assert ((not is_global_decl_body) || List.length d = 1); - assert ((not !is_builtin_non_fallible_group) || List.length d = 1); + assert ((not !group_has_builtin_info) || List.length d = 1); (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. @@ -144,8 +149,9 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) * builtin functions which are marked as non-fallible. * *) can_fail := - ((not is_global_decl_body) && not !is_builtin_non_fallible_group) - || !can_fail; + if is_global_decl_body then !can_fail + else if !group_has_builtin_info then !can_fail + else true; { can_fail = !can_fail; stateful = !stateful; -- cgit v1.2.3 From 7ffcb8e9c5c03f198362fd27bd42f30064541509 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 15:06:36 +0200 Subject: Fix some issues and regenerate the HashmapMain example for Lean --- compiler/ExtractBuiltin.ml | 11 ++++++++++- compiler/FunsAnalysis.ml | 11 ++++++----- compiler/InterpreterExpressions.ml | 3 ++- 3 files changed, 18 insertions(+), 7 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 363955bf..2dbacce3 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -381,6 +381,7 @@ let builtin_fun_effects = let int_funs = List.concat int_funs in let no_fail_no_state_funs = [ + (* TODO: redundancy with the funs information below *) "alloc::vec::Vec::new"; "alloc::vec::Vec::len"; "alloc::boxed::Box::deref"; @@ -395,7 +396,15 @@ let builtin_fun_effects = (fun n -> (n, { can_fail = false; stateful = false })) no_fail_no_state_funs in - let no_state_funs = [ "alloc::vec::Vec::push" ] in + let no_state_funs = + [ + (* TODO: redundancy with the funs information below *) + "alloc::vec::Vec::push"; + "alloc::vec::Vec::index"; + "alloc::vec::Vec::index_mut"; + "alloc::vec::Vec::index_mut_back"; + ] + in let no_state_funs = List.map (fun n -> (n, { can_fail = true; stateful = false })) no_state_funs in diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 9eac3e6f..69c0df71 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -76,6 +76,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) object (self) inherit [_] iter_statement as super method may_fail b = can_fail := !can_fail || b + method maybe_stateful b = stateful := !stateful || b method! visit_Assert env a = self#may_fail true; @@ -126,14 +127,14 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) | None -> let info_can_fail, info_stateful = match builtin_info with - | None -> (true, false) + | None -> (true, use_state) | Some { can_fail; stateful } -> (can_fail, stateful) in obj#may_fail info_can_fail; - stateful := - (not f.is_global_decl_body) - && use_state - && not (has_builtin_info && not info_stateful) + obj#maybe_stateful + (if f.is_global_decl_body then false + else if not use_state then false + else info_stateful) | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 341e97eb..245f3b77 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -144,7 +144,8 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) (match v.V.ty with | T.Adt (T.Assumed T.Box, _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.Adt (T.AdtId _, _) -> assert allow_adt_copy + | T.Adt (T.AdtId _, _) as ty -> + assert (allow_adt_copy || ty_is_primitively_copyable ty) | T.Adt (T.Tuple, _) -> () (* Ok *) | T.Adt ( T.Assumed (Slice | T.Array), -- cgit v1.2.3 From 1110b3da85e93ba0755a665edd5b8c986c54cef0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 16:15:35 +0200 Subject: Make minor modifications and update the array test for F* --- compiler/Driver.ml | 4 +++- compiler/ExtractBase.ml | 22 ++++++++++------------ compiler/ExtractBuiltin.ml | 5 ++++- 3 files changed, 17 insertions(+), 14 deletions(-) (limited to 'compiler') diff --git a/compiler/Driver.ml b/compiler/Driver.ml index 3b9ea4d1..b660b5a5 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -162,7 +162,9 @@ let () = | FStar -> (* Some patterns are not supported *) decompose_monadic_let_bindings := false; - decompose_nested_let_patterns := false + decompose_nested_let_patterns := false; + (* F* can disambiguate the field names *) + record_fields_short_names := true | Coq -> (* Some patterns are not supported *) decompose_monadic_let_bindings := true; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 8f71116c..6faa40b2 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1332,22 +1332,20 @@ let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) let rg_suff = (* TODO: make all the backends match what is done for Lean *) match rg with - | None -> ( - match !Config.backend with - | FStar | Coq | HOL4 -> "_fwd" - | Lean -> - (* In order to avoid name conflicts: - * - if the forward is eliminated, we add the suffix "_fwd" (it won't be used) - * - otherwise, no suffix (because the backward functions will have a suffix) - *) - if num_backs = 1 && not keep_fwd then "_fwd" else "") + | None -> + if + (* In order to avoid name conflicts: + * - if the forward is eliminated, we add the suffix "_fwd" (it won't be used) + * - otherwise, no suffix (because the backward functions will have a suffix) + *) + num_backs = 1 && not keep_fwd + then "_fwd" + else "" | Some rg -> assert (num_region_groups > 0 && num_backs > 0); if num_backs = 1 then (* Exactly one backward function *) - match !Config.backend with - | FStar | Coq | HOL4 -> if not keep_fwd then "_fwd_back" else "_back" - | Lean -> if not keep_fwd then "" else "_back" + if not keep_fwd then "" else "_back" else if (* Several region groups/backward functions: - if all the regions in the group have names, we use those names diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 2dbacce3..c6bde9c2 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -149,7 +149,10 @@ let builtin_types () : builtin_type_info list = let fields = List.map (fun (rname, name) -> - (rname, backend_choice (extract_name ^ name) name)) + ( rname, + match !backend with + | FStar | Lean -> name + | Coq | HOL4 -> extract_name ^ "_" ^ name )) fields in let constructor = mk_struct_constructor extract_name in -- cgit v1.2.3 From 1c4b1222dbf5e090c26e613694d63577343ab2fd Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 12:18:02 +0200 Subject: Fix a minor issue and regenerate some F* test files --- compiler/ExtractTypes.ml | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 8ffbce41..dcd69f2b 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -622,11 +622,18 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | FStar | Lean | HOL4 -> name | Coq -> capitalize_first_letter name in - let type_name name = + let get_type_name_no_suffix name = match !backend with - | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_t" + | FStar | Coq | HOL4 -> String.concat "_" (get_type_name name) | Lean -> String.concat "." (get_type_name name) in + let type_name name = + match !backend with + | FStar -> + StringUtils.lowercase_first_letter (get_type_name_no_suffix name ^ "_t") + | Coq | HOL4 -> get_type_name_no_suffix name ^ "_t" + | Lean -> get_type_name_no_suffix name + in let field_name (def_name : name) (field_id : FieldId.id) (field_name : string option) : string = let field_name_s = @@ -641,15 +648,18 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) "_" ^ field_name_s else field_name_s else - let def_name = type_name_to_snake_case def_name ^ "_" in - def_name ^ field_name_s + let def_name = get_type_name_no_suffix def_name ^ "_" ^ field_name_s in + match !backend with + | Lean | HOL4 -> def_name + | Coq | FStar -> StringUtils.lowercase_first_letter def_name in let variant_name (def_name : name) (variant : string) : string = match !backend with | FStar | Coq | HOL4 -> let variant = to_camel_case variant in if variant_concatenate_type_name then - type_name_to_camel_case def_name ^ variant + StringUtils.capitalize_first_letter + (get_type_name_no_suffix def_name ^ "_" ^ variant) else variant | Lean -> variant in @@ -660,7 +670,10 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let get_fun_name fname = let fname = get_name fname in (* TODO: don't convert to snake case for Coq, HOL4, F* *) - flatten_name fname + let fname = flatten_name fname in + match !backend with + | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter fname + | Lean -> fname in let global_name (name : global_name) : string = (* Converting to snake case also lowercases the letters (in Rust, global @@ -688,9 +701,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) with the trait decl name *) let trait_decl = let name = trait_decl.name in - match !backend with - | FStar | Coq | HOL4 -> type_name_to_snake_case name ^ "_inst" - | Lean -> String.concat "" (get_type_name name) ^ "Inst" + get_type_name_no_suffix name ^ "Inst" in flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in -- cgit v1.2.3 From b50498d74f8e0b4a5f53468200510edec9d9674a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 15:16:20 +0200 Subject: Fix minor issues in the name collision detection --- compiler/ExtractBase.ml | 32 +++++++++++++++++++++++--------- compiler/ExtractTypes.ml | 1 - 2 files changed, 23 insertions(+), 10 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 6faa40b2..8ddb2ec6 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -501,6 +501,15 @@ let names_map_check_collision (id_to_string : id -> string) (id : id) (* There is a clash: print a nice debugging message for the user *) report_name_collision id_to_string clash id name +(** Insert bindings in a names map without checking for collisions *) +let names_map_add_unchecked (id : id) (name : string) (nm : names_map) : + names_map = + (* Insert *) + let id_to_name = IdMap.add id name nm.id_to_name in + let name_to_id = StringMap.add name id nm.name_to_id in + let names_set = StringSet.add name nm.names_set in + { id_to_name; name_to_id; names_set } + let names_map_add (id_to_string : id -> string) (id : id) (name : string) (nm : names_map) : names_map = (* Check if there is a clash *) @@ -515,10 +524,7 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) (* If we fail hard on errors, raise an exception *) if !Config.extract_fail_hard then raise (Failure err)); (* Insert *) - let id_to_name = IdMap.add id name nm.id_to_name in - let name_to_id = StringMap.add name id nm.name_to_id in - let names_set = StringSet.add name nm.names_set in - { id_to_name; name_to_id; names_set } + names_map_add_unchecked id name nm (** The unsafe names map stores mappings from identifiers to names which might collide. For some backends and some names, it might be acceptable to have @@ -1235,10 +1241,8 @@ let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps [ fmt.bool_name; fmt.char_name; fmt.str_name ]; int_names; init.keywords; ] in - let names_set = StringSet.of_list keywords in - let name_to_id = - StringMap.of_list (List.map (fun x -> (x, UnknownId)) keywords) - in + let names_set = StringSet.empty in + let name_to_id = StringMap.empty in (* We fist initialize [id_to_name] as empty, because the id of a keyword is [UnknownId]. * Also note that we don't need this mapping for keywords: we insert keywords only * to check collisions. *) @@ -1246,11 +1250,21 @@ let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps let names_map = { id_to_name; name_to_id; names_set } in let unsafe_names_map = empty_unsafe_names_map in let strict_names_map = empty_names_map in - let nm = { names_map; unsafe_names_map; strict_names_map } in (* For debugging - we are creating bindings for assumed types and functions, so * it is ok if we simply use the "show" function (those aren't simply identified * by numbers) *) let id_to_string = show_id in + (* Add the keywords as strict collisions *) + let strict_names_map = + List.fold_left + (fun nm name -> + (* There is duplication in the keywords so we don't check the collisions + while registering them (what is important is that there are no collisions + between keywords and user-defined identifiers) *) + names_map_add_unchecked UnknownId name nm) + strict_names_map keywords + in + let nm = { names_map; unsafe_names_map; strict_names_map } in (* Then we add: * - the assumed types * - the assumed struct constructors diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index dcd69f2b..688ed352 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -110,7 +110,6 @@ let keywords () = "let"; "list"; "match"; - "not"; "open"; "rec"; "scalar_cast"; -- cgit v1.2.3 From dc0032f6ce3b837ba2f431bbb5c9a92c625f629f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 30 Oct 2023 12:24:05 +0100 Subject: Make minor updates following changes in Charon --- compiler/Pure.ml | 1 - compiler/SymbolicToPure.ml | 7 ++----- 2 files changed, 2 insertions(+), 6 deletions(-) (limited to 'compiler') diff --git a/compiler/Pure.ml b/compiler/Pure.ml index a5aa0edd..70653e57 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -1013,7 +1013,6 @@ type trait_decl = { name : name; generics : generic_params; preds : predicates; - all_trait_clauses : trait_clause list; 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; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 885d2ba5..c629a96f 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -3092,21 +3092,19 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) let translate_trait_decl (type_infos : TA.type_infos) (trait_decl : A.trait_decl) : trait_decl = let { - A.def_id; + def_id; name; generics; preds; - all_trait_clauses; consts; types; required_methods; provided_methods; - } = + } : A.trait_decl = trait_decl in let generics = translate_generic_params generics in let preds = translate_predicates preds in - let all_trait_clauses = List.map translate_trait_clause all_trait_clauses in let consts = List.map (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) @@ -3125,7 +3123,6 @@ let translate_trait_decl (type_infos : TA.type_infos) name; generics; preds; - all_trait_clauses; consts; types; required_methods; -- cgit v1.2.3 From 4ba7d73fa3bfbf9ef41b2d9d5595f28fb67b8e47 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 6 Nov 2023 18:11:24 +0100 Subject: Update following some changes in Charon --- compiler/Extract.ml | 37 ++++++++++------------- compiler/ExtractTypes.ml | 75 ++++++++++++++++++++++++---------------------- compiler/Pure.ml | 1 + compiler/SymbolicToPure.ml | 3 ++ 4 files changed, 59 insertions(+), 57 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 574602c7..a73bf0fd 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1808,7 +1808,6 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) (trait_decl : trait_decl) (builtin_info : ExtractBuiltin.builtin_trait_decl_info option) : extraction_ctx = - let generics = trait_decl.generics in (* Compute the clause names *) let clause_names = match builtin_info with @@ -1822,11 +1821,11 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) else ctx.fmt.trait_decl_name trait_decl ^ name in (c.clause_id, name)) - generics.trait_clauses + trait_decl.parent_clauses | Some info -> List.map (fun (c, name) -> (c.clause_id, name)) - (List.combine generics.trait_clauses info.parent_clauses) + (List.combine trait_decl.parent_clauses info.parent_clauses) in (* Register the names *) List.fold_left @@ -2113,12 +2112,15 @@ let extract_trait_impl_item (ctx : extraction_ctx) (fmt : F.formatter) extract_trait_item ctx fmt item_name assign ty (** Small helper - TODO: move *) -let generic_params_drop_prefix (g1 : generic_params) (g2 : generic_params) : - generic_params = +let generic_params_drop_prefix ~(drop_trait_clauses : bool) + (g1 : generic_params) (g2 : generic_params) : generic_params = let open Collections.List in let types = drop (length g1.types) g2.types in let const_generics = drop (length g1.const_generics) g2.const_generics in - let trait_clauses = drop (length g1.trait_clauses) g2.trait_clauses in + let trait_clauses = + if drop_trait_clauses then drop (length g1.trait_clauses) g2.trait_clauses + else g2.trait_clauses + in { types; const_generics; trait_clauses } (** Small helper. @@ -2139,7 +2141,9 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) (* We need to add the generics specific to the method, by removing those which actually apply to the trait decl *) let generics = - generic_params_drop_prefix decl.generics f.signature.generics + let drop_trait_clauses = false in + generic_params_drop_prefix ~drop_trait_clauses decl.generics + f.signature.generics in let ctx, type_params, cg_params, trait_clauses = ctx_add_generic_params generics ctx @@ -2189,8 +2193,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt decl_name; (* Print the generics *) - (* We ignore the trait clauses, which we extract as *fields* *) - let generics = { decl.generics with trait_clauses = [] } in + let generics = decl.generics in (* 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 = @@ -2199,17 +2202,6 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) extract_generic_params ctx fmt TypeDeclId.Set.empty generics type_params cg_params trait_clauses; - (* Add the parent clauses as local clauses, so that we can refer to them *) - let ctx = - List.fold_left - (fun ctx clause -> - let item_name = - ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx - in - ctx_add (LocalTraitClauseId clause.clause_id) item_name ctx) - ctx decl.generics.trait_clauses - in - F.pp_print_space fmt (); (match !backend with | Lean -> F.pp_print_string fmt "where" @@ -2233,7 +2225,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause in extract_trait_decl_item ctx fmt item_name ty) - decl.generics.trait_clauses; + decl.parent_clauses; (* The constants *) List.iter @@ -2330,7 +2322,8 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) are specific to the method, and call it will all the generics (trait impl + method generics) *) let f_generics = - generic_params_drop_prefix + let drop_trait_clauses = true in + generic_params_drop_prefix ~drop_trait_clauses { impl.generics with types = impl_types } f_generics in diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 688ed352..56290ab4 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1239,42 +1239,45 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); extract_rec false ret_ty; if inside then F.pp_print_string fmt ")" - | TraitType (trait_ref, generics, type_name) -> + | TraitType (trait_ref, generics, type_name) -> ( if !parameterize_trait_types then raise (Failure "Unimplemented") - else if trait_ref.trait_id <> Self then ( - (* HOL4 doesn't have 1st class types *) - assert (!backend <> HOL4); - let use_brackets = generics <> empty_generic_args in - if use_brackets then F.pp_print_string fmt "("; - extract_trait_ref ctx fmt no_params_tys false trait_ref; - extract_generic_args ctx fmt no_params_tys generics; - let name = - ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name - ctx - in - if use_brackets then F.pp_print_string fmt ")"; - F.pp_print_string fmt ("." ^ name)) else - (* There are two situations: - - we are extracting a declared item (typically a function signature) - for a trait declaration. We directly refer to the item (we extract - trait declarations as structures, so we can refer to their fields) - - we are extracting a provided method for a trait declaration. We - refer to the item in the self trait clause (see {!SelfTraitClauseId}). - - Remark: we can't get there for trait *implementations* because then the - types should have been normalized. - *) - let trait_decl_id = Option.get ctx.trait_decl_id in - let item_name = ctx_get_trait_type trait_decl_id type_name ctx in - assert (generics = empty_generic_args); - if ctx.is_provided_method then - (* Provided method: use the trait self clause *) - let self_clause = ctx_get_trait_self_clause ctx in - F.pp_print_string fmt (self_clause ^ "." ^ item_name) - else - (* Declaration: directly refer to the item *) - F.pp_print_string fmt item_name + (* There may be a special treatment depending on the instance id *) + match trait_ref.trait_id with + | Self -> + (* There are two situations: + - we are extracting a declared item (typically a function signature) + for a trait declaration. We directly refer to the item (we extract + trait declarations as structures, so we can refer to their fields) + - we are extracting a provided method for a trait declaration. We + refer to the item in the self trait clause (see {!SelfTraitClauseId}). + + Remark: we can't get there for trait *implementations* because then the + types should have been normalized. + *) + let trait_decl_id = Option.get ctx.trait_decl_id in + let item_name = ctx_get_trait_type trait_decl_id type_name ctx in + assert (generics = empty_generic_args); + if ctx.is_provided_method then + (* Provided method: use the trait self clause *) + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt (self_clause ^ "." ^ item_name) + else + (* Declaration: directly refer to the item *) + F.pp_print_string fmt item_name + | _ -> + (* HOL4 doesn't have 1st class types *) + assert (!backend <> HOL4); + let use_brackets = generics <> empty_generic_args in + if use_brackets then F.pp_print_string fmt "("; + extract_trait_ref ctx fmt no_params_tys false trait_ref; + extract_generic_args ctx fmt no_params_tys generics; + let name = + ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id + type_name ctx + in + if use_brackets then F.pp_print_string fmt ")"; + F.pp_print_string fmt ("." ^ name)) and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = @@ -1342,7 +1345,9 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) | Self -> (* This has specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) - raise (Failure "Unexpected") + if !Config.extract_fail_hard then + raise (Failure "Unexpected occurrence of `Self`") + else F.pp_print_string fmt "ERROR(\"Unexpected Self\")" | TraitImpl id -> let name = ctx_get_trait_impl id ctx in F.pp_print_string fmt name diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 70653e57..c33a745c 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -1013,6 +1013,7 @@ type trait_decl = { name : name; generics : generic_params; preds : predicates; + parent_clauses : trait_clause list; 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; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index c629a96f..46aa3b83 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -3096,6 +3096,7 @@ let translate_trait_decl (type_infos : TA.type_infos) name; generics; preds; + parent_clauses; consts; types; required_methods; @@ -3105,6 +3106,7 @@ let translate_trait_decl (type_infos : TA.type_infos) in let generics = translate_generic_params generics in let preds = translate_predicates preds in + let parent_clauses = List.map translate_trait_clause parent_clauses in let consts = List.map (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) @@ -3123,6 +3125,7 @@ let translate_trait_decl (type_infos : TA.type_infos) name; generics; preds; + parent_clauses; consts; types; required_methods; -- cgit v1.2.3 From 16c094457d0b23f5a9e1ea60e3195cc452ed7c43 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 6 Nov 2023 18:47:38 +0100 Subject: Fix some issues when extracting references to Self --- compiler/ExtractTypes.ml | 87 +++++++++++++++++++++++++++++++----------------- 1 file changed, 57 insertions(+), 30 deletions(-) (limited to 'compiler') diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 56290ab4..f4be9006 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1242,29 +1242,24 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) | TraitType (trait_ref, generics, type_name) -> ( if !parameterize_trait_types then raise (Failure "Unimplemented") else - (* There may be a special treatment depending on the instance id *) + let type_name = + ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name + ctx + in + (* There may be a special treatment depending on the instance id. + See the comments for {!extract_trait_instance_id_with_dot}. + TODO: there should be a cleaner way to do. The annoying thing + here is that if we project directly over the self clause, then + we have to be careful (we may not have to print the "Self."). + Otherwise, we can directly call {!extract_trait_ref}. + *) match trait_ref.trait_id with | Self -> - (* There are two situations: - - we are extracting a declared item (typically a function signature) - for a trait declaration. We directly refer to the item (we extract - trait declarations as structures, so we can refer to their fields) - - we are extracting a provided method for a trait declaration. We - refer to the item in the self trait clause (see {!SelfTraitClauseId}). - - Remark: we can't get there for trait *implementations* because then the - types should have been normalized. - *) - let trait_decl_id = Option.get ctx.trait_decl_id in - let item_name = ctx_get_trait_type trait_decl_id type_name ctx in assert (generics = empty_generic_args); - if ctx.is_provided_method then - (* Provided method: use the trait self clause *) - let self_clause = ctx_get_trait_self_clause ctx in - F.pp_print_string fmt (self_clause ^ "." ^ item_name) - else - (* Declaration: directly refer to the item *) - F.pp_print_string fmt item_name + assert (trait_ref.generics = empty_generic_args); + extract_trait_instance_id_with_dot ctx fmt no_params_tys false + trait_ref.trait_id; + F.pp_print_string fmt type_name | _ -> (* HOL4 doesn't have 1st class types *) assert (!backend <> HOL4); @@ -1272,12 +1267,8 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) if use_brackets then F.pp_print_string fmt "("; extract_trait_ref ctx fmt no_params_tys false trait_ref; extract_generic_args ctx fmt no_params_tys generics; - let name = - ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id - type_name ctx - in if use_brackets then F.pp_print_string fmt ")"; - F.pp_print_string fmt ("." ^ name)) + F.pp_print_string fmt ("." ^ type_name)) and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = @@ -1338,12 +1329,48 @@ and extract_generic_args (ctx : extraction_ctx) (fmt : F.formatter) (extract_trait_ref ctx fmt no_params_tys true) trait_refs) +(** We sometimes need to ignore references to `Self` when generating the + code, espcially when we project associated items. For this reason we + have a special function for the cases where we project from an instance + id (e.g., `::foo` - note that in the extracted code, the + projections are often written with a dot '.'). + *) +and extract_trait_instance_id_with_dot (ctx : extraction_ctx) + (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) + (id : trait_instance_id) : unit = + match id with + | Self -> + (* There are two situations: + - we are extracting a declared item and need to refer to another + item (for instance, we are extracting a method signature and + need to refer to an associated type). + We directly refer to the other item (we extract trait declarations + as structures, so we can refer to their fields) + - we are extracting a provided method for a trait declaration. We + refer to the item in the self trait clause (see {!SelfTraitClauseId}). + + Remark: we can't get there for trait *implementations* because then the + types should have been normalized. + *) + if ctx.is_provided_method then + (* Provided method: use the trait self clause *) + let self_clause = ctx_get_trait_self_clause ctx in + F.pp_print_string fmt (self_clause ^ ".") + else + (* Declaration: nothing to print, we will directly refer to + the item. *) + () + | _ -> + (* Other cases *) + extract_trait_instance_id ctx fmt no_params_tys inside id; + F.pp_print_string fmt "." + and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (id : trait_instance_id) : unit = match id with | Self -> - (* This has specific treatment depending on the item we're extracting + (* This has a specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) if !Config.extract_fail_hard then raise (Failure "Unexpected occurrence of `Self`") @@ -1357,13 +1384,13 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) | ParentClause (inst_id, decl_id, clause_id) -> (* Use the trait decl id to lookup the name *) let name = ctx_get_trait_parent_clause decl_id clause_id ctx in - extract_trait_instance_id ctx fmt no_params_tys true inst_id; - F.pp_print_string fmt ("." ^ name) + extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt 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 decl_id item_name clause_id ctx in - extract_trait_instance_id ctx fmt no_params_tys true inst_id; - F.pp_print_string fmt ("." ^ name) + extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; + F.pp_print_string fmt name | TraitRef trait_ref -> extract_trait_ref ctx fmt no_params_tys inside trait_ref | UnknownTrait _ -> -- cgit v1.2.3 From bcc3f4ae99ba5ff78d03c51c825659e1b67bb0b0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 6 Nov 2023 18:52:41 +0100 Subject: Fix a naming issue --- compiler/ExtractTypes.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index f4be9006..7bd02381 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -700,7 +700,9 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) with the trait decl name *) let trait_decl = let name = trait_decl.name in - get_type_name_no_suffix name ^ "Inst" + let name = get_type_name_no_suffix name ^ "Inst" in + (* Remove the occurrences of '.' *) + String.concat "" (String.split_on_char '.' name) in flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in -- cgit v1.2.3 From ed788eec1d8be1656c0ad7dab25975ad3f5497c2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 7 Nov 2023 10:40:27 +0100 Subject: Update the normalization of associated types --- compiler/AssociatedTypes.ml | 169 +++++++++++++++++++++++++++++++------------- compiler/Pure.ml | 1 + compiler/Substitute.ml | 3 + compiler/SymbolicToPure.ml | 3 + 4 files changed, 126 insertions(+), 50 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 94e08996..e4015903 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -168,8 +168,8 @@ let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = type 'r norm_ctx = { ctx : C.eval_ctx; get_ty_repr : 'r C.trait_type_ref -> 'r T.ty option; - convert_ety : T.ety -> 'r T.ty; - convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; + convert_ety : T.ety -> 'r T.ty; (* TODO: remove? *) + convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; (* TODO: remove? *) ty_to_string : 'r T.ty -> string; generic_params_to_string : T.generic_params -> string; generic_args_to_string : 'r T.generic_args -> string; @@ -178,9 +178,100 @@ type 'r norm_ctx = { pp_r : Format.formatter -> 'r -> unit; } -(** Normalize a type by simplyfying the references to trait associated types +(** Small utility to lookup trait impls, together with a substitution. + + Remark: one reason we have those small helpers is that all functions are + parameterized by a type variable 'r. The OCaml type inferencer and type + checker are however not very good at generating precise error messages in + this context: if in the body of the function we have an overly constrained + usage of 'r (for instance, the type inferencer deduces 'r should be + [T.erased_region]), it will not be able to pinpoint the location which + introduced the constraints and we just get a type-checking error for the + whole function. The fact that we have mutually recursive functions makes it + worse (the type-checker sometimes indicates a well-typed function as not + well-typed, because it calls a not well-typed function...). + By isolating the places where such errors typically happen in small helpers + (i.e., the places where we convert between different types of regions by + performing substitutions), we make maintenance a lot easier. + *) +let ctx_lookup_trait_impl : + 'r. + 'r norm_ctx -> + T.TraitImplId.id -> + 'r T.generic_args -> + A.trait_impl * (T.region_var_id T.region, 'r) Subst.subst = + fun ctx impl_id generics -> + (* Lookup the implementation *) + let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in + (* The substitution *) + let tr_self = T.UnknownTrait __FUNCTION__ in + let subst = + Subst.make_subst_from_generics_no_regions trait_impl.generics generics + tr_self + in + (* Return *) + (trait_impl, subst) + +let ctx_lookup_trait_impl_ty : + 'r. + 'r norm_ctx -> T.TraitImplId.id -> 'r T.generic_args -> string -> 'r T.ty + = + fun ctx impl_id generics type_name -> + (* Lookup the implementation *) + let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + (* Lookup the type *) + let ty = snd (List.assoc type_name trait_impl.types) in + (* Annoying: convert etype to an stype - TODO: how to avoid that? *) + let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in + (* Substitute *) + Subst.ty_substitute subst ty + +let ctx_lookup_trait_impl_parent_clause : + 'r. + 'r norm_ctx -> + T.TraitImplId.id -> + 'r T.generic_args -> + T.TraitClauseId.id -> + 'r T.trait_ref = + fun ctx impl_id generics clause_id -> + (* Lookup the implementation *) + let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + (* Lookup the clause *) + let clause = T.TraitClauseId.nth trait_impl.parent_trait_refs clause_id in + (* Sanity check: the clause necessarily refers to an impl *) + let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (* Substitute *) + Subst.trait_ref_substitute subst clause + +let ctx_lookup_trait_impl_item_clause : + 'r. + 'r norm_ctx -> + T.TraitImplId.id -> + 'r T.generic_args -> + string -> + T.TraitClauseId.id -> + 'r T.trait_ref = + fun ctx impl_id generics item_name clause_id -> + (* Lookup the implementation *) + let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + (* Lookup the item then its clause *) + let item = List.assoc item_name trait_impl.types in + let clause = T.TraitClauseId.nth (fst item) clause_id in + (* Sanity check: the clause necessarily refers to an impl *) + let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (* Annoying: convert etype to an stype - TODO: how to avoid that? *) + let clause : T.strait_ref = + TypesUtils.etrait_ref_no_regions_to_gr_trait_ref clause + in + (* Substitute *) + Subst.trait_ref_substitute subst clause + +(** Normalize a type by simplifying the references to trait associated types and choosing a representative when there are equalities between types - enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. *) + enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. + + See the comments for {!ctx_normalize_trait_instance_id}. + *) let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = fun ctx ty -> log#ldebug (lazy ("ctx_normalize_ty: " ^ ctx.ty_to_string ty)); @@ -221,21 +312,10 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = (lazy ("ctx_normalize_ty: trait type: trait ref: " ^ ctx.ty_to_string ty)); - (* Lookup the implementation *) - let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* Lookup the type *) - let ty = snd (List.assoc type_name trait_impl.types) in - (* Annoying: convert etype to an stype - TODO: how to avoid that? *) - let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in - (* Substitute *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let subst = - Subst.make_subst_from_generics_no_regions trait_impl.generics - trait_ref.generics tr_self + let ty = + ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name in - let ty = Subst.ty_substitute subst ty in - (* Reconvert *) - let ty : 'r T.ty = ctx.convert_ety (Subst.erase_regions ty) in (* Normalize *) ctx_normalize_ty ctx ty | T.TraitImpl impl_id -> @@ -252,21 +332,10 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = the Rustc AST. TODO: factor out with the branch above. *) - (* Lookup the implementation *) - let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* Lookup the type *) - let ty = snd (List.assoc type_name trait_impl.types) in - (* Annoying: convert etype to an stype - TODO: how to avoid that? *) - let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in - (* Substitute *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let subst = - Subst.make_subst_from_generics_no_regions trait_impl.generics - trait_ref.generics tr_self + let ty = + ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name in - let ty = Subst.ty_substitute subst ty in - (* Reconvert *) - let ty : 'r T.ty = ctx.convert_ety (Subst.erase_regions ty) in (* Normalize *) ctx_normalize_ty ctx ty | _ -> @@ -286,7 +355,8 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = match ctx.get_ty_repr tr with None -> ty | Some ty -> ty) (** This returns the normalized trait instance id together with an optional - reference to a trait **implementation**. + reference to a trait **implementation** (the `trait_ref` we return has + necessarily for instance id a [TraitImpl]). We need this in particular to simplify the trait instance ids after we performed a substitution. @@ -305,7 +375,10 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = fn f(...) -> T::S; ... - let x = f[TraitImpl](...); // T::S ~~> TraitImpl::S ~~> usize + let x = f[TraitImpl](...); + (* The return type of the call to f is: + T::S ~~> TraitImpl::S ~~> usize + *) ]} Several remarks: @@ -359,17 +432,17 @@ and ctx_normalize_trait_instance_id : ^^^^^^^^^^^^^^^^^^^^^^^^^^^ those are the parent clauses ]} - - We can find the parent clauses in the [trait_decl_ref] field, which - tells us which specific instantiation of [Trait1] is implemented - by [Impl1]. *) + (* Lookup the clause *) + let impl_id = + TypesUtils.trait_instance_id_as_trait_impl impl.trait_id + in let clause = - T.TraitClauseId.nth impl.trait_decl_ref.decl_generics.trait_refs + ctx_lookup_trait_impl_parent_clause ctx impl_id impl.generics clause_id in - (* Sanity check: the clause necessarily refers to an impl *) - let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in + (* Normalize the clause *) + let clause = ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) | ItemClause (inst_id, decl_id, item_name, clause_id) -> ( let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in @@ -391,20 +464,16 @@ and ctx_normalize_trait_instance_id : } ]} *) - (* The referenced instance should be an impl *) + (* Lookup the impl *) let impl_id = TypesUtils.trait_instance_id_as_trait_impl impl.trait_id in - let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in - (* Lookup the clause *) - let item = List.assoc item_name trait_impl.types in - let clause = T.TraitClauseId.nth (fst item) clause_id in - (* Sanity check: the clause necessarily refers to an impl *) - let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in - (* We need to convert the clause type - - TODO: we have too many problems with those conversions, we should - merge the types. *) - let clause = ctx.convert_etrait_ref clause in + let clause = + ctx_lookup_trait_impl_item_clause ctx impl_id impl.generics + item_name clause_id + in + (* Normalize the clause *) + let clause = ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) | TraitRef { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } -> (* We can't simplify the id *yet* : we will simplify it when projecting. diff --git a/compiler/Pure.ml b/compiler/Pure.ml index c33a745c..e6a3dab5 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -1027,6 +1027,7 @@ type trait_impl = { impl_trait : trait_decl_ref; generics : generic_params; preds : predicates; + parent_trait_refs : trait_ref list; consts : (trait_item_name * (ty * global_decl_id)) list; types : (trait_item_name * (trait_ref list * ty)) list; required_methods : (trait_item_name * fun_decl_id) list; diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 6d9b9e15..23f618e2 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -71,6 +71,9 @@ let erase_regions_subst : ('r, T.erased_region) subst = (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) let erase_regions (ty : 'r T.ty) : T.ety = ty_substitute erase_regions_subst ty +let trait_ref_erase_regions (tr : 'r T.trait_ref) : T.etrait_ref = + trait_ref_substitute erase_regions_subst tr + (** Generate fresh regions for region variables. Return the list of new regions and appropriate substitutions from the diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 46aa3b83..2ce8c706 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -3140,6 +3140,7 @@ let translate_trait_impl (type_infos : TA.type_infos) impl_trait; generics; preds; + parent_trait_refs; consts; types; required_methods; @@ -3152,6 +3153,7 @@ let translate_trait_impl (type_infos : TA.type_infos) in let generics = translate_generic_params generics in let preds = translate_predicates preds in + let parent_trait_refs = List.map translate_strait_ref parent_trait_refs in let consts = List.map (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) @@ -3171,6 +3173,7 @@ let translate_trait_impl (type_infos : TA.type_infos) impl_trait; generics; preds; + parent_trait_refs; consts; types; required_methods; -- cgit v1.2.3 From a745e81c9949f24878f788fffd36667739c59330 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 7 Nov 2023 10:44:58 +0100 Subject: Update the extraction --- compiler/Extract.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index a73bf0fd..8ad8a18d 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2416,7 +2416,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) * Extract the items *) - (* The parent clauses - we retrieve those from the impl_ref *) + (* The parent clauses *) let trait_decl_id = impl.impl_trait.trait_decl_id in TraitClauseId.iteri (fun clause_id trait_ref -> @@ -2426,7 +2426,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref in extract_trait_impl_item ctx fmt item_name ty) - impl.impl_trait.decl_generics.trait_refs; + impl.parent_trait_refs; (* The constants *) List.iter -- cgit v1.2.3 From 9df1d191cfaf929b755e9d26d55811531acd939d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 11:21:53 +0100 Subject: Fix a small issue in AssociatedTypes --- compiler/AssociatedTypes.ml | 2 +- compiler/Config.ml | 6 +++--- compiler/Driver.ml | 8 +++++++- compiler/Extract.ml | 4 ++-- compiler/ExtractBase.ml | 12 ++++++------ compiler/ExtractTypes.ml | 2 +- compiler/Logging.ml | 2 +- 7 files changed, 21 insertions(+), 15 deletions(-) (limited to 'compiler') diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index e4015903..581e218c 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -451,7 +451,7 @@ and ctx_normalize_trait_instance_id : | None -> (* This is actually a local clause *) assert (trait_instance_id_is_local_clause inst_id); - (ParentClause (inst_id, decl_id, clause_id), None) + (ItemClause (inst_id, decl_id, item_name, clause_id), None) | Some impl -> (* We figure out the item clause by doing the following: {[ diff --git a/compiler/Config.ml b/compiler/Config.ml index cd0903b6..8483c879 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -333,6 +333,6 @@ let parameterize_trait_types = ref false *) let type_check_pure_code = ref false -(** Shall we fail hard if there is an issue at code-generation time? - We may not want in case outputting a code with holes helps debugging *) -let extract_fail_hard = ref false +(** Shall we fail hard if we encounter an issue, or should we attempt to go + as far as possible while leaving "holes" in the generated code? *) +let fail_hard = ref true diff --git a/compiler/Driver.ml b/compiler/Driver.ml index b660b5a5..14668632 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -41,7 +41,7 @@ let _ = pure_utils_log#set_level EL.Info; symbolic_to_pure_log#set_level EL.Info; pure_micro_passes_log#set_level EL.Info; - pure_to_extract_log#set_level EL.Info; + extract_log#set_level EL.Info; translate_log#set_level EL.Info; scc_log#set_level EL.Info; reorder_decls_log#set_level EL.Info @@ -66,6 +66,9 @@ let () = (* Read the command line arguments *) let dest_dir = ref "" in + (* Print the imported llbc *) + let print_llbc = ref false in + let spec = [ ( "-backend", @@ -118,6 +121,8 @@ let () = ( "-lean-default-lakefile", Arg.Clear lean_gen_lakefile, " Generate a default lakefile.lean (Lean only)" ); + ("-print-llbc", Arg.Set print_llbc, " Print the imported LLBC"); + ("-k", Arg.Clear fail_hard, " Do not fail hard in case of error"); ] in @@ -131,6 +136,7 @@ let () = in if !extract_template_decreases_clauses then extract_decreases_clauses := true; + if !print_llbc then main_log#set_level EL.Debug; (* Sanity check (now that the arguments are parsed!): -template-clauses ==> decrease-clauses *) assert (!extract_decreases_clauses || not !extract_template_decreases_clauses); diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 8ad8a18d..b8cb38bb 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -472,7 +472,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) | Error (types, err) -> extract_generic_args ctx fmt TypeDeclId.Set.empty { generics with types }; - if !Config.extract_fail_hard then raise (Failure err) + if !Config.fail_hard then raise (Failure err) else F.pp_print_string fmt "(\"ERROR: ill-formed builtin: invalid number of filtering \ @@ -1992,7 +1992,7 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) trans_fun.back_id in log#serror err; - if !Config.extract_fail_hard then raise (Failure err) + if !Config.fail_hard then raise (Failure err) else (trans_fun.back_id, "%ERROR_BUILTIN_NAME_NOT_FOUND%") in let rg_with_name_list = List.map find trans_funs in diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 8ddb2ec6..55b1bca3 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -8,7 +8,7 @@ module F = Format open ExtractBuiltin (** The local logger *) -let log = L.pure_to_extract_log +let log = L.extract_log type region_group_info = { id : RegionGroupId.id; @@ -488,7 +488,7 @@ let report_name_collision (id_to_string : id -> string) (id1 : id) (id2 : id) in log#serror err; (* If we fail hard on errors, raise an exception *) - if !Config.extract_fail_hard then raise (Failure err) + if !Config.fail_hard then raise (Failure err) let names_map_get_id_from_name (name : string) (nm : names_map) : id option = StringMap.find_opt name nm.name_to_id @@ -522,7 +522,7 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) in log#serror err; (* If we fail hard on errors, raise an exception *) - if !Config.extract_fail_hard then raise (Failure err)); + if !Config.fail_hard then raise (Failure err)); (* Insert *) names_map_add_unchecked id name nm @@ -691,7 +691,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | FunId (Assumed aid) -> A.show_assumed_fun_id aid | TraitMethod (trait_ref, method_name, _) -> (* Shouldn't happen *) - if !Config.extract_fail_hard then raise (Failure "Unexpected") + if !Config.fail_hard then raise (Failure "Unexpected") else "Trait method: decl: " ^ TraitDeclId.to_string trait_ref.trait_decl_ref.trait_decl_id @@ -903,7 +903,7 @@ let names_maps_get (id_to_string : id -> string) (id : id) (nm : names_maps) : ^ map_to_string m in log#serror err; - if !Config.extract_fail_hard then raise (Failure err) + if !Config.fail_hard then raise (Failure err) else "(%%%ERROR: unknown identifier\": " ^ id_to_string id ^ "\"%%%)") else let m = nm.names_map.id_to_name in @@ -915,7 +915,7 @@ let names_maps_get (id_to_string : id -> string) (id : id) (nm : names_maps) : ^ map_to_string m in log#serror err; - if !Config.extract_fail_hard then raise (Failure err) + if !Config.fail_hard then raise (Failure err) else "(ERROR: \"" ^ id_to_string id ^ "\")" let ctx_get (id : id) (ctx : extraction_ctx) : string = diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 7bd02381..699a0e96 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1374,7 +1374,7 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) | Self -> (* This has a specific treatment depending on the item we're extracting (associated type, etc.). We should have caught this elsewhere. *) - if !Config.extract_fail_hard then + if !Config.fail_hard then raise (Failure "Unexpected occurrence of `Self`") else F.pp_print_string fmt "ERROR(\"Unexpected Self\")" | TraitImpl id -> diff --git a/compiler/Logging.ml b/compiler/Logging.ml index 59abbfc7..721655b8 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -22,7 +22,7 @@ let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure" let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" (** Logger for ExtractBase *) -let pure_to_extract_log = L.get_logger "MainLogger.ExtractBase" +let extract_log = L.get_logger "MainLogger.ExtractBase" (** Logger for Interpreter *) let interpreter_log = L.get_logger "MainLogger.Interpreter" -- cgit v1.2.3 From c57dec640d4e12c3dc66969d626bbbca2eb733fd Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 11:43:47 +0100 Subject: Modify some options and update the Makefile --- compiler/Config.ml | 4 ++-- compiler/Driver.ml | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) (limited to 'compiler') diff --git a/compiler/Config.ml b/compiler/Config.ml index 8483c879..a487f9e2 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -124,7 +124,7 @@ let always_deconstruct_adts_with_matches = ref false (** Controls whether we need to use a state to model the external world (I/O, for instance). *) -let use_state = ref true +let use_state = ref false (** Controls whether we use fuel to control termination. *) @@ -160,7 +160,7 @@ let backward_no_state_update = ref false files for the types, clauses and functions, or if we group them in one file. *) -let split_files = ref true +let split_files = ref false (** Generate the library entry point, if the crate is split between different files. diff --git a/compiler/Driver.ml b/compiler/Driver.ml index 14668632..128ae890 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -93,9 +93,9 @@ let () = Arg.Set extract_decreases_clauses, " Use decreases clauses/termination measures for the recursive \ definitions" ); - ( "-no-state", - Arg.Clear use_state, - " Do not use state-error monads, simply use error monads" ); + ( "-state", + Arg.Set use_state, + " Use a *state*-error monads, instead of an error monads" ); ( "-use-fuel", Arg.Set use_fuel, " Use a fuel parameter to control divergence" ); @@ -106,10 +106,10 @@ let () = Arg.Set extract_template_decreases_clauses, " Generate templates for the required decreases clauses/termination \ measures, in a dedicated file. Implies -decreases-clauses" ); - ( "-no-split-files", - Arg.Clear split_files, - " Do not split the definitions between different files for types, \ - functions, etc." ); + ( "-split-files", + Arg.Set split_files, + " Split the definitions between different files for types, functions, \ + etc." ); ( "-no-check-inv", Arg.Clear check_invariants, " Deactivate the invariant sanity checks performed at every evaluation \ -- cgit v1.2.3 From 9254f5aeadfc9d17f31e13c61a7843364220c4ed Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 12:33:14 +0100 Subject: Progress on making the traits work for F* --- compiler/Extract.ml | 38 +++++++++++++++++------ compiler/ExtractTypes.ml | 78 +++++++++++++++++++++++++++++++----------------- compiler/PureUtils.ml | 35 ++++++++++++++++++++++ 3 files changed, 115 insertions(+), 36 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index b8cb38bb..0805ed96 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2148,10 +2148,16 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) let ctx, type_params, cg_params, trait_clauses = ctx_add_generic_params generics ctx in - let use_forall = generics <> empty_generic_params in + let backend_uses_forall = + match !backend with Coq | Lean -> true | FStar | HOL4 -> false + in + let generics_not_empty = generics <> empty_generic_params in + let use_forall = generics_not_empty && backend_uses_forall in + let use_arrows = generics_not_empty && not backend_uses_forall in let use_forall_use_sep = false in extract_generic_params ctx fmt TypeDeclId.Set.empty ~use_forall - ~use_forall_use_sep generics type_params cg_params trait_clauses; + ~use_forall_use_sep ~use_arrows generics type_params cg_params + trait_clauses; if use_forall then F.pp_print_string fmt ","; (* Extract the inputs and output *) F.pp_print_space fmt (); @@ -2189,6 +2195,12 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) let qualif = Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec (Some Struct)) in + (* When checking if the trait declaration is empty: we ignore the provided + methods, because for now they are extracted separately *) + let is_empty = trait_decl_is_empty { decl with provided_methods = [] } in + if !backend = FStar && not is_empty then ( + F.pp_print_string fmt "noeq"; + F.pp_print_space fmt ()); F.pp_print_string fmt qualif; F.pp_print_space fmt (); F.pp_print_string fmt decl_name; @@ -2205,7 +2217,9 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); (match !backend with | Lean -> F.pp_print_string fmt "where" + | FStar -> if not is_empty then F.pp_print_string fmt "= {" | _ -> F.pp_print_string fmt "{"); + if !backend = FStar && is_empty then F.pp_print_string fmt "= unit"; (* Close the box for the name + generics *) F.pp_close_box fmt (); @@ -2268,15 +2282,15 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (fun (name, id) -> extract_trait_decl_method_items ctx fmt decl name id) decl.required_methods; + (* Close the outer boxes for the definition *) + if !Config.backend <> Lean then F.pp_close_box fmt (); (* Close the brackets *) (match !Config.backend with | Lean -> () | _ -> - F.pp_print_space fmt (); - F.pp_print_string fmt "}"); - - (* Close the outer boxes for the definition *) - if !Config.backend <> Lean then F.pp_close_box fmt (); + if (not (!backend = FStar)) || not is_empty then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "}")); F.pp_close_box fmt (); (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 @@ -2405,8 +2419,13 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); extract_trait_decl_ref 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 *) + let is_empty = trait_impl_is_empty { impl with provided_methods = [] } in + F.pp_print_space fmt (); if !Config.backend = Lean then F.pp_print_string fmt ":= {" + else if !Config.backend = FStar && is_empty then F.pp_print_string fmt "= ()" else F.pp_print_string fmt "= {"; (* Close the box for the name + generics *) @@ -2472,8 +2491,9 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* Close the outer boxes for the definition, as well as the brackets *) F.pp_close_box fmt (); - F.pp_print_space fmt (); - F.pp_print_string fmt "}"; + if (not (!backend = FStar)) || not is_empty then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "}"); F.pp_close_box fmt (); (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 699a0e96..a294d4ca 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -608,19 +608,6 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Lean -> String.concat "." name in let get_type_name = get_name in - let type_name_to_camel_case name = - let name = get_type_name name in - let name = List.map to_camel_case name in - String.concat "" name - in - let type_name_to_snake_case name = - let name = get_type_name name in - let name = List.map to_snake_case name in - let name = String.concat "_" name in - match !backend with - | FStar | Lean | HOL4 -> name - | Coq -> capitalize_first_letter name - in let get_type_name_no_suffix name = match !backend with | FStar | Coq | HOL4 -> String.concat "_" (get_type_name name) @@ -704,7 +691,10 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) (* Remove the occurrences of '.' *) String.concat "" (String.split_on_char '.' name) in - flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) + let name = flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in + match !backend with + | FStar -> StringUtils.lowercase_first_letter name + | Coq | HOL4 | Lean -> name in let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) @@ -715,12 +705,28 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) else trait_decl_name trait_decl ^ "_" ^ clause in let trait_type_name (trait_decl : trait_decl) (item : string) : string = - if !Config.record_fields_short_names then item - else trait_decl_name trait_decl ^ "_" ^ item + let name = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + (* Constants are usually all capital letters. + Some backends do not support field names starting with a capital letter, + and it may be weird to lowercase everything (especially as it may lead + to more name collisions): we add a prefix when necessary. + For instance, it gives: "U" -> "tU" + Note that for some backends we prepend the type name (because those backends + can't disambiguate fields coming from different ADTs if they have the same + names), and thus don't need to add a prefix starting with a lowercase. + *) + match !backend with FStar -> "t" ^ name | Coq | Lean | HOL4 -> name in let trait_const_name (trait_decl : trait_decl) (item : string) : string = - if !Config.record_fields_short_names then item - else trait_decl_name trait_decl ^ "_" ^ item + let name = + if !Config.record_fields_short_names then item + else trait_decl_name trait_decl ^ "_" ^ item + in + (* See [trait_type_name] *) + match !backend with FStar -> "c" ^ name | Coq | Lean | HOL4 -> name in let trait_method_name (trait_decl : trait_decl) (item : string) : string = if !Config.record_fields_short_names then item @@ -1832,18 +1838,24 @@ let extract_trait_self_clause (insert_req_space : unit -> unit) *) let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) ?(use_forall = false) - ?(use_forall_use_sep = true) ?(as_implicits : bool = false) - ?(space : bool ref option = None) ?(trait_decl : trait_decl option = None) - (generics : generic_params) (type_params : string list) - (cg_params : string list) (trait_clauses : string list) : unit = + ?(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) + (type_params : string list) (cg_params : string list) + (trait_clauses : string list) : unit = let all_params = List.concat [ type_params; cg_params; trait_clauses ] in (* HOL4 doesn't support const generics *) assert (cg_params = [] || !backend <> HOL4); let left_bracket (implicit : bool) = - if implicit then F.pp_print_string fmt "{" else F.pp_print_string fmt "(" + if implicit && !backend <> FStar then F.pp_print_string fmt "{" + else F.pp_print_string fmt "(" in let right_bracket (implicit : bool) = - if implicit then F.pp_print_string fmt "}" else F.pp_print_string fmt ")" + if implicit && !backend <> FStar then F.pp_print_string fmt "}" + else F.pp_print_string fmt ")" + in + let print_implicit_symbol (implicit : bool) = + if implicit && !backend = FStar then F.pp_print_string fmt "#" else () in let insert_req_space () = match space with @@ -1871,6 +1883,7 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) left_bracket as_implicits; List.iter (fun s -> + print_implicit_symbol as_implicits; F.pp_print_string fmt s; F.pp_print_space fmt ()) type_params; @@ -1878,7 +1891,10 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt (type_keyword ()); (* ) *) - right_bracket as_implicits); + right_bracket as_implicits; + if use_arrows then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "->")); (* Print the const generic parameters *) List.iter (fun (var : const_generic_var) -> @@ -1886,13 +1902,17 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) (* ( *) left_bracket as_implicits; let n = ctx_get_const_generic_var var.index ctx in + print_implicit_symbol as_implicits; F.pp_print_string fmt n; F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); extract_literal_type ctx fmt var.ty; (* ) *) - right_bracket as_implicits) + right_bracket as_implicits; + if use_arrows then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "->")) const_generics); (* Print the trait clauses *) List.iter @@ -1901,13 +1921,17 @@ let extract_generic_params (ctx : extraction_ctx) (fmt : F.formatter) (* ( *) left_bracket as_implicits; let n = ctx_get_local_trait_clause clause.clause_id ctx in + print_implicit_symbol as_implicits; F.pp_print_string fmt n; F.pp_print_space fmt (); F.pp_print_string fmt ":"; F.pp_print_space fmt (); extract_trait_clause_type ctx fmt no_params_tys clause; (* ) *) - right_bracket as_implicits) + right_bracket as_implicits; + if use_arrows then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "->")) trait_clauses in (* If we extract the generics for a provided method for a trait declaration diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 4e44f252..3aeabffe 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -642,3 +642,38 @@ let trait_decl_get_method (trait_decl : trait_decl) (method_name : string) : List.find (fun (s, _) -> s = method_name) trait_decl.provided_methods in { is_provided = true; id = Option.get id } + +let trait_decl_is_empty (trait_decl : trait_decl) : bool = + let { + def_id = _; + name = _; + generics = _; + preds = _; + parent_clauses; + consts; + types; + required_methods; + provided_methods; + } = + trait_decl + in + parent_clauses = [] && consts = [] && types = [] && required_methods = [] + && provided_methods = [] + +let trait_impl_is_empty (trait_impl : trait_impl) : bool = + let { + def_id = _; + name = _; + impl_trait = _; + generics = _; + preds = _; + parent_trait_refs; + consts; + types; + required_methods; + provided_methods; + } = + trait_impl + in + parent_trait_refs = [] && consts = [] && types = [] && required_methods = [] + && provided_methods = [] -- cgit v1.2.3 From 2438e99c6d5a368da59dfa77a400246a8bc55d39 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 13:43:41 +0100 Subject: Extract the trait parent clauses after the types and the constants --- compiler/Extract.ml | 49 +++++++++++++++++++++++++------------------------ 1 file changed, 25 insertions(+), 24 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 0805ed96..e22f1385 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2228,19 +2228,6 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) * Extract the items *) - (* The parent clauses *) - List.iter - (fun clause -> - let item_name = - ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx - in - let ty () = - F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause - in - extract_trait_decl_item ctx fmt item_name ty) - decl.parent_clauses; - (* The constants *) List.iter (fun (name, (ty, _)) -> @@ -2277,6 +2264,20 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) clauses) decl.types; + (* The parent clauses - note that the parent clauses may refer to the types + and const generics: for this reason we extract them *after* *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + decl.parent_clauses; + (* The required methods *) List.iter (fun (name, id) -> extract_trait_decl_method_items ctx fmt decl name id) @@ -2434,18 +2435,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* * Extract the items *) - - (* The parent clauses *) let trait_decl_id = impl.impl_trait.trait_decl_id in - TraitClauseId.iteri - (fun clause_id trait_ref -> - let item_name = ctx_get_trait_parent_clause trait_decl_id clause_id ctx in - let ty () = - F.pp_print_space fmt (); - extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref - in - extract_trait_impl_item ctx fmt item_name ty) - impl.parent_trait_refs; (* The constants *) List.iter @@ -2483,6 +2473,17 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) trait_refs) impl.types; + (* The parent clauses *) + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = ctx_get_trait_parent_clause trait_decl_id clause_id ctx in + let ty () = + F.pp_print_space fmt (); + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + impl.parent_trait_refs; + (* The required methods *) List.iter (fun (name, id) -> -- cgit v1.2.3 From 3a22c56e026ee4488bc5e2d16d2066853ae7ccb9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 16:22:09 +0100 Subject: Make the traits work for Coq --- compiler/Extract.ml | 391 +++++++++++++++++++++++++++++---------------- compiler/ExtractBase.ml | 8 + compiler/ExtractBuiltin.ml | 12 +- compiler/ExtractTypes.ml | 106 +++++++----- compiler/FunsAnalysis.ml | 7 +- compiler/Translate.ml | 22 ++- 6 files changed, 353 insertions(+), 193 deletions(-) (limited to 'compiler') diff --git a/compiler/Extract.ml b/compiler/Extract.ml index e22f1385..d04f5c1d 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -320,8 +320,11 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) ctx_get_trait_const trait_ref.trait_decl_ref.trait_decl_id const_name ctx in + let add_brackets (s : string) = + if !backend = Coq then "(" ^ s ^ ")" else s + in if use_brackets then F.pp_print_string fmt ")"; - F.pp_print_string fmt ("." ^ name)) + F.pp_print_string fmt ("." ^ add_brackets name)) | _ -> (* "Regular" expression *) (* Open parentheses *) @@ -430,7 +433,10 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) ctx_get_trait_method trait_ref.trait_decl_ref.trait_decl_id method_name rg_id ctx in - F.pp_print_string fmt ("." ^ fun_name)) + let add_brackets (s : string) = + if !backend = Coq then "(" ^ s ^ ")" else s + in + F.pp_print_string fmt ("." ^ add_brackets fun_name)) else (* Provided method: we see it as a regular function call, and use the function name *) @@ -2021,12 +2027,15 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) in let ctx = - let trait_name = + let trait_name, trait_constructor = match builtin_info with - | None -> ctx.fmt.trait_decl_name trait_decl - | Some info -> info.extract_name + | None -> + ( ctx.fmt.trait_decl_name trait_decl, + ctx.fmt.trait_decl_constructor trait_decl ) + | Some info -> (info.extract_name, info.constructor) in - ctx_add (TraitDeclId trait_decl.def_id) trait_name ctx + let ctx = ctx_add (TraitDeclId trait_decl.def_id) trait_name ctx in + ctx_add (TraitDeclConstructorId trait_decl.def_id) trait_constructor ctx in (* Parent clauses *) let ctx = @@ -2108,7 +2117,7 @@ let extract_trait_decl_item (ctx : extraction_ctx) (fmt : F.formatter) let extract_trait_impl_item (ctx : extraction_ctx) (fmt : F.formatter) (item_name : string) (ty : unit -> unit) : unit = - let assign = match !Config.backend with Lean -> ":=" | _ -> "=" in + let assign = match !Config.backend with Lean | Coq -> ":=" | _ -> "=" in extract_trait_item ctx fmt item_name assign ty (** Small helper - TODO: move *) @@ -2215,87 +2224,173 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) cg_params trait_clauses; F.pp_print_space fmt (); - (match !backend with - | Lean -> F.pp_print_string fmt "where" - | FStar -> if not is_empty then F.pp_print_string fmt "= {" - | _ -> F.pp_print_string fmt "{"); - if !backend = FStar && is_empty then F.pp_print_string fmt "= unit"; + if is_empty && !backend = FStar then ( + F.pp_print_string fmt "= unit"; + (* Outer box *) + F.pp_close_box fmt ()) + else if is_empty && !backend = Coq then ( + (* Coq is not very good at infering constructors *) + let cons = ctx_get_trait_constructor decl.def_id ctx in + F.pp_print_string fmt (":= " ^ cons ^ "{}."); + (* Outer box *) + F.pp_close_box fmt ()) + else ( + (match !backend with + | Lean -> F.pp_print_string fmt "where" + | FStar -> F.pp_print_string fmt "= {" + | Coq -> + let cons = ctx_get_trait_constructor decl.def_id ctx in + F.pp_print_string fmt (":= " ^ cons ^ " {") + | _ -> F.pp_print_string fmt "{"); - (* Close the box for the name + generics *) - F.pp_close_box fmt (); + (* Close the box for the name + generics *) + F.pp_close_box fmt (); - (* - * Extract the items - *) + (* + * Extract the items + *) - (* The constants *) - List.iter - (fun (name, (ty, _)) -> - let item_name = ctx_get_trait_const decl.def_id name ctx in - let ty () = - let inside = false in - F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty inside ty - in - extract_trait_decl_item ctx fmt item_name ty) - decl.consts; + (* The constants *) + List.iter + (fun (name, (ty, _)) -> + let item_name = ctx_get_trait_const decl.def_id name ctx in + let ty () = + let inside = false in + F.pp_print_space fmt (); + extract_ty ctx fmt TypeDeclId.Set.empty inside ty + in + extract_trait_decl_item ctx fmt item_name ty) + decl.consts; - (* The types *) - List.iter - (fun (name, (clauses, _)) -> - (* Extract the type *) - let item_name = ctx_get_trait_type decl.def_id name ctx in - let ty () = - F.pp_print_space fmt (); - F.pp_print_string fmt (type_keyword ()) - in - extract_trait_decl_item ctx fmt item_name ty; - (* Extract the clauses *) - List.iter - (fun clause -> - let item_name = - ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx - in - let ty () = - F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause - in - extract_trait_decl_item ctx fmt item_name ty) - clauses) - decl.types; + (* The types *) + List.iter + (fun (name, (clauses, _)) -> + (* Extract the type *) + let item_name = ctx_get_trait_type decl.def_id name ctx in + let ty () = + F.pp_print_space fmt (); + F.pp_print_string fmt (type_keyword ()) + in + extract_trait_decl_item ctx fmt item_name ty; + (* Extract the clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + clauses) + decl.types; - (* The parent clauses - note that the parent clauses may refer to the types - and const generics: for this reason we extract them *after* *) - List.iter - (fun clause -> - let item_name = - ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx - in - let ty () = - F.pp_print_space fmt (); - extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause - in - extract_trait_decl_item ctx fmt item_name ty) - decl.parent_clauses; + (* The parent clauses - note that the parent clauses may refer to the types + and const generics: for this reason we extract them *after* *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_clause_type ctx fmt TypeDeclId.Set.empty clause + in + extract_trait_decl_item ctx fmt item_name ty) + decl.parent_clauses; - (* The required methods *) - List.iter - (fun (name, id) -> extract_trait_decl_method_items ctx fmt decl name id) - decl.required_methods; - - (* Close the outer boxes for the definition *) - if !Config.backend <> Lean then F.pp_close_box fmt (); - (* Close the brackets *) - (match !Config.backend with - | Lean -> () - | _ -> - if (not (!backend = FStar)) || not is_empty then ( + (* The required methods *) + List.iter + (fun (name, id) -> extract_trait_decl_method_items ctx fmt decl name id) + decl.required_methods; + + (* Close the outer boxes for the definition *) + if !Config.backend <> Lean then F.pp_close_box fmt (); + (* Close the brackets *) + match !Config.backend with + | Lean -> () + | Coq -> + F.pp_print_space fmt (); + F.pp_print_string fmt "}." + | _ -> F.pp_print_space fmt (); - F.pp_print_string fmt "}")); + F.pp_print_string fmt "}"); F.pp_close_box fmt (); (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 +(** Generate the [Arguments] instructions for the trait declarationsin Coq, so + that we don't have to provide the implicit arguments when projecting the fields. *) +let extract_trait_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) + (decl : trait_decl) : unit = + (* Generating the [Arguments] instructions is useful only if there are parameters *) + let num_params = + List.length decl.generics.types + + List.length decl.generics.const_generics + + List.length decl.generics.trait_clauses + in + if num_params > 0 then ( + (* The constructor *) + let cons_name = ctx_get_trait_constructor decl.def_id ctx in + extract_coq_arguments_instruction ctx fmt cons_name num_params; + (* The constants *) + List.iter + (fun (name, _) -> + let item_name = ctx_get_trait_const decl.def_id name ctx in + extract_coq_arguments_instruction ctx fmt item_name num_params) + decl.consts; + (* The types *) + List.iter + (fun (name, (clauses, _)) -> + (* The type *) + let item_name = ctx_get_trait_type decl.def_id name ctx in + extract_coq_arguments_instruction ctx fmt item_name num_params; + (* The type clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_item_clause decl.def_id name clause.clause_id ctx + in + extract_coq_arguments_instruction ctx fmt item_name num_params) + clauses) + decl.types; + (* The parent clauses *) + List.iter + (fun clause -> + let item_name = + ctx_get_trait_parent_clause decl.def_id clause.clause_id ctx + in + extract_coq_arguments_instruction ctx fmt item_name num_params) + decl.parent_clauses; + (* The required methods *) + List.iter + (fun (item_name, id) -> + (* Lookup the definition *) + let trans = A.FunDeclId.Map.find id ctx.trans_funs in + (* Extract the items *) + let funs = + if trans.keep_fwd then trans.fwd :: trans.backs else trans.backs + in + let extract_for_method (f : fun_and_loops) = + let f = f.f in + let item_name = + ctx_get_trait_method decl.def_id item_name f.back_id ctx + in + extract_coq_arguments_instruction ctx fmt item_name num_params + in + List.iter extract_for_method funs) + decl.required_methods; + (* Add a space *) + F.pp_print_space fmt ()) + +(** See {!extract_trait_decl_coq_arguments} *) +let extract_trait_decl_extra_info (ctx : extraction_ctx) (fmt : F.formatter) + (trait_decl : trait_decl) : unit = + match !backend with + | Coq -> extract_trait_decl_coq_arguments ctx fmt trait_decl + | _ -> () + (** Small helper. Extract the items for a method in a trait impl. @@ -2425,76 +2520,92 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) let is_empty = trait_impl_is_empty { impl with provided_methods = [] } in F.pp_print_space fmt (); - if !Config.backend = Lean then F.pp_print_string fmt ":= {" - else if !Config.backend = FStar && is_empty then F.pp_print_string fmt "= ()" - else F.pp_print_string fmt "= {"; + if is_empty && !Config.backend = FStar then ( + F.pp_print_string fmt "= ()"; + (* Outer box *) + 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.impl_trait.trait_decl_id ctx in + F.pp_print_string fmt (":= " ^ cons ^ "."); + (* Outer box *) + F.pp_close_box fmt ()) + else ( + if !Config.backend = Lean then F.pp_print_string fmt ":= {" + else if !Config.backend = Coq then F.pp_print_string fmt ":= {|" + else F.pp_print_string fmt "= {"; - (* Close the box for the name + generics *) - F.pp_close_box fmt (); + (* Close the box for the name + generics *) + F.pp_close_box fmt (); - (* - * Extract the items - *) - let trait_decl_id = impl.impl_trait.trait_decl_id in + (* + * Extract the items + *) + let trait_decl_id = impl.impl_trait.trait_decl_id in - (* The constants *) - List.iter - (fun (name, (_, id)) -> - let item_name = ctx_get_trait_const trait_decl_id name ctx in - let ty () = - F.pp_print_space fmt (); - F.pp_print_string fmt (ctx_get_global id ctx) - in + (* The constants *) + List.iter + (fun (name, (_, id)) -> + let item_name = ctx_get_trait_const trait_decl_id name ctx in + let ty () = + F.pp_print_space fmt (); + F.pp_print_string fmt (ctx_get_global id ctx) + in - extract_trait_impl_item ctx fmt item_name ty) - impl.consts; + extract_trait_impl_item ctx fmt item_name ty) + impl.consts; - (* The types *) - List.iter - (fun (name, (trait_refs, ty)) -> - (* Extract the type *) - let item_name = ctx_get_trait_type trait_decl_id name ctx in - let ty () = - F.pp_print_space fmt (); - extract_ty ctx fmt TypeDeclId.Set.empty false ty - in - extract_trait_impl_item ctx fmt item_name ty; - (* Extract the clauses *) - TraitClauseId.iteri - (fun clause_id trait_ref -> - let item_name = - ctx_get_trait_item_clause trait_decl_id name clause_id ctx - in - let ty () = - F.pp_print_space fmt (); - extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref - in - extract_trait_impl_item ctx fmt item_name ty) - trait_refs) - impl.types; - - (* The parent clauses *) - TraitClauseId.iteri - (fun clause_id trait_ref -> - let item_name = ctx_get_trait_parent_clause trait_decl_id clause_id ctx in - let ty () = - F.pp_print_space fmt (); - extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref - in - extract_trait_impl_item ctx fmt item_name ty) - impl.parent_trait_refs; + (* The types *) + List.iter + (fun (name, (trait_refs, ty)) -> + (* Extract the type *) + let item_name = ctx_get_trait_type trait_decl_id name ctx in + let ty () = + F.pp_print_space fmt (); + extract_ty ctx fmt TypeDeclId.Set.empty false ty + in + extract_trait_impl_item ctx fmt item_name ty; + (* Extract the clauses *) + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = + ctx_get_trait_item_clause trait_decl_id name clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + trait_refs) + impl.types; + + (* The parent clauses *) + TraitClauseId.iteri + (fun clause_id trait_ref -> + let item_name = + ctx_get_trait_parent_clause trait_decl_id clause_id ctx + in + let ty () = + F.pp_print_space fmt (); + extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref + in + extract_trait_impl_item ctx fmt item_name ty) + impl.parent_trait_refs; - (* The required methods *) - List.iter - (fun (name, id) -> - extract_trait_impl_method_items ctx fmt impl name id all_generics) - impl.required_methods; + (* The required methods *) + List.iter + (fun (name, id) -> + extract_trait_impl_method_items ctx fmt impl name id all_generics) + impl.required_methods; - (* Close the outer boxes for the definition, as well as the brackets *) - F.pp_close_box fmt (); - if (not (!backend = FStar)) || not is_empty then ( - F.pp_print_space fmt (); - F.pp_print_string fmt "}"); + (* Close the outer boxes for the definition, as well as the brackets *) + F.pp_close_box fmt (); + if !backend = Coq then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "|}.") + else if (not (!backend = FStar)) || not is_empty then ( + F.pp_print_space fmt (); + F.pp_print_string fmt "}")); F.pp_close_box fmt (); (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 55b1bca3..31b1a447 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -246,6 +246,7 @@ type formatter = { *) trait_decl_name : trait_decl -> string; trait_impl_name : trait_decl -> trait_impl -> string; + trait_decl_constructor : trait_decl -> string; trait_parent_clause_name : trait_decl -> trait_clause -> string; trait_const_name : trait_decl -> string -> string; trait_type_name : trait_decl -> string -> string; @@ -388,6 +389,7 @@ type id = | TraitDeclId of TraitDeclId.id | TraitImplId of TraitImplId.id | LocalTraitClauseId of TraitClauseId.id + | TraitDeclConstructorId of TraitDeclId.id | TraitMethodId of TraitDeclId.id * string * T.RegionGroupId.id option (** Something peculiar with trait methods: because we have to take into account forward/backward functions, we may need to generate fields @@ -801,6 +803,8 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TraitImplId id -> "trait_impl_id: " ^ TraitImplId.to_string id | LocalTraitClauseId id -> "local_trait_clause_id: " ^ TraitClauseId.to_string id + | TraitDeclConstructorId id -> + "trait_decl_constructor: " ^ trait_decl_id_to_string id | TraitParentClauseId (id, clause_id) -> "trait_parent_clause_id: " ^ trait_decl_id_to_string id ^ ", clause_id: " ^ TraitClauseId.to_string clause_id @@ -959,6 +963,10 @@ let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = ctx_get_type (Assumed id) ctx +let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : + string = + ctx_get (TraitDeclConstructorId id) ctx + let ctx_get_trait_self_clause (ctx : extraction_ctx) : string = ctx_get TraitSelfClauseId ctx diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index c6bde9c2..a54ab604 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -420,6 +420,7 @@ let builtin_fun_effects_map = type builtin_trait_decl_info = { rust_name : string; extract_name : string; + constructor : string; parent_clauses : string list; consts : (string * string) list; types : (string * (string * string list)) list; @@ -444,6 +445,7 @@ let builtin_trait_decls_info () = | Coq | FStar | HOL4 -> String.concat "_" rust_name | Lean -> String.concat "." rust_name) in + let constructor = mk_struct_constructor extract_name in let consts = [] in let types = let mk_type item_name = @@ -479,7 +481,15 @@ let builtin_trait_decls_info () = List.map mk_method methods in let rust_name = String.concat "::" rust_name in - { rust_name; extract_name; parent_clauses; consts; types; methods } + { + rust_name; + extract_name; + constructor; + parent_clauses; + consts; + types; + methods; + } in [ (* Deref *) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index a294d4ca..77f76bb4 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -697,6 +697,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Coq | HOL4 | Lean -> name in + let trait_decl_constructor (trait_decl : trait_decl) : string = + let name = trait_decl_name trait_decl in + ExtractBuiltin.mk_struct_constructor name + in + let trait_parent_clause_name (trait_decl : trait_decl) (clause : trait_clause) : string = (* TODO: improve - it would be better to not use indices *) @@ -937,6 +942,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) decreases_proof_name; trait_decl_name; trait_impl_name; + trait_decl_constructor; trait_parent_clause_name; trait_const_name; trait_type_name; @@ -1254,6 +1260,9 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) ctx_get_trait_type trait_ref.trait_decl_ref.trait_decl_id type_name ctx in + let add_brackets (s : string) = + if !backend = Coq then "(" ^ s ^ ")" else s + in (* There may be a special treatment depending on the instance id. See the comments for {!extract_trait_instance_id_with_dot}. TODO: there should be a cleaner way to do. The annoying thing @@ -1276,7 +1285,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) extract_trait_ref ctx fmt no_params_tys false trait_ref; extract_generic_args ctx fmt no_params_tys generics; if use_brackets then F.pp_print_string fmt ")"; - F.pp_print_string fmt ("." ^ type_name)) + F.pp_print_string fmt ("." ^ add_brackets type_name)) and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (tr : trait_ref) : unit = @@ -1376,6 +1385,7 @@ and extract_trait_instance_id_with_dot (ctx : extraction_ctx) and extract_trait_instance_id (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 -> (* This has a specific treatment depending on the item we're extracting @@ -1393,12 +1403,12 @@ and extract_trait_instance_id (ctx : extraction_ctx) (fmt : F.formatter) (* Use the trait decl id to lookup the name *) let name = ctx_get_trait_parent_clause decl_id clause_id ctx in extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; - F.pp_print_string fmt name + 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 decl_id item_name clause_id ctx in extract_trait_instance_id_with_dot ctx fmt no_params_tys true inst_id; - F.pp_print_string fmt name + F.pp_print_string fmt (add_brackets name) | TraitRef trait_ref -> extract_trait_ref ctx fmt no_params_tys inside trait_ref | UnknownTrait _ -> @@ -2156,49 +2166,59 @@ let extract_type_decl (ctx : extraction_ctx) (fmt : F.formatter) extract_type_decl_gen ctx fmt type_decl_group kind def extract_body | HOL4 -> extract_type_decl_hol4_opaque ctx fmt def +(** Generate a [Argument] instruction in Coq to allow omitting implicit + arguments for variants, fields, etc.. + + For instance, provided we have this definition: + {[ + Inductive result A := + | Return : A -> result A + | Fail_ : error -> result A. + ]} + + We may want to generate those instructions: + {[ + Arguments Return {_} a. + Arguments Fail_ {_}. + ]} + *) +let extract_coq_arguments_instruction (ctx : extraction_ctx) (fmt : F.formatter) + (cons_name : string) (num_implicit_params : int) : unit = + (* Add a break before *) + F.pp_print_break fmt 0 0; + (* Open a box *) + F.pp_open_hovbox fmt ctx.indent_incr; + F.pp_print_break fmt 0 0; + F.pp_print_string fmt "Arguments"; + F.pp_print_space fmt (); + F.pp_print_string fmt cons_name; + (* Print the type/const params and the trait clauses (`{T}`) *) + F.pp_print_space fmt (); + F.pp_print_string fmt "{"; + Collections.List.iter_times num_implicit_params (fun () -> + F.pp_print_space fmt (); + F.pp_print_string fmt "_"); + F.pp_print_space fmt (); + F.pp_print_string fmt "}."; + + (* Close the box *) + F.pp_close_box fmt () + (** Auxiliary function. - Generate [Arguments] instructions in Coq. + Generate [Arguments] instructions in Coq for type definitions. *) let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (kind : decl_kind) (decl : type_decl) : unit = assert (!backend = Coq); - (* Generating the [Arguments] instructions is useful only if there are type parameters *) - if decl.generics.types = [] && decl.generics.const_generics = [] then () + (* Generating the [Arguments] instructions is useful only if there are parameters *) + let num_params = + List.length decl.generics.types + + List.length decl.generics.const_generics + + List.length decl.generics.trait_clauses + in + if num_params = 0 then () else - (* Add the type params - note that we need those bindings only for the - * body translation (they are not top-level) *) - let _ctx_body, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.generics ctx - in - (* Auxiliary function to extract an [Arguments Cons {T} _ _.] instruction *) - let extract_arguments_info (cons_name : string) (fields : 'a list) : unit = - (* Add a break before *) - F.pp_print_break fmt 0 0; - (* Open a box *) - F.pp_open_hovbox fmt ctx.indent_incr; - F.pp_print_break fmt 0 0; - F.pp_print_string fmt "Arguments"; - F.pp_print_space fmt (); - F.pp_print_string fmt cons_name; - (* Print the type/const params and the trait clauses (`{T}`) *) - List.iter - (fun (var : string) -> - F.pp_print_space fmt (); - F.pp_print_string fmt ("{" ^ var ^ "}")) - (List.concat [ type_params; cg_params; trait_clauses ]); - (* Print the fields (`_`) *) - List.iter - (fun _ -> - F.pp_print_space fmt (); - F.pp_print_string fmt "_") - fields; - F.pp_print_string fmt "."; - - (* Close the box *) - F.pp_close_box fmt () - in - (* Generate the [Arguments] instruction *) match decl.kind with | Opaque -> () @@ -2206,23 +2226,23 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) let adt_id = AdtId decl.def_id in (* Generate the instruction for the record constructor *) let cons_name = ctx_get_struct adt_id ctx in - extract_arguments_info cons_name fields; + extract_coq_arguments_instruction ctx fmt cons_name num_params; (* Generate the instruction for the record projectors, if there are *) let is_rec = decl_is_from_rec_group kind in if not is_rec then FieldId.iteri (fun fid _ -> let cons_name = ctx_get_field adt_id fid ctx in - extract_arguments_info cons_name []) + extract_coq_arguments_instruction ctx fmt cons_name num_params) fields; (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 | Enum variants -> (* Generate the instructions *) VariantId.iteri - (fun vid (v : variant) -> + (fun vid (_ : variant) -> let cons_name = ctx_get_variant (AdtId decl.def_id) vid ctx in - extract_arguments_info cons_name v.fields) + extract_coq_arguments_instruction ctx fmt cons_name num_params) variants; (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 69c0df71..e17ea16f 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -104,9 +104,10 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) (* None of the assumed functions can diverge nor are considered stateful *) can_fail := !can_fail || Assumed.assumed_fun_can_fail id | TraitMethod _ -> - (* We consider trait functions can fail, diverge, and are not stateful *) - can_fail := true; - can_diverge := true); + (* We consider trait functions can fail, but can not diverge and are not stateful. + TODO: this may cause issues if we use use a fuel parameter. + *) + can_fail := true); super#visit_Call env call method! visit_Panic env = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index cb23198a..a3d96023 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -751,14 +751,17 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) (** Export a trait declaration. *) let export_trait_decl (fmt : Format.formatter) (_config : gen_config) - (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) : unit = + (ctx : gen_ctx) (trait_decl_id : Pure.trait_decl_id) (extract_decl : bool) + (extract_extra_info : bool) : unit = let trait_decl = T.TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls in (* Check if the trait declaration is builtin, in which case we ignore it *) let open ExtractBuiltin in let sname = name_to_simple_name trait_decl.name in - if SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) = None then + if SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) = None then ( let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in - Extract.extract_trait_decl ctx fmt trait_decl + if extract_decl then Extract.extract_trait_decl ctx fmt trait_decl; + if extract_extra_info then + Extract.extract_trait_decl_extra_info ctx fmt trait_decl) else () (** Export a trait implementation. *) @@ -796,7 +799,12 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) let export_functions_group = export_functions_group fmt config ctx in let export_global = export_global fmt config ctx in let export_types_group = export_types_group fmt config ctx in - let export_trait_decl = export_trait_decl fmt config ctx in + let export_trait_decl_group id = + export_trait_decl fmt config ctx id true false + in + let export_trait_decl_group_extra_info id = + export_trait_decl fmt config ctx id false true + in let export_trait_impl = export_trait_impl fmt config ctx in let export_state_type () : unit = @@ -833,8 +841,10 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) export_functions_group pure_funs | Global id -> export_global id | TraitDecl id -> - if config.extract_trait_decls && config.extract_transparent then - export_trait_decl id + (* TODO: update to extract groups *) + if config.extract_trait_decls && config.extract_transparent then ( + export_trait_decl_group id; + export_trait_decl_group_extra_info id) | TraitImpl id -> if config.extract_trait_impls && config.extract_transparent then export_trait_impl id -- cgit v1.2.3