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(-) 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(-) 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 +++ tests/coq/array/Array_Funs.v | 4 ++++ tests/fstar/array/Array.Funs.fst | 4 ++++ tests/lean/Array/Funs.lean | 4 ++++ 5 files changed, 17 insertions(+), 2 deletions(-) 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 diff --git a/tests/coq/array/Array_Funs.v b/tests/coq/array/Array_Funs.v index 6d791873..d47e4633 100644 --- a/tests/coq/array/Array_Funs.v +++ b/tests/coq/array/Array_Funs.v @@ -183,6 +183,10 @@ Definition index_index_array_fwd array_index_shared u32 32%usize a j . +(** [array::const_gen_ret]: forward function *) +Definition const_gen_ret_fwd (N : usize) : result usize := + Return N. + (** [array::update_update_array]: forward function *) Definition update_update_array_fwd (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index 7c1d0b09..72163585 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -139,6 +139,10 @@ let index_index_array_fwd let* a = array_index_shared (array u32 32) 32 s i in array_index_shared u32 32 a j +(** [array::const_gen_ret]: forward function *) +let const_gen_ret_fwd (n : usize) : result usize = + Return n + (** [array::update_update_array]: forward function *) let update_update_array_fwd (s : array (array u32 32) 32) (i : usize) (j : usize) : result unit = diff --git a/tests/lean/Array/Funs.lean b/tests/lean/Array/Funs.lean index ad737dca..8d10c660 100644 --- a/tests/lean/Array/Funs.lean +++ b/tests/lean/Array/Funs.lean @@ -166,6 +166,10 @@ def index_index_array Array.index_shared (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i Array.index_shared U32 (Usize.ofInt 32) a j +/- [array::const_gen_ret]: forward function -/ +def const_gen_ret (N : Usize) : Result Usize := + Result.ret N + /- [array::update_update_array]: forward function -/ def update_update_array (s : Array (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32)) (i : Usize) -- cgit v1.2.3 From 8543092569616ef6a75949a72532f7b73dc696f2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 18 Aug 2023 12:23:03 +0200 Subject: Regenerate the array tests --- tests/coq/array/Array_Funs.v | 9 +++++++++ tests/fstar/array/Array.Funs.fst | 8 ++++++++ tests/lean/Array/Funs.lean | 8 ++++++++ 3 files changed, 25 insertions(+) diff --git a/tests/coq/array/Array_Funs.v b/tests/coq/array/Array_Funs.v index d47e4633..6ff3066a 100644 --- a/tests/coq/array/Array_Funs.v +++ b/tests/coq/array/Array_Funs.v @@ -451,6 +451,15 @@ Definition f3_fwd (n : nat) : result u32 := sum2_fwd n s s0 . +(** [array::SZ] *) +Definition sz_body : result usize := Return 32%usize. +Definition sz_c : usize := sz_body%global. + +(** [array::f5]: forward function *) +Definition f5_fwd (x : array u32 32%usize) : result u32 := + array_index_shared u32 32%usize x 0%usize +. + (** [array::ite]: forward function *) Definition ite_fwd : result unit := s <- diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index 72163585..83256398 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -347,6 +347,14 @@ let f3_fwd : result u32 = ]) 16 18 in sum2_fwd s s0 +(** [array::SZ] *) +let sz_body : result usize = Return 32 +let sz_c : usize = eval_global sz_body + +(** [array::f5]: forward function *) +let f5_fwd (x : array u32 32) : result u32 = + array_index_shared u32 32 x 0 + (** [array::ite]: forward function *) let ite_fwd : result unit = let* s = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in diff --git a/tests/lean/Array/Funs.lean b/tests/lean/Array/Funs.lean index 8d10c660..a42072d1 100644 --- a/tests/lean/Array/Funs.lean +++ b/tests/lean/Array/Funs.lean @@ -447,6 +447,14 @@ def f3 : Result U32 := ]) (Usize.ofInt 16) (Usize.ofInt 18) sum2 s s0 +/- [array::SZ] -/ +def sz_body : Result Usize := Result.ret (Usize.ofInt 32) +def sz_c : Usize := eval_global sz_body (by simp) + +/- [array::f5]: forward function -/ +def f5 (x : Array U32 (Usize.ofInt 32)) : Result U32 := + Array.index_shared U32 (Usize.ofInt 32) x (Usize.ofInt 0) + /- [array::ite]: forward function -/ def ite : Result Unit := do -- 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 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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 --- Makefile | 2 +- compiler/Driver.ml | 4 +++- compiler/SymbolicToPure.ml | 14 ++++++++++++-- 3 files changed, 16 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index a0111b37..807352f8 100644 --- a/Makefile +++ b/Makefile @@ -166,7 +166,7 @@ tleanp-polonius_list: OPTIONS += thol4p-polonius_list: SUBDIR := misc-polonius_list thol4p-polonius_list: OPTIONS += -trans-constants: OPTIONS += -test-units -test-trans-units -no-split-files -no-state +trans-constants: OPTIONS += -test-trans-units -no-split-files -no-state trans-constants: SUBDIR := misc tfstar-constants: OPTIONS += tcoq-constants: OPTIONS += 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(-) 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 --- backends/lean/Base/Primitives/Scalar.lean | 42 ++++++++++++++++++++++++++ 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 + 8 files changed, 154 insertions(+), 38 deletions(-) create mode 100644 compiler/ExtractAssumed.ml diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index ffc969f3..fa5a63cd 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -230,6 +230,20 @@ def Scalar.cMax (ty : ScalarTy) : Int := | .Usize => Scalar.max .U32 | _ => Scalar.max ty +theorem Scalar.min_lt_max (ty : ScalarTy) : Scalar.min ty < Scalar.max ty := by + cases ty <;> simp [Scalar.min, Scalar.max] + . simp [Isize.min, Isize.max] + have h1 := Isize.refined_min.property + have h2 := Isize.refined_max.property + cases h1 <;> cases h2 <;> simp [*] + . simp [Usize.max] + have h := Usize.refined_max.property + cases h <;> simp [*] + +theorem Scalar.min_le_max (ty : ScalarTy) : Scalar.min ty ≤ Scalar.max ty := by + have := Scalar.min_lt_max ty + int_tac + theorem Scalar.cMin_bound ty : Scalar.min ty ≤ Scalar.cMin ty := by cases ty <;> simp [Scalar.min, Scalar.max, Scalar.cMin, Scalar.cMax] at * have h := Isize.refined_min.property @@ -395,6 +409,34 @@ def Scalar.cast {src_ty : ScalarTy} (tgt_ty : ScalarTy) (x : Scalar src_ty) : Re @[reducible] def U64 := Scalar .U64 @[reducible] def U128 := Scalar .U128 +-- TODO: reducible? +@[reducible] def isize_min : Isize := Scalar.ofInt Isize.min (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) +@[reducible] def isize_max : Isize := Scalar.ofInt Isize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) +@[reducible] def i8_min : I8 := Scalar.ofInt I8.min +@[reducible] def i8_max : I8 := Scalar.ofInt I8.max +@[reducible] def i16_min : I16 := Scalar.ofInt I16.min +@[reducible] def i16_max : I16 := Scalar.ofInt I16.max +@[reducible] def i32_min : I32 := Scalar.ofInt I32.min +@[reducible] def i32_max : I32 := Scalar.ofInt I32.max +@[reducible] def i64_min : I64 := Scalar.ofInt I64.min +@[reducible] def i64_max : I64 := Scalar.ofInt I64.max +@[reducible] def i128_min : I128 := Scalar.ofInt I128.min +@[reducible] def i128_max : I128 := Scalar.ofInt I128.max + +-- TODO: reducible? +@[reducible] def usize_min : Usize := Scalar.ofInt Usize.min +@[reducible] def usize_max : Usize := Scalar.ofInt Usize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Usize)) +@[reducible] def u8_min : U8 := Scalar.ofInt U8.min +@[reducible] def u8_max : U8 := Scalar.ofInt U8.max +@[reducible] def u16_min : U16 := Scalar.ofInt U16.min +@[reducible] def u16_max : U16 := Scalar.ofInt U16.max +@[reducible] def u32_min : U32 := Scalar.ofInt U32.min +@[reducible] def u32_max : U32 := Scalar.ofInt U32.max +@[reducible] def u64_min : U64 := Scalar.ofInt U64.min +@[reducible] def u64_max : U64 := Scalar.ofInt U64.max +@[reducible] def u128_min : U128 := Scalar.ofInt U128.min +@[reducible] def u128_max : U128 := Scalar.ofInt U128.max + -- TODO: below: not sure this is the best way. -- Should we rather overload operations like +, -, etc.? -- Also, it is possible to automate the generation of those definitions 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 --- backends/coq/Primitives.v | 14 ++++ backends/fstar/Primitives.fst | 47 +++++++++--- backends/hol4/primitivesScript.sml | 26 +++++++ backends/hol4/primitivesTheory.sig | 120 ++++++++++++++++++++++++++++++ backends/lean/Base/Primitives/Scalar.lean | 48 ++++++------ compiler/Extract.ml | 1 - compiler/ExtractAssumed.ml | 40 ++++++---- 7 files changed, 247 insertions(+), 49 deletions(-) diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 71a2d9c3..8d6c9c8d 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -394,6 +394,20 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + (*** Range *) Record range (T : Type) := mk_range { start: T; diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 9db82069..cd18cf29 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/backends/hol4/primitivesScript.sml b/backends/hol4/primitivesScript.sml index 82da4de9..916988be 100644 --- a/backends/hol4/primitivesScript.sml +++ b/backends/hol4/primitivesScript.sml @@ -555,6 +555,32 @@ Proof QED val _ = evalLib.add_unfold_thm "mk_isize_unfold" +(** Constants *) +val core_i8_min_def = Define ‘core_i8_min = int_to_i8 i8_min’ +val core_i8_max_def = Define ‘core_i8_max = int_to_i8 i8_max’ +val core_i16_min_def = Define ‘core_i16_min = int_to_i16 i16_min’ +val core_i16_max_def = Define ‘core_i16_max = int_to_i16 i16_max’ +val core_i32_min_def = Define ‘core_i32_min = int_to_i32 i32_min’ +val core_i32_max_def = Define ‘core_i32_max = int_to_i32 i32_max’ +val core_i64_min_def = Define ‘core_i64_min = int_to_i64 i64_min’ +val core_i64_max_def = Define ‘core_i64_max = int_to_i64 i64_max’ +val core_i128_min_def = Define ‘core_i128_min = int_to_i128 i128_min’ +val core_i128_max_def = Define ‘core_i128_max = int_to_i128 i128_max’ +val core_isize_min_def = Define ‘core_isize_min = int_to_isize isize_min’ +val core_isize_max_def = Define ‘core_isize_max = int_to_isize isize_max’ +val core_u8_min_def = Define ‘core_u8_min = int_to_u8 0’ +val core_u8_max_def = Define ‘core_u8_max = int_to_u8 u8_max’ +val core_u16_min_def = Define ‘core_u16_min = int_to_u16 0’ +val core_u16_max_def = Define ‘core_u16_max = int_to_u16 u16_max’ +val core_u32_min_def = Define ‘core_u32_min = int_to_u32 0’ +val core_u32_max_def = Define ‘core_u32_max = int_to_u32 u32_max’ +val core_u64_min_def = Define ‘core_u64_min = int_to_u64 0’ +val core_u64_max_def = Define ‘core_u64_max = int_to_u64 u64_max’ +val core_u128_min_def = Define ‘core_u128_min = int_to_u128 0’ +val core_u128_max_def = Define ‘core_u128_max = int_to_u128 u128_max’ +val core_usize_min_def = Define ‘core_usize_min = int_to_usize 0’ +val core_usize_max_def = Define ‘core_usize_max = int_to_usize usize_max’ + val isize_neg_def = Define ‘isize_neg x = mk_isize (- (isize_to_int x))’ val i8_neg_def = Define ‘i8_neg x = mk_i8 (- (i8_to_int x))’ val i16_neg_def = Define ‘i16_neg x = mk_i16 (- (i16_to_int x))’ diff --git a/backends/hol4/primitivesTheory.sig b/backends/hol4/primitivesTheory.sig index 6660b02d..4ae6bb3e 100644 --- a/backends/hol4/primitivesTheory.sig +++ b/backends/hol4/primitivesTheory.sig @@ -46,6 +46,30 @@ sig (* Definitions *) val bind_def : thm + val core_i128_max_def : thm + val core_i128_min_def : thm + val core_i16_max_def : thm + val core_i16_min_def : thm + val core_i32_max_def : thm + val core_i32_min_def : thm + val core_i64_max_def : thm + val core_i64_min_def : thm + val core_i8_max_def : thm + val core_i8_min_def : thm + val core_isize_max_def : thm + val core_isize_min_def : thm + val core_u128_max_def : thm + val core_u128_min_def : thm + val core_u16_max_def : thm + val core_u16_min_def : thm + val core_u32_max_def : thm + val core_u32_min_def : thm + val core_u64_max_def : thm + val core_u64_min_def : thm + val core_u8_max_def : thm + val core_u8_min_def : thm + val core_usize_max_def : thm + val core_usize_min_def : thm val error_BIJ : thm val error_CASE : thm val error_TY_DEF : thm @@ -566,6 +590,102 @@ sig monad_bind x f = case x of Return y => f y | Fail e => Fail e | Diverge => Diverge + [core_i128_max_def] Definition + + ⊢ core_i128_max = int_to_i128 i128_max + + [core_i128_min_def] Definition + + ⊢ core_i128_min = int_to_i128 i128_min + + [core_i16_max_def] Definition + + ⊢ core_i16_max = int_to_i16 i16_max + + [core_i16_min_def] Definition + + ⊢ core_i16_min = int_to_i16 i16_min + + [core_i32_max_def] Definition + + ⊢ core_i32_max = int_to_i32 i32_max + + [core_i32_min_def] Definition + + ⊢ core_i32_min = int_to_i32 i32_min + + [core_i64_max_def] Definition + + ⊢ core_i64_max = int_to_i64 i64_max + + [core_i64_min_def] Definition + + ⊢ core_i64_min = int_to_i64 i64_min + + [core_i8_max_def] Definition + + ⊢ core_i8_max = int_to_i8 i8_max + + [core_i8_min_def] Definition + + ⊢ core_i8_min = int_to_i8 i8_min + + [core_isize_max_def] Definition + + ⊢ core_isize_max = int_to_isize isize_max + + [core_isize_min_def] Definition + + ⊢ core_isize_min = int_to_isize isize_min + + [core_u128_max_def] Definition + + ⊢ core_u128_max = int_to_u128 u128_max + + [core_u128_min_def] Definition + + ⊢ core_u128_min = int_to_u128 0 + + [core_u16_max_def] Definition + + ⊢ core_u16_max = int_to_u16 u16_max + + [core_u16_min_def] Definition + + ⊢ core_u16_min = int_to_u16 0 + + [core_u32_max_def] Definition + + ⊢ core_u32_max = int_to_u32 u32_max + + [core_u32_min_def] Definition + + ⊢ core_u32_min = int_to_u32 0 + + [core_u64_max_def] Definition + + ⊢ core_u64_max = int_to_u64 u64_max + + [core_u64_min_def] Definition + + ⊢ core_u64_min = int_to_u64 0 + + [core_u8_max_def] Definition + + ⊢ core_u8_max = int_to_u8 u8_max + + [core_u8_min_def] Definition + + ⊢ core_u8_min = int_to_u8 0 + + [core_usize_max_def] Definition + + ⊢ core_usize_max = int_to_usize usize_max + + [core_usize_min_def] Definition + + ⊢ core_usize_min = int_to_usize 0 + [error_BIJ] Definition ⊢ (∀a. num2error (error2num a) = a) ∧ diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index fa5a63cd..6e7733a7 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -410,32 +410,32 @@ def Scalar.cast {src_ty : ScalarTy} (tgt_ty : ScalarTy) (x : Scalar src_ty) : Re @[reducible] def U128 := Scalar .U128 -- TODO: reducible? -@[reducible] def isize_min : Isize := Scalar.ofInt Isize.min (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) -@[reducible] def isize_max : Isize := Scalar.ofInt Isize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) -@[reducible] def i8_min : I8 := Scalar.ofInt I8.min -@[reducible] def i8_max : I8 := Scalar.ofInt I8.max -@[reducible] def i16_min : I16 := Scalar.ofInt I16.min -@[reducible] def i16_max : I16 := Scalar.ofInt I16.max -@[reducible] def i32_min : I32 := Scalar.ofInt I32.min -@[reducible] def i32_max : I32 := Scalar.ofInt I32.max -@[reducible] def i64_min : I64 := Scalar.ofInt I64.min -@[reducible] def i64_max : I64 := Scalar.ofInt I64.max -@[reducible] def i128_min : I128 := Scalar.ofInt I128.min -@[reducible] def i128_max : I128 := Scalar.ofInt I128.max +@[reducible] def core_isize_min : Isize := Scalar.ofInt Isize.min (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) +@[reducible] def core_isize_max : Isize := Scalar.ofInt Isize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Isize)) +@[reducible] def core_i8_min : I8 := Scalar.ofInt I8.min +@[reducible] def core_i8_max : I8 := Scalar.ofInt I8.max +@[reducible] def core_i16_min : I16 := Scalar.ofInt I16.min +@[reducible] def core_i16_max : I16 := Scalar.ofInt I16.max +@[reducible] def core_i32_min : I32 := Scalar.ofInt I32.min +@[reducible] def core_i32_max : I32 := Scalar.ofInt I32.max +@[reducible] def core_i64_min : I64 := Scalar.ofInt I64.min +@[reducible] def core_i64_max : I64 := Scalar.ofInt I64.max +@[reducible] def core_i128_min : I128 := Scalar.ofInt I128.min +@[reducible] def core_i128_max : I128 := Scalar.ofInt I128.max -- TODO: reducible? -@[reducible] def usize_min : Usize := Scalar.ofInt Usize.min -@[reducible] def usize_max : Usize := Scalar.ofInt Usize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Usize)) -@[reducible] def u8_min : U8 := Scalar.ofInt U8.min -@[reducible] def u8_max : U8 := Scalar.ofInt U8.max -@[reducible] def u16_min : U16 := Scalar.ofInt U16.min -@[reducible] def u16_max : U16 := Scalar.ofInt U16.max -@[reducible] def u32_min : U32 := Scalar.ofInt U32.min -@[reducible] def u32_max : U32 := Scalar.ofInt U32.max -@[reducible] def u64_min : U64 := Scalar.ofInt U64.min -@[reducible] def u64_max : U64 := Scalar.ofInt U64.max -@[reducible] def u128_min : U128 := Scalar.ofInt U128.min -@[reducible] def u128_max : U128 := Scalar.ofInt U128.max +@[reducible] def core_usize_min : Usize := Scalar.ofInt Usize.min +@[reducible] def core_usize_max : Usize := Scalar.ofInt Usize.max (by simp [Scalar.min, Scalar.max]; apply (Scalar.min_le_max .Usize)) +@[reducible] def core_u8_min : U8 := Scalar.ofInt U8.min +@[reducible] def core_u8_max : U8 := Scalar.ofInt U8.max +@[reducible] def core_u16_min : U16 := Scalar.ofInt U16.min +@[reducible] def core_u16_max : U16 := Scalar.ofInt U16.max +@[reducible] def core_u32_min : U32 := Scalar.ofInt U32.min +@[reducible] def core_u32_max : U32 := Scalar.ofInt U32.max +@[reducible] def core_u64_min : U64 := Scalar.ofInt U64.min +@[reducible] def core_u64_max : U64 := Scalar.ofInt U64.max +@[reducible] def core_u128_min : U128 := Scalar.ofInt U128.min +@[reducible] def core_u128_max : U128 := Scalar.ofInt U128.max -- TODO: below: not sure this is the best way. -- Should we rather overload operations like +, -, etc.? 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 ce8f5c8f67e41a74bfdf8f6d664ff4e45e9de850 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 7 Sep 2023 16:06:14 +0200 Subject: Regenerate the test files and fix a proof --- tests/coq/array/Primitives.v | 14 +++++++ tests/coq/betree/BetreeMain_Funs.v | 10 +---- tests/coq/betree/Primitives.v | 14 +++++++ tests/coq/hashmap/Hashmap_Funs.v | 6 +-- tests/coq/hashmap/Primitives.v | 14 +++++++ tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 6 +-- tests/coq/hashmap_on_disk/Primitives.v | 14 +++++++ tests/coq/misc/Constants.v | 6 +-- tests/coq/misc/Primitives.v | 14 +++++++ tests/fstar/array/Primitives.fst | 47 +++++++++++++++++----- tests/fstar/betree/BetreeMain.Funs.fst | 8 +--- tests/fstar/betree/Primitives.fst | 47 +++++++++++++++++----- .../fstar/betree_back_stateful/BetreeMain.Funs.fst | 8 +--- tests/fstar/betree_back_stateful/Primitives.fst | 47 +++++++++++++++++----- tests/fstar/hashmap/Hashmap.Funs.fst | 6 +-- tests/fstar/hashmap/Primitives.fst | 47 +++++++++++++++++----- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 6 +-- tests/fstar/hashmap_on_disk/Primitives.fst | 47 +++++++++++++++++----- tests/fstar/misc/Constants.fst | 6 +-- tests/fstar/misc/Primitives.fst | 47 +++++++++++++++++----- tests/hol4/betree/betreeMain_FunsScript.sml | 12 +----- tests/hol4/betree/betreeMain_FunsTheory.sig | 14 +------ tests/hol4/hashmap/hashmap_FunsScript.sml | 10 +---- tests/hol4/hashmap/hashmap_FunsTheory.sig | 12 +----- tests/hol4/hashmap/hashmap_PropertiesScript.sml | 2 +- .../hashmap_on_disk/hashmapMain_FunsScript.sml | 10 +---- .../hashmap_on_disk/hashmapMain_FunsTheory.sig | 12 +----- tests/hol4/misc-constants/constantsScript.sml | 10 +---- tests/hol4/misc-constants/constantsTheory.sig | 12 +----- tests/lean/BetreeMain/Funs.lean | 9 +---- tests/lean/Constants.lean | 6 +-- tests/lean/Hashmap/Funs.lean | 6 +-- tests/lean/HashmapMain/Funs.lean | 6 +-- 33 files changed, 320 insertions(+), 215 deletions(-) diff --git a/tests/coq/array/Primitives.v b/tests/coq/array/Primitives.v index 71a2d9c3..8d6c9c8d 100644 --- a/tests/coq/array/Primitives.v +++ b/tests/coq/array/Primitives.v @@ -394,6 +394,20 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + (*** Range *) Record range (T : Type) := mk_range { start: T; diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index 1e457433..cfa1f8fb 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -75,12 +75,6 @@ Definition betree_node_id_counter_fresh_id_back Return {| Betree_node_id_counter_next_node_id := i |} . -(** [core::num::u64::{9}::MAX] *) -Definition core_num_u64_max_body : result u64 := - Return 18446744073709551615%u64 -. -Definition core_num_u64_max_c : u64 := core_num_u64_max_body%global. - (** [betree_main::betree::upsert_update]: forward function *) Definition betree_upsert_update_fwd (prev : option u64) (st : Betree_upsert_fun_state_t) : result u64 := @@ -93,8 +87,8 @@ Definition betree_upsert_update_fwd | Some prev0 => match st with | BetreeUpsertFunStateAdd v => - margin <- u64_sub core_num_u64_max_c prev0; - if margin s>= v then u64_add prev0 v else Return core_num_u64_max_c + margin <- u64_sub core_u64_max prev0; + if margin s>= v then u64_add prev0 v else Return core_u64_max | BetreeUpsertFunStateSub v => if prev0 s>= v then u64_sub prev0 v else Return 0%u64 end diff --git a/tests/coq/betree/Primitives.v b/tests/coq/betree/Primitives.v index 71a2d9c3..8d6c9c8d 100644 --- a/tests/coq/betree/Primitives.v +++ b/tests/coq/betree/Primitives.v @@ -394,6 +394,20 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + (*** Range *) Record range (T : Type) := mk_range { start: T; diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index e950ba0b..054880d4 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -190,10 +190,6 @@ Definition hash_map_insert_no_resize_fwd_back |}) . -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body : result u32 := Return 4294967295%u32. -Definition core_num_u32_max_c : u32 := core_num_u32_max_body%global. - (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hash_map_move_elements_from_list_loop_fwd_back @@ -259,7 +255,7 @@ Definition hash_map_move_elements_fwd_back (there is a single backward function, and the forward function returns ()) *) Definition hash_map_try_resize_fwd_back (T : Type) (n : nat) (self : Hash_map_t T) : result (Hash_map_t T) := - max_usize <- scalar_cast U32 Usize core_num_u32_max_c; + max_usize <- scalar_cast U32 Usize core_u32_max; let capacity := vec_len (List_t T) self.(Hash_map_slots) in n1 <- usize_div max_usize 2%usize; let (i, i0) := self.(Hash_map_max_load_factor) in diff --git a/tests/coq/hashmap/Primitives.v b/tests/coq/hashmap/Primitives.v index 71a2d9c3..8d6c9c8d 100644 --- a/tests/coq/hashmap/Primitives.v +++ b/tests/coq/hashmap/Primitives.v @@ -394,6 +394,20 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + (*** Range *) Record range (T : Type) := mk_range { start: T; diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index 657d5590..a85adbf2 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -208,10 +208,6 @@ Definition hashmap_hash_map_insert_no_resize_fwd_back |}) . -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body : result u32 := Return 4294967295%u32. -Definition core_num_u32_max_c : u32 := core_num_u32_max_body%global. - (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashmap_hash_map_move_elements_from_list_loop_fwd_back @@ -282,7 +278,7 @@ Definition hashmap_hash_map_try_resize_fwd_back (T : Type) (n : nat) (self : Hashmap_hash_map_t T) : result (Hashmap_hash_map_t T) := - max_usize <- scalar_cast U32 Usize core_num_u32_max_c; + max_usize <- scalar_cast U32 Usize core_u32_max; let capacity := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in n1 <- usize_div max_usize 2%usize; let (i, i0) := self.(Hashmap_hash_map_max_load_factor) in diff --git a/tests/coq/hashmap_on_disk/Primitives.v b/tests/coq/hashmap_on_disk/Primitives.v index 71a2d9c3..8d6c9c8d 100644 --- a/tests/coq/hashmap_on_disk/Primitives.v +++ b/tests/coq/hashmap_on_disk/Primitives.v @@ -394,6 +394,20 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + (*** Range *) Record range (T : Type) := mk_range { start: T; diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index f1c32730..5dd78a09 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -12,12 +12,8 @@ Module Constants. Definition x0_body : result u32 := Return 0%u32. Definition x0_c : u32 := x0_body%global. -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body : result u32 := Return 4294967295%u32. -Definition core_num_u32_max_c : u32 := core_num_u32_max_body%global. - (** [constants::X1] *) -Definition x1_body : result u32 := Return core_num_u32_max_c. +Definition x1_body : result u32 := Return core_u32_max. Definition x1_c : u32 := x1_body%global. (** [constants::X2] *) diff --git a/tests/coq/misc/Primitives.v b/tests/coq/misc/Primitives.v index 71a2d9c3..8d6c9c8d 100644 --- a/tests/coq/misc/Primitives.v +++ b/tests/coq/misc/Primitives.v @@ -394,6 +394,20 @@ Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + (*** Range *) Record range (T : Type) := mk_range { start: T; diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 9db82069..cd18cf29 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index 847dc865..2bb2352b 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -60,10 +60,6 @@ let betree_node_id_counter_fresh_id_back let* i = u64_add self.betree_node_id_counter_next_node_id 1 in Return { betree_node_id_counter_next_node_id = i } -(** [core::num::u64::{9}::MAX] *) -let core_num_u64_max_body : result u64 = Return 18446744073709551615 -let core_num_u64_max_c : u64 = eval_global core_num_u64_max_body - (** [betree_main::betree::upsert_update]: forward function *) let betree_upsert_update_fwd (prev : option u64) (st : betree_upsert_fun_state_t) : result u64 = @@ -76,8 +72,8 @@ let betree_upsert_update_fwd | Some prev0 -> begin match st with | BetreeUpsertFunStateAdd v -> - let* margin = u64_sub core_num_u64_max_c prev0 in - if margin >= v then u64_add prev0 v else Return core_num_u64_max_c + let* margin = u64_sub core_u64_max prev0 in + if margin >= v then u64_add prev0 v else Return core_u64_max | BetreeUpsertFunStateSub v -> if prev0 >= v then u64_sub prev0 v else Return 0 end diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 9db82069..cd18cf29 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index 3d08cd3c..8083ee8f 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -60,10 +60,6 @@ let betree_node_id_counter_fresh_id_back let* i = u64_add self.betree_node_id_counter_next_node_id 1 in Return { betree_node_id_counter_next_node_id = i } -(** [core::num::u64::{9}::MAX] *) -let core_num_u64_max_body : result u64 = Return 18446744073709551615 -let core_num_u64_max_c : u64 = eval_global core_num_u64_max_body - (** [betree_main::betree::upsert_update]: forward function *) let betree_upsert_update_fwd (prev : option u64) (st : betree_upsert_fun_state_t) : result u64 = @@ -76,8 +72,8 @@ let betree_upsert_update_fwd | Some prev0 -> begin match st with | BetreeUpsertFunStateAdd v -> - let* margin = u64_sub core_num_u64_max_c prev0 in - if margin >= v then u64_add prev0 v else Return core_num_u64_max_c + let* margin = u64_sub core_u64_max prev0 in + if margin >= v then u64_add prev0 v else Return core_u64_max | BetreeUpsertFunStateSub v -> if prev0 >= v then u64_sub prev0 v else Return 0 end diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 9db82069..cd18cf29 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index f4c13a7b..40cd0477 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -139,10 +139,6 @@ let hash_map_insert_no_resize_fwd_back let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in Return { self with hash_map_slots = v } -(** [core::num::u32::{8}::MAX] *) -let core_num_u32_max_body : result u32 = Return 4294967295 -let core_num_u32_max_c : u32 = eval_global core_num_u32_max_body - (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hash_map_move_elements_from_list_loop_fwd_back @@ -194,7 +190,7 @@ let hash_map_move_elements_fwd_back (there is a single backward function, and the forward function returns ()) *) let hash_map_try_resize_fwd_back (t : Type0) (self : hash_map_t t) : result (hash_map_t t) = - let* max_usize = scalar_cast U32 Usize core_num_u32_max_c in + let* max_usize = scalar_cast U32 Usize core_u32_max in let capacity = vec_len (list_t t) self.hash_map_slots in let* n1 = usize_div max_usize 2 in let (i, i0) = self.hash_map_max_load_factor in diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 9db82069..cd18cf29 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 1c94209c..5af90bd8 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -157,10 +157,6 @@ let hashmap_hash_map_insert_no_resize_fwd_back hash_mod l0 in Return { self with hashmap_hash_map_slots = v } -(** [core::num::u32::{8}::MAX] *) -let core_num_u32_max_body : result u32 = Return 4294967295 -let core_num_u32_max_c : u32 = eval_global core_num_u32_max_body - (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashmap_hash_map_move_elements_from_list_loop_fwd_back @@ -218,7 +214,7 @@ let hashmap_hash_map_move_elements_fwd_back (there is a single backward function, and the forward function returns ()) *) let hashmap_hash_map_try_resize_fwd_back (t : Type0) (self : hashmap_hash_map_t t) : result (hashmap_hash_map_t t) = - let* max_usize = scalar_cast U32 Usize core_num_u32_max_c in + let* max_usize = scalar_cast U32 Usize core_u32_max in let capacity = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in let* n1 = usize_div max_usize 2 in let (i, i0) = self.hashmap_hash_map_max_load_factor in diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 9db82069..cd18cf29 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/tests/fstar/misc/Constants.fst b/tests/fstar/misc/Constants.fst index d2b0415e..7dfb6f36 100644 --- a/tests/fstar/misc/Constants.fst +++ b/tests/fstar/misc/Constants.fst @@ -9,12 +9,8 @@ open Primitives let x0_body : result u32 = Return 0 let x0_c : u32 = eval_global x0_body -(** [core::num::u32::{8}::MAX] *) -let core_num_u32_max_body : result u32 = Return 4294967295 -let core_num_u32_max_c : u32 = eval_global core_num_u32_max_body - (** [constants::X1] *) -let x1_body : result u32 = Return core_num_u32_max_c +let x1_body : result u32 = Return core_u32_max let x1_c : u32 = eval_global x1_body (** [constants::X2] *) diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index 9db82069..cd18cf29 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -169,17 +169,44 @@ let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : /// The scalar types type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max /// Negation let isize_neg = scalar_neg #Isize diff --git a/tests/hol4/betree/betreeMain_FunsScript.sml b/tests/hol4/betree/betreeMain_FunsScript.sml index 5e604f8c..bd16c16c 100644 --- a/tests/hol4/betree/betreeMain_FunsScript.sml +++ b/tests/hol4/betree/betreeMain_FunsScript.sml @@ -88,14 +88,6 @@ val betree_node_id_counter_fresh_id_back_def = Define ‘ od ’ -(** [core::num::u64::{9}::MAX] *) -Definition core_num_u64_max_body_def: - core_num_u64_max_body : u64 result = Return (int_to_u64 18446744073709551615) -End -Definition core_num_u64_max_c_def: - core_num_u64_max_c : u64 = get_return_value core_num_u64_max_body -End - val betree_upsert_update_fwd_def = Define ‘ (** [betree_main::betree::upsert_update]: forward function *) betree_upsert_update_fwd @@ -109,8 +101,8 @@ val betree_upsert_update_fwd_def = Define ‘ (case st of | BetreeUpsertFunStateAdd v => do - margin <- u64_sub core_num_u64_max_c prev0; - if u64_ge margin v then u64_add prev0 v else Return core_num_u64_max_c + margin <- u64_sub core_u64_max prev0; + if u64_ge margin v then u64_add prev0 v else Return core_u64_max od | BetreeUpsertFunStateSub v => if u64_ge prev0 v then u64_sub prev0 v else Return (int_to_u64 0))) diff --git a/tests/hol4/betree/betreeMain_FunsTheory.sig b/tests/hol4/betree/betreeMain_FunsTheory.sig index 6c249f70..c922ca9f 100644 --- a/tests/hol4/betree/betreeMain_FunsTheory.sig +++ b/tests/hol4/betree/betreeMain_FunsTheory.sig @@ -58,8 +58,6 @@ sig val betree_store_internal_node_fwd_def : thm val betree_store_leaf_node_fwd_def : thm val betree_upsert_update_fwd_def : thm - val core_num_u64_max_body_def : thm - val core_num_u64_max_c_def : thm val main_fwd_def : thm val betreeMain_Funs_grammars : type_grammar.grammar * term_grammar.grammar @@ -1215,22 +1213,14 @@ sig case st of BetreeUpsertFunStateAdd v => do - margin <- u64_sub core_num_u64_max_c prev0; + margin <- u64_sub core_u64_max prev0; if u64_ge margin v then u64_add prev0 v - else Return core_num_u64_max_c + else Return core_u64_max od | BetreeUpsertFunStateSub v' => if u64_ge prev0 v' then u64_sub prev0 v' else Return (int_to_u64 0) - [core_num_u64_max_body_def] Definition - - ⊢ core_num_u64_max_body = Return (int_to_u64 18446744073709551615) - - [core_num_u64_max_c_def] Definition - - ⊢ core_num_u64_max_c = get_return_value core_num_u64_max_body - [main_fwd_def] Definition ⊢ main_fwd = Return () diff --git a/tests/hol4/hashmap/hashmap_FunsScript.sml b/tests/hol4/hashmap/hashmap_FunsScript.sml index e3c3d2a5..682c5760 100644 --- a/tests/hol4/hashmap/hashmap_FunsScript.sml +++ b/tests/hol4/hashmap/hashmap_FunsScript.sml @@ -170,14 +170,6 @@ val hash_map_insert_no_resize_fwd_back_def = Define ‘ od ’ -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body_def: - core_num_u32_max_body : u32 result = Return (int_to_u32 4294967295) -End -Definition core_num_u32_max_c_def: - core_num_u32_max_c : u32 = get_return_value core_num_u32_max_body -End - val [hash_map_move_elements_from_list_loop_fwd_back_def] = DefineDiv ‘ (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) @@ -241,7 +233,7 @@ val hash_map_try_resize_fwd_back_def = Define ‘ (there is a single backward function, and the forward function returns ()) *) hash_map_try_resize_fwd_back (self : 't hash_map_t) : 't hash_map_t result = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); let capacity = vec_len self.hash_map_slots in do n1 <- usize_div max_usize (int_to_usize 2); diff --git a/tests/hol4/hashmap/hashmap_FunsTheory.sig b/tests/hol4/hashmap/hashmap_FunsTheory.sig index 50482547..bb3e192b 100644 --- a/tests/hol4/hashmap/hashmap_FunsTheory.sig +++ b/tests/hol4/hashmap/hashmap_FunsTheory.sig @@ -3,8 +3,6 @@ sig type thm = Thm.thm (* Definitions *) - val core_num_u32_max_body_def : thm - val core_num_u32_max_c_def : thm val hash_key_fwd_def : thm val hash_map_allocate_slots_fwd_def : thm val hash_map_allocate_slots_loop_fwd_def : thm @@ -48,14 +46,6 @@ sig (* [hashmap_Types] Parent theory of "hashmap_Funs" - [core_num_u32_max_body_def] Definition - - ⊢ core_num_u32_max_body = Return (int_to_u32 4294967295) - - [core_num_u32_max_c_def] Definition - - ⊢ core_num_u32_max_c = get_return_value core_num_u32_max_body - [hash_key_fwd_def] Definition ⊢ ∀k. hash_key_fwd k = Return k @@ -472,7 +462,7 @@ sig ⊢ ∀self. hash_map_try_resize_fwd_back self = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); capacity <<- vec_len self.hash_map_slots; n1 <- usize_div max_usize (int_to_usize 2); (i,i0) <<- self.hash_map_max_load_factor; diff --git a/tests/hol4/hashmap/hashmap_PropertiesScript.sml b/tests/hol4/hashmap/hashmap_PropertiesScript.sml index 7259f2f5..8bc12fa5 100644 --- a/tests/hol4/hashmap/hashmap_PropertiesScript.sml +++ b/tests/hol4/hashmap/hashmap_PropertiesScript.sml @@ -1296,7 +1296,7 @@ Proof rw [hash_map_try_resize_fwd_back_def] >> (* “_ <-- mk_usize (u32_to_int core_num_u32_max_c)” *) assume_tac usize_u32_bounds >> - fs [core_num_u32_max_c_def, core_num_u32_max_body_def, get_return_value_def, u32_max_def] >> + fs [core_u32_max_def, u32_max_def] >> massage >> fs [mk_usize_def, u32_max_def] >> (* / 2 *) progress >> diff --git a/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml b/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml index b21c4f58..c1e30aa6 100644 --- a/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml +++ b/tests/hol4/hashmap_on_disk/hashmapMain_FunsScript.sml @@ -193,14 +193,6 @@ val hashmap_hash_map_insert_no_resize_fwd_back_def = Define ‘ od ’ -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body_def: - core_num_u32_max_body : u32 result = Return (int_to_u32 4294967295) -End -Definition core_num_u32_max_c_def: - core_num_u32_max_c : u32 = get_return_value core_num_u32_max_body -End - val [hashmap_hash_map_move_elements_from_list_loop_fwd_back_def] = DefineDiv ‘ (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) @@ -271,7 +263,7 @@ val hashmap_hash_map_try_resize_fwd_back_def = Define ‘ hashmap_hash_map_try_resize_fwd_back (self : 't hashmap_hash_map_t) : 't hashmap_hash_map_t result = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); let capacity = vec_len self.hashmap_hash_map_slots in do n1 <- usize_div max_usize (int_to_usize 2); diff --git a/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig b/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig index 1d24cb26..d4e43d9a 100644 --- a/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig +++ b/tests/hol4/hashmap_on_disk/hashmapMain_FunsTheory.sig @@ -3,8 +3,6 @@ sig type thm = Thm.thm (* Definitions *) - val core_num_u32_max_body_def : thm - val core_num_u32_max_c_def : thm val hashmap_hash_key_fwd_def : thm val hashmap_hash_map_allocate_slots_fwd_def : thm val hashmap_hash_map_allocate_slots_loop_fwd_def : thm @@ -50,14 +48,6 @@ sig (* [hashmapMain_Opaque] Parent theory of "hashmapMain_Funs" - [core_num_u32_max_body_def] Definition - - ⊢ core_num_u32_max_body = Return (int_to_u32 4294967295) - - [core_num_u32_max_c_def] Definition - - ⊢ core_num_u32_max_c = get_return_value core_num_u32_max_body - [hashmap_hash_key_fwd_def] Definition ⊢ ∀k. hashmap_hash_key_fwd k = Return k @@ -506,7 +496,7 @@ sig ⊢ ∀self. hashmap_hash_map_try_resize_fwd_back self = do - max_usize <- mk_usize (u32_to_int core_num_u32_max_c); + max_usize <- mk_usize (u32_to_int core_u32_max); capacity <<- vec_len self.hashmap_hash_map_slots; n1 <- usize_div max_usize (int_to_usize 2); (i,i0) <<- self.hashmap_hash_map_max_load_factor; diff --git a/tests/hol4/misc-constants/constantsScript.sml b/tests/hol4/misc-constants/constantsScript.sml index d589d348..40a319c6 100644 --- a/tests/hol4/misc-constants/constantsScript.sml +++ b/tests/hol4/misc-constants/constantsScript.sml @@ -13,17 +13,9 @@ Definition x0_c_def: x0_c : u32 = get_return_value x0_body End -(** [core::num::u32::{8}::MAX] *) -Definition core_num_u32_max_body_def: - core_num_u32_max_body : u32 result = Return (int_to_u32 4294967295) -End -Definition core_num_u32_max_c_def: - core_num_u32_max_c : u32 = get_return_value core_num_u32_max_body -End - (** [constants::X1] *) Definition x1_body_def: - x1_body : u32 result = Return core_num_u32_max_c + x1_body : u32 result = Return core_u32_max End Definition x1_c_def: x1_c : u32 = get_return_value x1_body diff --git a/tests/hol4/misc-constants/constantsTheory.sig b/tests/hol4/misc-constants/constantsTheory.sig index 149d7e22..287ad5f5 100644 --- a/tests/hol4/misc-constants/constantsTheory.sig +++ b/tests/hol4/misc-constants/constantsTheory.sig @@ -4,8 +4,6 @@ sig (* Definitions *) val add_fwd_def : thm - val core_num_u32_max_body_def : thm - val core_num_u32_max_c_def : thm val get_z1_fwd_def : thm val get_z1_z1_body_def : thm val get_z1_z1_c_def : thm @@ -110,14 +108,6 @@ sig ⊢ ∀a b. add_fwd a b = i32_add a b - [core_num_u32_max_body_def] Definition - - ⊢ core_num_u32_max_body = Return (int_to_u32 4294967295) - - [core_num_u32_max_c_def] Definition - - ⊢ core_num_u32_max_c = get_return_value core_num_u32_max_body - [get_z1_fwd_def] Definition ⊢ get_z1_fwd = Return get_z1_z1_c @@ -321,7 +311,7 @@ sig [x1_body_def] Definition - ⊢ x1_body = Return core_num_u32_max_c + ⊢ x1_body = Return core_u32_max [x1_c_def] Definition diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 07ef08dc..6681731f 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -64,11 +64,6 @@ def betree.NodeIdCounter.fresh_id_back let i ← self.next_node_id + (U64.ofInt 1) Result.ret { next_node_id := i } -/- [core::num::u64::{9}::MAX] -/ -def core_num_u64_max_body : Result U64 := - Result.ret (U64.ofInt 18446744073709551615) -def core_num_u64_max_c : U64 := eval_global core_num_u64_max_body (by simp) - /- [betree_main::betree::upsert_update]: forward function -/ def betree.upsert_update (prev : Option U64) (st : betree.UpsertFunState) : Result U64 := @@ -81,10 +76,10 @@ def betree.upsert_update match st with | betree.UpsertFunState.Add v => do - let margin ← core_num_u64_max_c - prev0 + let margin ← core_u64_max - prev0 if margin >= v then prev0 + v - else Result.ret core_num_u64_max_c + else Result.ret core_u64_max | betree.UpsertFunState.Sub v => if prev0 >= v then prev0 - v diff --git a/tests/lean/Constants.lean b/tests/lean/Constants.lean index 51b415d6..b0cdaa90 100644 --- a/tests/lean/Constants.lean +++ b/tests/lean/Constants.lean @@ -9,12 +9,8 @@ namespace constants def x0_body : Result U32 := Result.ret (U32.ofInt 0) def x0_c : U32 := eval_global x0_body (by simp) -/- [core::num::u32::{8}::MAX] -/ -def core_num_u32_max_body : Result U32 := Result.ret (U32.ofInt 4294967295) -def core_num_u32_max_c : U32 := eval_global core_num_u32_max_body (by simp) - /- [constants::X1] -/ -def x1_body : Result U32 := Result.ret core_num_u32_max_c +def x1_body : Result U32 := Result.ret core_u32_max def x1_c : U32 := eval_global x1_body (by simp) /- [constants::X2] -/ diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index 30b30e0b..01c61de4 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -132,10 +132,6 @@ def HashMap.insert_no_resize let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 Result.ret { self with slots := v } -/- [core::num::u32::{8}::MAX] -/ -def core_num_u32_max_body : Result U32 := Result.ret (U32.ofInt 4294967295) -def core_num_u32_max_c : U32 := eval_global core_num_u32_max_body (by simp) - /- [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.move_elements_from_list_loop @@ -184,7 +180,7 @@ def HashMap.move_elements (there is a single backward function, and the forward function returns ()) -/ def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := do - let max_usize ← Scalar.cast .Usize core_num_u32_max_c + let max_usize ← Scalar.cast .Usize core_u32_max let capacity := Vec.len (List T) self.slots let n1 ← max_usize / (Usize.ofInt 2) let (i, i0) := self.max_load_factor diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index aec957ec..848b1a35 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -147,10 +147,6 @@ def hashmap.HashMap.insert_no_resize let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 Result.ret { self with slots := v } -/- [core::num::u32::{8}::MAX] -/ -def core_num_u32_max_body : Result U32 := Result.ret (U32.ofInt 4294967295) -def core_num_u32_max_c : U32 := eval_global core_num_u32_max_body (by simp) - /- [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.move_elements_from_list_loop @@ -206,7 +202,7 @@ def hashmap.HashMap.move_elements def hashmap.HashMap.try_resize (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do - let max_usize ← Scalar.cast .Usize core_num_u32_max_c + let max_usize ← Scalar.cast .Usize core_u32_max let capacity := Vec.len (hashmap.List T) self.slots let n1 ← max_usize / (Usize.ofInt 2) let (i, i0) := self.max_load_factor -- 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(-) 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(-) 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(-) 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 ------------------------------------- tests/lean/Hashmap/Properties.lean | 8 +++----- 6 files changed, 41 insertions(+), 52 deletions(-) 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) diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index ab95b854..6bc821d3 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -303,19 +303,17 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value | some _ => nhm.len_s = hm.len_s) := by rw [insert_no_resize] simp only [hash_key, bind_tc_ret] -- TODO: annoying - have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by checkpoint + have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by intro simp_all [inv] - progress keep _ as ⟨ hash_mod, hhm ⟩ - have _ : 0 ≤ hash_mod.val := by checkpoint scalar_tac + progress as ⟨ hash_mod, hhm ⟩ + have _ : 0 ≤ hash_mod.val := by scalar_tac have _ : hash_mod.val < Vec.length hm.slots := by have : 0 < hm.slots.val.len := by simp [inv] at hinv simp [hinv] -- TODO: we want to automate that simp [*, Int.emod_lt_of_pos] - -- TODO: change the spec of Vec.index_mut to introduce a let-binding. - -- or: make progress introduce the let-binding by itself (this is clearer) progress as ⟨ l, h_leq ⟩ -- TODO: make progress use the names written in the goal progress as ⟨ inserted ⟩ -- 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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 e75879992c5a5a5102a4c5f20b90e6a1032b8ec5 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 22 Sep 2023 16:40:31 +0200 Subject: Add support for Shl/Shr typechecking in InterpreterExpressions --- compiler/InterpreterExpressions.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 8b2070c6..469bebec 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -523,7 +523,10 @@ let eval_binary_op_symbolic (config : C.config) (binop : E.binop) | E.BitOr -> assert (int_ty1 = int_ty2); T.Literal (Integer int_ty1) - | E.Shl | E.Shr -> raise Unimplemented + | E.Shl | E.Shr -> + (* The number of bits can be of a different integer type + than the operand *) + T.Literal (Integer int_ty1) | E.Ne | E.Eq -> raise (Failure "Unreachable")) | _ -> raise (Failure "Invalid inputs for binop") in -- cgit v1.2.3 From a5f87ba02342ae0b96fe0d8ba16f1ec78469d760 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 22 Sep 2023 16:48:37 +0200 Subject: Allow bitshifts with any pair of integer types --- compiler/SymbolicToPure.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 3512270a..08f67592 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -1542,7 +1542,11 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : | [ arg0; arg1 ] -> let int_ty0 = ty_as_integer arg0.ty in let int_ty1 = ty_as_integer arg1.ty in - assert (int_ty0 = int_ty1); + (match binop with + (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) + | E.Shl | E.Shr -> () + | _ -> assert (int_ty0 = int_ty1) + ); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; -- cgit v1.2.3 From f4e2c2bb09d9d7b54afc0692b7f690f5ec2eb029 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 22 Sep 2023 17:27:54 +0200 Subject: Add Lean extraction of shl/shr --- compiler/Extract.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index c4238d83..61856f0a 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -472,7 +472,7 @@ let extract_binop (extract_expr : bool -> texpression -> unit) (match (!backend, binop) with | HOL4, (Eq | Ne) | (FStar | Coq | Lean), (Eq | Lt | Le | Ne | Ge | Gt) - | Lean, (Div | Rem | Add | Sub | Mul) -> + | Lean, (Div | Rem | Add | Sub | Mul | Shl | Shr) -> let binop = match binop with | Eq -> "=" @@ -486,6 +486,8 @@ let extract_binop (extract_expr : bool -> texpression -> unit) | Add -> "+" | Sub -> "-" | Mul -> "*" + | Shl -> "<<<" + | Shr -> ">>>" | _ -> raise (Failure "Unreachable") in let binop = -- cgit v1.2.3 From 4a76a074820a6ba23cfb0f33cd67b2d7964ac407 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 5 Oct 2023 12:44:53 +0200 Subject: Add a mention to the Zulip in the README --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 768c4277..c0a09ebe 100644 --- a/README.md +++ b/README.md @@ -17,6 +17,8 @@ internal language to a pure lamdba calculus. It is intended to be used in combi representation called LLBC. It currently has backends for [F\*](https://www.fstar-lang.org), [Coq](https://coq.inria.fr/), [HOL4](https://hol-theorem-prover.org/) and [LEAN](https://leanprover.github.io/). +If you want to contribute or ask questions, we strongly encourage you to join the [Zulip](https://aeneas-verif.zulipchat.com/). + ## Project Structure - `src`: the OCaml sources. Note that we rely on [Dune](https://github.com/ocaml/dune) -- cgit v1.2.3 From e684179ff9c582495b720c3b1310e0648ca24a58 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 6 Oct 2023 12:13:38 +0200 Subject: Generate the Traits test files for Lean --- tests/lean/Traits.lean | 1 + tests/lean/Traits/Funs.lean | 232 +++++++++++++++++++++++++++++++++++++++++++ tests/lean/Traits/Types.lean | 86 ++++++++++++++++ tests/lean/lakefile.lean | 1 + 4 files changed, 320 insertions(+) create mode 100644 tests/lean/Traits.lean create mode 100644 tests/lean/Traits/Funs.lean create mode 100644 tests/lean/Traits/Types.lean diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean new file mode 100644 index 00000000..5e812e95 --- /dev/null +++ b/tests/lean/Traits.lean @@ -0,0 +1 @@ +import Traits.Funs diff --git a/tests/lean/Traits/Funs.lean b/tests/lean/Traits/Funs.lean new file mode 100644 index 00000000..52ff0c0a --- /dev/null +++ b/tests/lean/Traits/Funs.lean @@ -0,0 +1,232 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [traits]: function definitions +import Base +import Traits.Types +open Primitives + +namespace traits + +/- [traits::Bool::{0}::get_bool]: forward function -/ +def Bool.get_bool (self : Bool) : Result Bool := + Result.ret self + +/- Trait implementation: [traits::Bool::{0}] -/ +def Bool.BoolTraitInst : BoolTrait Bool := { + get_bool := Bool.get_bool +} + +/- [traits::BoolTrait::ret_true]: forward function -/ +def BoolTrait.ret_true + {Self : Type} (self_clause : BoolTrait Self) (self : Self) : Result Bool := + Result.ret true + +/- [traits::test_bool_trait_bool]: forward function -/ +def test_bool_trait_bool (x : Bool) : Result Bool := + do + let b ← Bool.get_bool x + if b + then BoolTrait.ret_true Bool.BoolTraitInst x + else Result.ret false + +/- [traits::Option::{1}::get_bool]: forward function -/ +def Option.get_bool (T : Type) (self : Option T) : Result Bool := + match self with + | Option.none => Result.ret false + | Option.some t => Result.ret true + +/- Trait implementation: [traits::Option::{1}] -/ +def Option.BoolTraitInst (T : Type) : BoolTrait (Option T) := { + get_bool := Option.get_bool T +} + +/- [traits::test_bool_trait_option]: forward function -/ +def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := + do + let b ← Option.get_bool T x + if b + then BoolTrait.ret_true (Option.BoolTraitInst T) x + else Result.ret false + +/- [traits::test_bool_trait]: forward function -/ +def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := + inst.get_bool x + +/- [traits::u64::{2}::to_u64]: forward function -/ +def u64.to_u64 (self : U64) : Result U64 := + Result.ret self + +/- Trait implementation: [traits::u64::{2}] -/ +def u64.ToU64Inst : ToU64 U64 := { + to_u64 := u64.to_u64 +} + +/- [traits::Tuple2::{3}::to_u64]: forward function -/ +def Tuple2.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := + do + let (t, t0) := self + let i ← inst.to_u64 t + let i0 ← inst.to_u64 t0 + i + i0 + +/- Trait implementation: [traits::Tuple2::{3}] -/ +def Tuple2.ToU64Inst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { + to_u64 := Tuple2.to_u64 A inst +} + +/- [traits::f]: forward function -/ +def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := + Tuple2.to_u64 T inst x + +/- [traits::g]: forward function -/ +def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := + inst.to_u64 x + +/- [traits::h0]: forward function -/ +def h0 (x : U64) : Result U64 := + u64.to_u64 x + +/- [traits::Wrapper::{4}::to_u64]: forward function -/ +def Wrapper.to_u64 + (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := + inst.to_u64 self.x + +/- Trait implementation: [traits::Wrapper::{4}] -/ +def Wrapper.ToU64Inst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper T) := { + to_u64 := Wrapper.to_u64 T inst +} + +/- [traits::h1]: forward function -/ +def h1 (x : Wrapper U64) : Result U64 := + Wrapper.to_u64 U64 u64.ToU64Inst x + +/- [traits::h2]: forward function -/ +def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := + Wrapper.to_u64 T inst x + +/- [traits::u64::{5}::to_type]: forward function -/ +def u64.to_type (self : U64) : Result Bool := + Result.ret (self > (U64.ofInt 0)) + +/- Trait implementation: [traits::u64::{5}] -/ +def u64.ToTypeInst : ToType U64 Bool := { + to_type := u64.to_type +} + +/- [traits::h3]: forward function -/ +def h3 + (T1 T2 : Type) (inst : OfType T1) (inst0 : ToType T2 T1) (y : T2) : + Result T1 + := + inst.of_type T2 inst0 y + +/- [traits::h4]: forward function -/ +def h4 + (T1 T2 : Type) (inst : OfTypeBis T1 T2) (inst0 : ToType T2 T1) (y : T2) : + Result T1 + := + inst.of_type y + +/- [traits::TestType::{6}::test::TestType1::{0}::test]: forward function -/ +def TestType.test.TestType1.test + (self : TestType.test.TestType1) : Result Bool := + Result.ret (self._0 > (U64.ofInt 1)) + +/- Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] -/ +def TestType.test.TestType1.TestTypetestTestTraitInst : TestType.test.TestTrait + TestType.test.TestType1 := { + test := TestType.test.TestType1.test +} + +/- [traits::TestType::{6}::test]: forward function -/ +def TestType.test + (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := + do + let x0 ← inst.to_u64 x + if x0 > (U64.ofInt 0) + then TestType.test.TestType1.test { _0 := (U64.ofInt 0) } + else Result.ret false + +/- [traits::BoolWrapper::{7}::to_type]: forward function -/ +def BoolWrapper.to_type + (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := + inst.to_type self._0 + +/- Trait implementation: [traits::BoolWrapper::{7}] -/ +def BoolWrapper.ToTypeInst (T : Type) (inst : ToType Bool T) : ToType + BoolWrapper T := { + to_type := BoolWrapper.to_type T inst +} + +/- [traits::WithConstTy::LEN2] -/ +def with_const_ty_len2_body : Result Usize := Result.ret (Usize.ofInt 32) +def with_const_ty_len2_c : Usize := + eval_global with_const_ty_len2_body (by simp) + +/- [traits::Bool::{8}::LEN1] -/ +def bool_len1_body : Result Usize := Result.ret (Usize.ofInt 12) +def bool_len1_c : Usize := eval_global bool_len1_body (by simp) + +/- [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def Bool.f (i : U64) (a : Array U8 (Usize.ofInt 32)) : Result U64 := + Result.ret i + +/- Trait implementation: [traits::Bool::{8}] -/ +def Bool.WithConstTyInst : WithConstTy Bool (Usize.ofInt 32) := { + LEN1 := bool_len1_c + LEN2 := with_const_ty_len2_c + V := U8 + W := U64 + W_clause_0 := u64.ToU64Inst + f := Bool.f +} + +/- [traits::use_with_const_ty1]: forward function -/ +def use_with_const_ty1 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) : Result Usize := + let i := inst.LEN1 + Result.ret i + +/- [traits::use_with_const_ty2]: forward function -/ +def use_with_const_ty2 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (w : inst.W) : + Result Unit + := + Result.ret () + +/- [traits::use_with_const_ty3]: forward function -/ +def use_with_const_ty3 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (x : inst.W) : + Result U64 + := + inst.W_clause_0.to_u64 x + +/- [traits::test_where1]: forward function -/ +def test_where1 (T : Type) (_x : T) : Result Unit := + Result.ret () + +/- [traits::test_where2]: forward function -/ +def test_where2 + (T : Type) (inst : WithConstTy T (Usize.ofInt 32)) (_x : U32) : + Result Unit + := + Result.ret () + +/- [traits::test_child_trait1]: forward function -/ +def test_child_trait1 + (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := + inst.parent_clause_0.get_name x + +/- [traits::test_child_trait2]: forward function -/ +def test_child_trait2 + (T : Type) (inst : ChildTrait T) (x : T) : Result inst.parent_clause_0.W := + inst.parent_clause_0.get_w x + +/- [traits::order1]: forward function -/ +def order1 + (T U : Type) (inst : ParentTrait0 T) (inst0 : ParentTrait0 U) : + Result Unit + := + Result.ret () + +end traits diff --git a/tests/lean/Traits/Types.lean b/tests/lean/Traits/Types.lean new file mode 100644 index 00000000..b3a52346 --- /dev/null +++ b/tests/lean/Traits/Types.lean @@ -0,0 +1,86 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [traits]: type definitions +import Base +open Primitives + +namespace traits + +/- Trait declaration: [traits::BoolTrait] -/ +structure BoolTrait (Self : Type) where + get_bool : Self → Result Bool + +/- Trait declaration: [traits::ToU64] -/ +structure ToU64 (Self : Type) where + to_u64 : Self → Result U64 + +/- [traits::Wrapper] -/ +structure Wrapper (T : Type) where + x : T + +/- Trait declaration: [traits::ToType] -/ +structure ToType (Self T : Type) where + to_type : Self → Result T + +/- Trait declaration: [traits::OfType] -/ +structure OfType (Self : Type) where + of_type : forall (T : Type) (inst : ToType T Self), T → Result Self + +/- Trait declaration: [traits::OfTypeBis] -/ +structure OfTypeBis (Self T : Type) where + parent_clause_0 :ToType T Self + of_type : T → Result Self + +/- [traits::TestType] -/ +structure TestType (T : Type) where + _0 : T + +/- [traits::TestType::{6}::test::TestType1] -/ +structure TestType.test.TestType1 where + _0 : U64 + +/- Trait declaration: [traits::TestType::{6}::test::TestTrait] -/ +structure TestType.test.TestTrait (Self : Type) where + test : Self → Result Bool + +/- [traits::BoolWrapper] -/ +structure BoolWrapper where + _0 : Bool + +/- Trait declaration: [traits::WithConstTy] -/ +structure WithConstTy (Self : Type) (LEN : Usize) where + LEN1 :Usize + LEN2 :Usize + V :Type + W :Type + W_clause_0 :ToU64 W + f : W → Array U8 LEN → Result W + +/- [alloc::string::String] -/ +axiom alloc.string.String : Type + +/- Trait declaration: [traits::ParentTrait0] -/ +structure ParentTrait0 (Self : Type) where + W :Type + get_name : Self → Result alloc.string.String + get_w : Self → Result W + +/- Trait declaration: [traits::ParentTrait1] -/ +structure ParentTrait1 (Self : Type) where + +/- Trait declaration: [traits::ChildTrait] -/ +structure ChildTrait (Self : Type) where + parent_clause_0 :ParentTrait0 Self + parent_clause_1 :ParentTrait1 Self + +/- Trait declaration: [traits::Iterator] -/ +structure Iterator (Self : Type) where + Item :Type + +/- Trait declaration: [traits::IntoIterator] -/ +structure IntoIterator (Self : Type) where + Item :Type + IntoIter :Type + IntoIter_clause_0 :Iterator IntoIter + into_iter : Self → Result IntoIter + +end traits diff --git a/tests/lean/lakefile.lean b/tests/lean/lakefile.lean index cc63c48f..1747c581 100644 --- a/tests/lean/lakefile.lean +++ b/tests/lean/lakefile.lean @@ -18,3 +18,4 @@ package «tests» {} @[default_target] lean_lib paper @[default_target] lean_lib poloniusList @[default_target] lean_lib array +@[default_target] lean_lib traits -- 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 ++++++- tests/lean/Traits/Types.lean | 20 ++++++++++---------- 2 files changed, 16 insertions(+), 11 deletions(-) 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) diff --git a/tests/lean/Traits/Types.lean b/tests/lean/Traits/Types.lean index b3a52346..a8c12fe5 100644 --- a/tests/lean/Traits/Types.lean +++ b/tests/lean/Traits/Types.lean @@ -48,11 +48,11 @@ structure BoolWrapper where /- Trait declaration: [traits::WithConstTy] -/ structure WithConstTy (Self : Type) (LEN : Usize) where - LEN1 :Usize - LEN2 :Usize - V :Type - W :Type - W_clause_0 :ToU64 W + LEN1 : Usize + LEN2 : Usize + V : Type + W : Type + W_clause_0 : ToU64 W f : W → Array U8 LEN → Result W /- [alloc::string::String] -/ @@ -60,7 +60,7 @@ axiom alloc.string.String : Type /- Trait declaration: [traits::ParentTrait0] -/ structure ParentTrait0 (Self : Type) where - W :Type + W : Type get_name : Self → Result alloc.string.String get_w : Self → Result W @@ -74,13 +74,13 @@ structure ChildTrait (Self : Type) where /- Trait declaration: [traits::Iterator] -/ structure Iterator (Self : Type) where - Item :Type + Item : Type /- Trait declaration: [traits::IntoIterator] -/ structure IntoIterator (Self : Type) where - Item :Type - IntoIter :Type - IntoIter_clause_0 :Iterator IntoIter + Item : Type + IntoIter : Type + IntoIter_clause_0 : Iterator IntoIter into_iter : Self → Result IntoIter end traits -- 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 --- backends/coq/Primitives.v | 3 ++ backends/lean/Base/IList/IList.lean | 57 +++++++++++++++++++++++++++++++- backends/lean/Base/Primitives/Array.lean | 9 +++++ compiler/Assumed.ml | 15 +++++++++ compiler/Driver.ml | 2 ++ compiler/Extract.ml | 4 ++- compiler/InterpreterStatements.ml | 2 +- compiler/PrintPure.ml | 1 + compiler/PureMicroPasses.ml | 2 +- 9 files changed, 91 insertions(+), 4 deletions(-) diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 8d6c9c8d..b92eb967 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -433,6 +433,9 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. +(* For initialization *) +Axiom array_repeat : forall {T : Type} (n : usize) (x : T), array T n. + Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index 0b483e90..f10ec4e7 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -112,7 +112,19 @@ def pairwise_rel section Lemmas -variable {α : Type u} +variable {α : Type u} + +def ireplicate {α : Type u} (i : ℤ) (x : α) : List α := + if i ≤ 0 then [] + else x :: ireplicate (i - 1) x +termination_by ireplicate i x => i.toNat +decreasing_by + simp_wf + -- TODO: simplify this kind of proofs + simp at * + have : 0 ≤ i := by linarith + have : 1 ≤ i := by linarith + simp [Int.toNat_sub_of_le, *] @[simp] theorem update_nil : update ([] : List α) i y = [] := by simp [update] @[simp] theorem update_zero_cons : update ((x :: tl) : List α) 0 y = y :: tl := by simp [update] @@ -129,6 +141,10 @@ variable {α : Type u} @[simp] theorem slice_nil : slice i j ([] : List α) = [] := by simp [slice] @[simp] theorem slice_zero : slice 0 0 (ls : List α) = [] := by cases ls <;> simp [slice] +@[simp] theorem ireplicate_zero : ireplicate 0 x = [] := by rw [ireplicate]; simp +@[simp] theorem ireplicate_nzero_cons (hne : 0 < i) : ireplicate i x = x :: ireplicate (i - 1) x := by + rw [ireplicate]; simp [*]; intro; linarith + @[simp] theorem slice_nzero_cons (i j : Int) (x : α) (tl : List α) (hne : i ≠ 0) : slice i j ((x :: tl) : List α) = slice (i - 1) (j - 1) tl := match tl with @@ -144,6 +160,45 @@ theorem slice_nzero_cons (i j : Int) (x : α) (tl : List α) (hne : i ≠ 0) : s conv at this => lhs; simp [slice, *] simp [*, slice] +@[simp] +theorem ireplicate_replicate {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : + ireplicate l x = replicate l.toNat x := + if hz: l = 0 then by + simp [*] + else by + have : 0 < l := by int_tac + have hr := ireplicate_replicate (l - 1) x (by int_tac) + simp [*] + have hl : l.toNat = .succ (l.toNat - 1) := by + cases hl: l.toNat <;> simp_all + conv => rhs; rw[hl] +termination_by ireplicate_replicate l x h => l.toNat +decreasing_by + simp_wf + -- TODO: simplify this kind of proofs + simp at * + have : 0 ≤ l := by linarith + have : 1 ≤ l := by linarith + simp [Int.toNat_sub_of_le, *] + +@[simp] +theorem ireplicate_len {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : + (ireplicate l x).len = l := + if hz: l = 0 then by + simp [*] + else by + have : 0 < l := by int_tac + have hr := ireplicate_len (l - 1) x (by int_tac) + simp [*] +termination_by ireplicate_len l x h => l.toNat +decreasing_by + simp_wf + -- TODO: simplify this kind of proofs + simp at * + have : 0 ≤ l := by linarith + have : 1 ≤ l := by linarith + simp [Int.toNat_sub_of_le, *] + theorem len_eq_length (ls : List α) : ls.len = ls.length := by induction ls . rfl diff --git a/backends/lean/Base/Primitives/Array.lean b/backends/lean/Base/Primitives/Array.lean index 6c95fd78..49c84bee 100644 --- a/backends/lean/Base/Primitives/Array.lean +++ b/backends/lean/Base/Primitives/Array.lean @@ -51,6 +51,15 @@ def Array.index_shared (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Re | none => fail .arrayOutOfBounds | some x => ret x +-- For initialization +def Array.repeat (α : Type u) (n : Usize) (x : α) : Array α n := + ⟨ List.ireplicate n.val x, by have h := n.hmin; simp_all [Scalar.min] ⟩ + +@[pspec] +theorem Array.repeat_spec {α : Type u} (n : Usize) (x : α) : + ∃ a, Array.repeat α n x = a ∧ a.val = List.ireplicate n.val x := by + simp [Array.repeat] + /- In the theorems below: we don't always need the `∃ ..`, but we use one so that `progress` introduces an opaque variable and an equality. This helps control the context. 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 bb37801b3922f617302f5ffe25e8c8e7c0734b08 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 13 Oct 2023 00:40:46 +0200 Subject: Add support for array repeat --- tests/lean/Array/Funs.lean | 33 +++++++-------------------------- 1 file changed, 7 insertions(+), 26 deletions(-) diff --git a/tests/lean/Array/Funs.lean b/tests/lean/Array/Funs.lean index a42072d1..d3cb29d2 100644 --- a/tests/lean/Array/Funs.lean +++ b/tests/lean/Array/Funs.lean @@ -53,16 +53,6 @@ def index_array_u32 (s : Array U32 (Usize.ofInt 32)) (i : Usize) : Result U32 := Array.index_shared U32 (Usize.ofInt 32) s i -/- [array::index_array_generic]: forward function -/ -def index_array_generic - (N : Usize) (s : Array U32 N) (i : Usize) : Result U32 := - Array.index_shared U32 N s i - -/- [array::index_array_generic_call]: forward function -/ -def index_array_generic_call - (N : Usize) (s : Array U32 N) (i : Usize) : Result U32 := - index_array_generic N s i - /- [array::index_array_copy]: forward function -/ def index_array_copy (x : Array U32 (Usize.ofInt 32)) : Result U32 := Array.index_shared U32 (Usize.ofInt 32) x (Usize.ofInt 0) @@ -166,10 +156,6 @@ def index_index_array Array.index_shared (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i Array.index_shared U32 (Usize.ofInt 32) a j -/- [array::const_gen_ret]: forward function -/ -def const_gen_ret (N : Usize) : Result Usize := - Result.ret N - /- [array::update_update_array]: forward function -/ def update_update_array (s : Array (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32)) (i : Usize) @@ -430,21 +416,11 @@ def f3 : Result U32 := (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) (Usize.ofInt 0) let _ ← f2 i + let b := Array.repeat U32 (Usize.ofInt 32) (U32.ofInt 0) let s ← Array.to_slice_shared U32 (Usize.ofInt 2) (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - let s0 ← - f4 - (Array.make U32 (Usize.ofInt 32) [ - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0) - ]) (Usize.ofInt 16) (Usize.ofInt 18) + let s0 ← f4 b (Usize.ofInt 16) (Usize.ofInt 18) sum2 s s0 /- [array::SZ] -/ @@ -474,4 +450,9 @@ def ite : Result Unit := (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s2 Result.ret () +/- [array::array]: forward function -/ +def array (LEN : Usize) : Result (Array U8 LEN) := + let a := Array.repeat U8 LEN (U8.ofInt 0) + Result.ret a + end array -- cgit v1.2.3 From 8ac8d00b2958d007facb5162196831d0a2138db8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 13 Oct 2023 10:31:06 +0200 Subject: Update Primitives.fst --- backends/fstar/Primitives.fst | 3 +++ 1 file changed, 3 insertions(+) diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index cd18cf29..e9391834 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -352,6 +352,9 @@ let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range us let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = admit() +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = + admit() + let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = admit() -- 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(-) 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 --- backends/lean/Base/Primitives/Scalar.lean | 15 ++++++++++++++ compiler/Extract.ml | 33 ++++++++++--------------------- 2 files changed, 25 insertions(+), 23 deletions(-) diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index 6e7733a7..9e65d3c0 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -764,6 +764,21 @@ def U32.ofInt := @Scalar.ofInt .U32 def U64.ofInt := @Scalar.ofInt .U64 def U128.ofInt := @Scalar.ofInt .U128 +postfix:74 "%isize" => Isize.ofInt +postfix:74 "%i8" => I8.ofInt +postfix:74 "%i16" => I16.ofInt +postfix:74 "%i32" => I32.ofInt +postfix:74 "%i64" => I64.ofInt +postfix:74 "%i128" => I128.ofInt +postfix:74 "%usize" => Usize.ofInt +postfix:74 "%u8" => U8.ofInt +postfix:74 "%u16" => U16.ofInt +postfix:74 "%u32" => U32.ofInt +postfix:74 "%u64" => U64.ofInt +postfix:74 "%u128" => U128.ofInt + +example : Result U32 := 1%u32 + 2%u32 + -- TODO: factor those lemmas out @[simp] theorem Scalar.ofInt_val_eq {ty} (h : Scalar.min ty ≤ x ∧ x ≤ Scalar.max ty) : (Scalar.ofInt x h).val = x := by simp [Scalar.ofInt, Scalar.ofIntCore] 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 584726e9c4e4378129a35f6cfbbbf934448d10a9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 17 Oct 2023 09:36:55 +0200 Subject: Implement tactics for termination proofs which involve arithmetic --- backends/lean/Base/Arith/Base.lean | 12 ++++++++++++ backends/lean/Base/Arith/Int.lean | 11 +++++++++++ backends/lean/Base/Arith/Scalar.lean | 11 +++++++++++ backends/lean/Base/IList/IList.lean | 24 +++--------------------- 4 files changed, 37 insertions(+), 21 deletions(-) diff --git a/backends/lean/Base/Arith/Base.lean b/backends/lean/Base/Arith/Base.lean index 9c11ed45..8ada4171 100644 --- a/backends/lean/Base/Arith/Base.lean +++ b/backends/lean/Base/Arith/Base.lean @@ -57,4 +57,16 @@ theorem int_pos_ind (p : Int → Prop) : -- TODO: there is probably something more general to do theorem nat_zero_eq_int_zero : (0 : Nat) = (0 : Int) := by simp +-- This is mostly used in termination proofs +theorem to_int_to_nat_lt (x y : ℤ) (h0 : 0 ≤ x) (h1 : x < y) : + ↑(x.toNat) < y := by + simp [*] + +-- This is mostly used in termination proofs +theorem to_int_sub_to_nat_lt (x y : ℤ) (x' : ℕ) + (h0 : ↑x' ≤ x) (h1 : x - ↑x' < y) : + ↑(x.toNat - x') < y := by + have : 0 ≤ x := by linarith + simp [Int.toNat_sub_of_le, *] + end Arith diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index 3359ecdb..2959e245 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -270,6 +270,17 @@ elab "int_tac" args:(" split_goal"?): tactic => let split := args.raw.getArgs.size > 0 intTac split (do pure ()) +-- For termination proofs +syntax "int_decr_tac" : tactic +macro_rules + | `(tactic| int_decr_tac) => + `(tactic| + simp_wf; + -- TODO: don't use a macro (namespace problems) + (first | apply Arith.to_int_to_nat_lt + | apply Arith.to_int_sub_to_nat_lt) <;> + simp_all <;> int_tac) + example (x : Int) (h0: 0 ≤ x) (h1: x ≠ 0) : 0 < x := by int_tac_preprocess linarith diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean index 47751c8a..66c31129 100644 --- a/backends/lean/Base/Arith/Scalar.lean +++ b/backends/lean/Base/Arith/Scalar.lean @@ -36,6 +36,17 @@ def scalarTac (splitGoalConjs : Bool) : Tactic.TacticM Unit := do elab "scalar_tac" : tactic => scalarTac false +-- For termination proofs +syntax "scalar_decr_tac" : tactic +macro_rules + | `(tactic| scalar_decr_tac) => + `(tactic| + simp_wf; + -- TODO: don't use a macro (namespace problems) + (first | apply Arith.to_int_to_nat_lt + | apply Arith.to_int_sub_to_nat_lt) <;> + simp_all <;> scalar_tac) + instance (ty : ScalarTy) : HasIntProp (Scalar ty) where -- prop_ty is inferred prop := λ x => And.intro x.hmin x.hmax diff --git a/backends/lean/Base/IList/IList.lean b/backends/lean/Base/IList/IList.lean index 79de93d5..f71f2de2 100644 --- a/backends/lean/Base/IList/IList.lean +++ b/backends/lean/Base/IList/IList.lean @@ -118,13 +118,7 @@ def ireplicate {α : Type u} (i : ℤ) (x : α) : List α := if i ≤ 0 then [] else x :: ireplicate (i - 1) x termination_by ireplicate i x => i.toNat -decreasing_by - simp_wf - -- TODO: simplify this kind of proofs - simp at * - have : 0 ≤ i := by linarith - have : 1 ≤ i := by linarith - simp [Int.toNat_sub_of_le, *] +decreasing_by int_decr_tac @[simp] theorem update_nil : update ([] : List α) i y = [] := by simp [update] @[simp] theorem update_zero_cons : update ((x :: tl) : List α) 0 y = y :: tl := by simp [update] @@ -173,13 +167,7 @@ theorem ireplicate_replicate {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : cases hl: l.toNat <;> simp_all conv => rhs; rw[hl] termination_by ireplicate_replicate l x h => l.toNat -decreasing_by - simp_wf - -- TODO: simplify this kind of proofs - simp at * - have : 0 ≤ l := by linarith - have : 1 ≤ l := by linarith - simp [Int.toNat_sub_of_le, *] +decreasing_by int_decr_tac @[simp] theorem ireplicate_len {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : @@ -191,13 +179,7 @@ theorem ireplicate_len {α : Type u} (l : ℤ) (x : α) (h : 0 ≤ l) : have hr := ireplicate_len (l - 1) x (by int_tac) simp [*] termination_by ireplicate_len l x h => l.toNat -decreasing_by - simp_wf - -- TODO: simplify this kind of proofs - simp at * - have : 0 ≤ l := by linarith - have : 1 ≤ l := by linarith - simp [Int.toNat_sub_of_le, *] +decreasing_by int_decr_tac theorem len_eq_length (ls : List α) : ls.len = ls.length := by induction ls -- cgit v1.2.3 From 61368028027a7c160c33b05ec605c26833212667 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 17 Oct 2023 10:36:15 +0200 Subject: Refold the scalar types when applying progress --- backends/lean/Base/Arith/Int.lean | 4 +- backends/lean/Base/Arith/Scalar.lean | 2 +- backends/lean/Base/Progress/Progress.lean | 26 ++++++++++- backends/lean/Base/Utils.lean | 75 ++++++++++++++++++++++++++----- 4 files changed, 91 insertions(+), 16 deletions(-) diff --git a/backends/lean/Base/Arith/Int.lean b/backends/lean/Base/Arith/Int.lean index 2959e245..a57f8bb1 100644 --- a/backends/lean/Base/Arith/Int.lean +++ b/backends/lean/Base/Arith/Int.lean @@ -162,7 +162,7 @@ def introInstances (declToUnfold : Name) (lookup : Expr → MetaM (Option Expr)) -- Add a declaration let nval ← Utils.addDeclTac name e type (asLet := false) -- Simplify to unfold the declaration to unfold (i.e., the projector) - Utils.simpAt [declToUnfold] [] [] (Tactic.Location.targets #[mkIdent name] false) + Utils.simpAt true [declToUnfold] [] [] (Location.targets #[mkIdent name] false) -- Return the new value pure nval @@ -240,7 +240,7 @@ def intTac (splitGoalConjs : Bool) (extraPreprocess : Tactic.TacticM Unit) : Ta -- the goal. I think before leads to a smaller proof term? Tactic.allGoals (intTacPreprocess extraPreprocess) -- More preprocessing - Tactic.allGoals (Utils.tryTac (Utils.simpAt [] [``nat_zero_eq_int_zero] [] .wildcard)) + Tactic.allGoals (Utils.tryTac (Utils.simpAt true [] [``nat_zero_eq_int_zero] [] .wildcard)) -- Split the conjunctions in the goal if splitGoalConjs then Tactic.allGoals (Utils.repeatTac Utils.splitConjTarget) -- Call linarith diff --git a/backends/lean/Base/Arith/Scalar.lean b/backends/lean/Base/Arith/Scalar.lean index 66c31129..2342cce6 100644 --- a/backends/lean/Base/Arith/Scalar.lean +++ b/backends/lean/Base/Arith/Scalar.lean @@ -17,7 +17,7 @@ def scalarTacExtraPreprocess : Tactic.TacticM Unit := do add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Usize []]) add (← mkAppM ``Scalar.cMax_bound #[.const ``ScalarTy.Isize []]) -- Reveal the concrete bounds, simplify calls to [ofInt] - Utils.simpAt [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, + Utils.simpAt true [``Scalar.min, ``Scalar.max, ``Scalar.cMin, ``Scalar.cMax, ``I8.min, ``I16.min, ``I32.min, ``I64.min, ``I128.min, ``I8.max, ``I16.max, ``I32.max, ``I64.max, ``I128.max, ``U8.min, ``U16.min, ``U32.min, ``U64.min, ``U128.min, diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 8b0759c5..ecf05dab 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -8,6 +8,27 @@ namespace Progress open Lean Elab Term Meta Tactic open Utils +-- TODO: the scalar types annoyingly often get reduced when we use the progress +-- tactic. We should find a way of controling reduction. For now we use rewriting +-- lemmas to make sure the goal remains clean, but this complexifies proof terms. +-- It seems there used to be a `fold` tactic. +theorem scalar_isize_eq : Primitives.Scalar .Isize = Primitives.Isize := by rfl +theorem scalar_i8_eq : Primitives.Scalar .I8 = Primitives.I8 := by rfl +theorem scalar_i16_eq : Primitives.Scalar .I16 = Primitives.I16 := by rfl +theorem scalar_i32_eq : Primitives.Scalar .I32 = Primitives.I32 := by rfl +theorem scalar_i64_eq : Primitives.Scalar .I64 = Primitives.I64 := by rfl +theorem scalar_i128_eq : Primitives.Scalar .I128 = Primitives.I128 := by rfl +theorem scalar_usize_eq : Primitives.Scalar .Usize = Primitives.Usize := by rfl +theorem scalar_u8_eq : Primitives.Scalar .U8 = Primitives.U8 := by rfl +theorem scalar_u16_eq : Primitives.Scalar .U16 = Primitives.U16 := by rfl +theorem scalar_u32_eq : Primitives.Scalar .U32 = Primitives.U32 := by rfl +theorem scalar_u64_eq : Primitives.Scalar .U64 = Primitives.U64 := by rfl +theorem scalar_u128_eq : Primitives.Scalar .U128 = Primitives.U128 := by rfl +def scalar_eqs := [ + ``scalar_isize_eq, ``scalar_i8_eq, ``scalar_i16_eq, ``scalar_i32_eq, ``scalar_i64_eq, ``scalar_i128_eq, + ``scalar_usize_eq, ``scalar_u8_eq, ``scalar_u16_eq, ``scalar_u32_eq, ``scalar_u64_eq, ``scalar_u128_eq +] + inductive TheoremOrLocal where | Theorem (thName : Name) | Local (asm : LocalDecl) @@ -111,8 +132,11 @@ def progressWith (fExpr : Expr) (th : TheoremOrLocal) splitEqAndPost fun hEq hPost ids => do trace[Progress] "eq and post:\n{hEq} : {← inferType hEq}\n{hPost}" tryTac ( - simpAt [] [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] + simpAt true [] + [``Primitives.bind_tc_ret, ``Primitives.bind_tc_fail, ``Primitives.bind_tc_div] [hEq.fvarId!] (.targets #[] true)) + -- TODO: remove this (some types get unfolded too much: we "fold" them back) + tryTac (simpAt true [] scalar_eqs [] .wildcard_dep) -- Clear the equality, unless the user requests not to do so let mgoal ← do if keep.isSome then getMainGoal diff --git a/backends/lean/Base/Utils.lean b/backends/lean/Base/Utils.lean index 5224e1c3..b917a789 100644 --- a/backends/lean/Base/Utils.lean +++ b/backends/lean/Base/Utils.lean @@ -604,16 +604,12 @@ example (h : ∃ x y z, x + y + z ≥ 0) : ∃ x, x ≥ 0 := by rename_i x y z exists x + y + z -/- Call the simp tactic. - The initialization of the context is adapted from Tactic.elabSimpArgs. - Something very annoying is that there is no function which allows to - initialize a simp context without doing an elaboration - as a consequence - we write our own here. -/ -def simpAt (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) - (loc : Tactic.Location) : - Tactic.TacticM Unit := do - -- Initialize with the builtin simp theorems - let simpThms ← Tactic.simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems) +def mkSimpCtx (simpOnly : Bool) (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) : + Tactic.TacticM Simp.Context := do + -- Initialize either with the builtin simp theorems or with all the simp theorems + let simpThms ← + if simpOnly then Tactic.simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems) + else getSimpTheorems -- Add the equational theorem for the declarations to unfold let simpThms ← declsToUnfold.foldlM (fun thms decl => thms.addDeclToUnfold decl) simpThms @@ -637,8 +633,63 @@ def simpAt (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVar throwError "Not a proposition: {thmName}" ) simpThms let congrTheorems ← getSimpCongrTheorems - let ctx : Simp.Context := { simpTheorems := #[simpThms], congrTheorems } + pure { simpTheorems := #[simpThms], congrTheorems } + + +inductive Location where + /-- Apply the tactic everywhere. Same as `Tactic.Location.wildcard` -/ + | wildcard + /-- Apply the tactic everywhere, including in the variable types (i.e., in + assumptions which are not propositions). --/ + | wildcard_dep + /-- Same as Tactic.Location -/ + | targets (hypotheses : Array Syntax) (type : Bool) + +-- Comes from Tactic.simpLocation +def customSimpLocation (ctx : Simp.Context) (discharge? : Option Simp.Discharge := none) + (loc : Location) : TacticM Simp.UsedSimps := do + match loc with + | Location.targets hyps simplifyTarget => + withMainContext do + let fvarIds ← Lean.Elab.Tactic.getFVarIds hyps + go fvarIds simplifyTarget + | Location.wildcard => + withMainContext do + go (← (← getMainGoal).getNondepPropHyps) (simplifyTarget := true) + | Location.wildcard_dep => + withMainContext do + let ctx ← Lean.MonadLCtx.getLCtx + let decls ← ctx.getDecls + let tgts := (decls.map (fun d => d.fvarId)).toArray + go tgts (simplifyTarget := true) +where + go (fvarIdsToSimp : Array FVarId) (simplifyTarget : Bool) : TacticM Simp.UsedSimps := do + let mvarId ← getMainGoal + let (result?, usedSimps) ← simpGoal mvarId ctx (simplifyTarget := simplifyTarget) (discharge? := discharge?) (fvarIdsToSimp := fvarIdsToSimp) + match result? with + | none => replaceMainGoal [] + | some (_, mvarId) => replaceMainGoal [mvarId] + return usedSimps + +/- Call the simp tactic. + The initialization of the context is adapted from Tactic.elabSimpArgs. + Something very annoying is that there is no function which allows to + initialize a simp context without doing an elaboration - as a consequence + we write our own here. -/ +def simpAt (simpOnly : Bool) (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) + (loc : Location) : + Tactic.TacticM Unit := do + -- Initialize the simp context + let ctx ← mkSimpCtx simpOnly declsToUnfold thms hypsToUse + -- Apply the simplifier + let _ ← customSimpLocation ctx (discharge? := .none) loc + +-- Call the simpAll tactic +def simpAll (declsToUnfold : List Name) (thms : List Name) (hypsToUse : List FVarId) : + Tactic.TacticM Unit := do + -- Initialize the simp context + let ctx ← mkSimpCtx false declsToUnfold thms hypsToUse -- Apply the simplifier - let _ ← Tactic.simpLocation ctx (discharge? := .none) loc + let _ ← Lean.Meta.simpAll (← getMainGoal) ctx end Utils -- 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(-) 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 --- backends/fstar/Primitives.fst | 23 ++++++++++++++++++++++- compiler/Extract.ml | 11 +++++++---- compiler/FunsAnalysis.ml | 24 +++++++++++++++++++++--- 3 files changed, 50 insertions(+), 8 deletions(-) diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index e9391834..7d0845ed 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -100,6 +100,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function +| Isize | I8 | I16 | I32 | I64 | I128 -> false +| Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +167,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +272,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,6 +300,13 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + (*** Range *) type range (a : Type0) = { start : a; 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 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(-) 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 c184adf70c23fe2c0f3b0b727918ca32e94e673a Mon Sep 17 00:00:00 2001 From: Paul-Nicolas Madelaine Date: Mon, 23 Oct 2023 18:00:34 +0200 Subject: ci: hydra -> github runner --- .github/workflows/ci.yml | 19 +++++++++++++++++++ flake.nix | 1 - 2 files changed, 19 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/ci.yml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 00000000..664dc674 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,19 @@ +on: + push: + branches-ignore: [ '_**' ] + pull_request: + workflow_dispatch: + +jobs: + nix: + #runs-on: ubuntu-latest + runs-on: [self-hosted, linux, nix] + steps: + #- uses: cachix/install-nix-action@v22 + - uses: actions/checkout@v4 + - run: nix build -L .#aeneas + - run: nix build -L .#checks.x86_64-linux.aeneas-tests + - run: nix build -L .#checks.x86_64-linux.aeneas-verify-fstar + - run: nix build -L .#checks.x86_64-linux.aeneas-verify-coq + #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean + - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 diff --git a/flake.nix b/flake.nix index 4ff46046..ebe1e90d 100644 --- a/flake.nix +++ b/flake.nix @@ -169,6 +169,5 @@ default = aeneas; }; checks = { inherit aeneas aeneas-tests aeneas-verify-fstar aeneas-verify-coq aeneas-verify-lean aeneas-verify-hol4; }; - hydraJobs = { inherit aeneas aeneas-tests aeneas-verify-fstar aeneas-verify-coq aeneas-verify-lean aeneas-verify-hol4; }; }); } -- cgit v1.2.3 From a2183bf48773d078a9372847f1715fd38b84819d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 11:15:33 +0200 Subject: Deactivate the concrete interpreter tests --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 807352f8..2c996345 100644 --- a/Makefile +++ b/Makefile @@ -115,7 +115,7 @@ AENEAS_CMD = $(AENEAS_EXE) $(CHARON_TEST_DIR)/llbc/$(FILE).llbc -dest tests/$(BA # Add specific options to some tests trans-no_nested_borrows trans-paper: \ - OPTIONS += -test-units -test-trans-units -no-split-files -no-state + OPTIONS += -test-trans-units -no-split-files -no-state trans-no_nested_borrows trans-paper: SUBDIR := misc tfstar-no_nested_borrows tfstar-paper: tlean-no_nested_borrows: SUBDIR := @@ -157,7 +157,7 @@ tcoq-hashmap_main: OPTIONS += -use-fuel tlean-hashmap_main: SUBDIR := thol4-hashmap_main: OPTIONS += -transp-polonius_list: OPTIONS += -test-units -test-trans-units -no-split-files -no-state +transp-polonius_list: OPTIONS += -test-trans-units -no-split-files -no-state transp-polonius_list: SUBDIR := misc tfstarp-polonius_list: OPTIONS += tcoqp-polonius_list: OPTIONS += -- 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(+) 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 f35aba375757db99d2dc6ac2b11b9eb1e437b420 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 24 Oct 2023 11:58:35 +0200 Subject: Add definitions in for the Lean Primitives library --- backends/lean/Base/Primitives.lean | 2 ++ backends/lean/Base/Primitives/Alloc.lean | 37 +++++++++++++++++++++++++ backends/lean/Base/Primitives/CoreOpsDeref.lean | 18 ++++++++++++ 3 files changed, 57 insertions(+) create mode 100644 backends/lean/Base/Primitives/Alloc.lean create mode 100644 backends/lean/Base/Primitives/CoreOpsDeref.lean diff --git a/backends/lean/Base/Primitives.lean b/backends/lean/Base/Primitives.lean index 6b7b0792..22378af7 100644 --- a/backends/lean/Base/Primitives.lean +++ b/backends/lean/Base/Primitives.lean @@ -2,3 +2,5 @@ import Base.Primitives.Base import Base.Primitives.Scalar import Base.Primitives.Array import Base.Primitives.Vec +import Base.Primitives.Alloc +import Base.Primitives.CoreOpsDeref diff --git a/backends/lean/Base/Primitives/Alloc.lean b/backends/lean/Base/Primitives/Alloc.lean new file mode 100644 index 00000000..0580421f --- /dev/null +++ b/backends/lean/Base/Primitives/Alloc.lean @@ -0,0 +1,37 @@ +import Lean +import Base.Primitives.Base +import Base.Primitives.CoreOpsDeref + +open Primitives +open Result + +namespace alloc + +namespace boxed -- alloc.boxed + +namespace Box -- alloc.boxed.Box + +def deref (T : Type) (x : T) : Result T := ret x +def deref_mut (T : Type) (x : T) : Result T := ret x +def deref_mut_back (T : Type) (_ : T) (x : T) : Result T := ret x + +/-- Trait instance -/ +def coreOpsDerefInst (Self : Type) : + core.ops.deref.Deref Self := { + Target := Self + deref := deref Self +} + +/-- Trait instance -/ +def coreOpsDerefMutInst (Self : Type) : + core.ops.deref.DerefMut Self := { + derefInst := coreOpsDerefInst Self + deref_mut := deref_mut Self + deref_mut_back := deref_mut_back Self +} + +end Box -- alloc.boxed.Box + +end boxed -- alloc.boxed + +end alloc diff --git a/backends/lean/Base/Primitives/CoreOpsDeref.lean b/backends/lean/Base/Primitives/CoreOpsDeref.lean new file mode 100644 index 00000000..2b540012 --- /dev/null +++ b/backends/lean/Base/Primitives/CoreOpsDeref.lean @@ -0,0 +1,18 @@ +import Lean +import Base.Primitives.Base + +open Primitives +open Result + +namespace core.ops.deref + +structure Deref (Self : Type) where + Target : Type + deref : Self → Result Target + +structure DerefMut (Self : Type) where + derefInst : Deref Self + deref_mut : Self → Result derefInst.Target + deref_mut_back : Self → derefInst.Target → Result Self + +end core.ops.deref -- 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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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 --- backends/lean/Base/Primitives/Base.lean | 4 ++-- compiler/ExtractBuiltin.ml | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/backends/lean/Base/Primitives/Base.lean b/backends/lean/Base/Primitives/Base.lean index 7c0fa3bb..2bd081c0 100644 --- a/backends/lean/Base/Primitives/Base.lean +++ b/backends/lean/Base/Primitives/Base.lean @@ -120,8 +120,8 @@ def Result.attach {α: Type} (o : Result α): Result { x : α // o = ret x } := -- MISC -- ---------- -@[simp] def mem.replace (a : Type) (x : a) (_ : a) : a := x -@[simp] def mem.replace_back (a : Type) (_ : a) (y : a) : a := y +@[simp] def core.mem.replace (a : Type) (x : a) (_ : a) : Result a := ret x +@[simp] def core.mem.replace_back (a : Type) (_ : a) (y : a) : Result a := ret y /-- Aeneas-translated function -- useful to reduce non-recursive definitions. Use with `simp [ aeneas ]` -/ 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 ++-- tests/lean/NoNestedBorrows.lean | 134 +++++++++++++++++++--------------------- 3 files changed, 79 insertions(+), 75 deletions(-) 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 * *) diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index 884e62c4..a90d6ea2 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -54,7 +54,7 @@ def div_test (x : U32) (y : U32) : Result U32 := /- [no_nested_borrows::div_test1]: forward function -/ def div_test1 (x : U32) : Result U32 := - x / (U32.ofInt 2) + x / 2#u32 /- [no_nested_borrows::rem_test]: forward function -/ def rem_test (x : U32) (y : U32) : Result U32 := @@ -67,7 +67,7 @@ def cast_test (x : U32) : Result I32 := /- [no_nested_borrows::test2]: forward function -/ def test2 : Result Unit := do - let _ ← (U32.ofInt 23) + (U32.ofInt 44) + let _ ← 23#u32 + 44#u32 Result.ret () /- Unit test for [no_nested_borrows::test2] -/ @@ -82,10 +82,10 @@ def get_max (x : U32) (y : U32) : Result U32 := /- [no_nested_borrows::test3]: forward function -/ def test3 : Result Unit := do - let x ← get_max (U32.ofInt 4) (U32.ofInt 3) - let y ← get_max (U32.ofInt 10) (U32.ofInt 11) + let x ← get_max 4#u32 3#u32 + let y ← get_max 10#u32 11#u32 let z ← x + y - if not (z = (U32.ofInt 15)) + if not (z = 15#u32) then Result.fail Error.panic else Result.ret () @@ -95,8 +95,8 @@ def test3 : Result Unit := /- [no_nested_borrows::test_neg1]: forward function -/ def test_neg1 : Result Unit := do - let y ← - (I32.ofInt 3) - if not (y = (I32.ofInt (-(3:Int)))) + let y ← - 3#i32 + if not (y = (-(3:Int))#i32) then Result.fail Error.panic else Result.ret () @@ -105,7 +105,7 @@ def test_neg1 : Result Unit := /- [no_nested_borrows::refs_test1]: forward function -/ def refs_test1 : Result Unit := - if not ((I32.ofInt 1) = (I32.ofInt 1)) + if not (1#i32 = 1#i32) then Result.fail Error.panic else Result.ret () @@ -114,16 +114,16 @@ def refs_test1 : Result Unit := /- [no_nested_borrows::refs_test2]: forward function -/ def refs_test2 : Result Unit := - if not ((I32.ofInt 2) = (I32.ofInt 2)) + if not (2#i32 = 2#i32) then Result.fail Error.panic else - if not ((I32.ofInt 0) = (I32.ofInt 0)) + if not (0#i32 = 0#i32) then Result.fail Error.panic else - if not ((I32.ofInt 2) = (I32.ofInt 2)) + if not (2#i32 = 2#i32) then Result.fail Error.panic else - if not ((I32.ofInt 2) = (I32.ofInt 2)) + if not (2#i32 = 2#i32) then Result.fail Error.panic else Result.ret () @@ -167,8 +167,8 @@ def test_panic (b : Bool) : Result Unit := /- [no_nested_borrows::test_copy_int]: forward function -/ def test_copy_int : Result Unit := do - let y ← copy_int (I32.ofInt 0) - if not ((I32.ofInt 0) = y) + let y ← copy_int 0#i32 + if not (0#i32 = y) then Result.fail Error.panic else Result.ret () @@ -185,7 +185,7 @@ def is_cons (T : Type) (l : List T) : Result Bool := def test_is_cons : Result Unit := do let l := List.Nil - let b ← is_cons I32 (List.Cons (I32.ofInt 0) l) + let b ← is_cons I32 (List.Cons 0#i32 l) if not b then Result.fail Error.panic else Result.ret () @@ -203,9 +203,9 @@ def split_list (T : Type) (l : List T) : Result (T × (List T)) := def test_split_list : Result Unit := do let l := List.Nil - let p ← split_list I32 (List.Cons (I32.ofInt 0) l) + let p ← split_list I32 (List.Cons 0#i32 l) let (hd, _) := p - if not (hd = (I32.ofInt 0)) + if not (hd = 0#i32) then Result.fail Error.panic else Result.ret () @@ -228,19 +228,18 @@ def choose_back /- [no_nested_borrows::choose_test]: forward function -/ def choose_test : Result Unit := do - let z ← choose I32 true (I32.ofInt 0) (I32.ofInt 0) - let z0 ← z + (I32.ofInt 1) - if not (z0 = (I32.ofInt 1)) + let z ← choose I32 true 0#i32 0#i32 + let z0 ← z + 1#i32 + if not (z0 = 1#i32) then Result.fail Error.panic else do - let (x, y) ← choose_back I32 true (I32.ofInt 0) (I32.ofInt 0) z0 - if not (x = (I32.ofInt 1)) + let (x, y) ← choose_back I32 true 0#i32 0#i32 z0 + if not (x = 1#i32) then Result.fail Error.panic - else - if not (y = (I32.ofInt 0)) - then Result.fail Error.panic - else Result.ret () + else if not (y = 0#i32) + then Result.fail Error.panic + else Result.ret () /- Unit test for [no_nested_borrows::choose_test] -/ #assert (choose_test == .ret ()) @@ -268,17 +267,17 @@ divergent def list_length (T : Type) (l : List T) : Result U32 := match l with | List.Cons t l1 => do let i ← list_length T l1 - (U32.ofInt 1) + i - | List.Nil => Result.ret (U32.ofInt 0) + 1#u32 + i + | List.Nil => Result.ret 0#u32 /- [no_nested_borrows::list_nth_shared]: forward function -/ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_shared T tl i0 | List.Nil => Result.fail Error.panic @@ -286,10 +285,10 @@ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut T tl i0 | List.Nil => Result.fail Error.panic @@ -298,11 +297,11 @@ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl0 ← list_nth_mut_back T tl i0 ret0 Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic @@ -324,47 +323,42 @@ def list_rev (T : Type) (l : List T) : Result (List T) := def test_list_functions : Result Unit := do let l := List.Nil - let l0 := List.Cons (I32.ofInt 2) l - let l1 := List.Cons (I32.ofInt 1) l0 - let i ← list_length I32 (List.Cons (I32.ofInt 0) l1) - if not (i = (U32.ofInt 3)) + let l0 := List.Cons 2#i32 l + let l1 := List.Cons 1#i32 l0 + let i ← list_length I32 (List.Cons 0#i32 l1) + if not (i = 3#u32) then Result.fail Error.panic else do - let i0 ← - list_nth_shared I32 (List.Cons (I32.ofInt 0) l1) (U32.ofInt 0) - if not (i0 = (I32.ofInt 0)) + let i0 ← list_nth_shared I32 (List.Cons 0#i32 l1) 0#u32 + if not (i0 = 0#i32) then Result.fail Error.panic else do - let i1 ← - list_nth_shared I32 (List.Cons (I32.ofInt 0) l1) (U32.ofInt 1) - if not (i1 = (I32.ofInt 1)) + let i1 ← list_nth_shared I32 (List.Cons 0#i32 l1) 1#u32 + if not (i1 = 1#i32) then Result.fail Error.panic else do - let i2 ← - list_nth_shared I32 (List.Cons (I32.ofInt 0) l1) - (U32.ofInt 2) - if not (i2 = (I32.ofInt 2)) + let i2 ← list_nth_shared I32 (List.Cons 0#i32 l1) 2#u32 + if not (i2 = 2#i32) then Result.fail Error.panic else do let ls ← - list_nth_mut_back I32 (List.Cons (I32.ofInt 0) l1) - (U32.ofInt 1) (I32.ofInt 3) - let i3 ← list_nth_shared I32 ls (U32.ofInt 0) - if not (i3 = (I32.ofInt 0)) + list_nth_mut_back I32 (List.Cons 0#i32 l1) 1#u32 3#i32 + let i3 ← list_nth_shared I32 ls 0#u32 + if not (i3 = 0#i32) then Result.fail Error.panic else do - let i4 ← list_nth_shared I32 ls (U32.ofInt 1) - if not (i4 = (I32.ofInt 3)) + let i4 ← list_nth_shared I32 ls 1#u32 + if not (i4 = 3#i32) then Result.fail Error.panic else do - let i5 ← list_nth_shared I32 ls (U32.ofInt 2) - if not (i5 = (I32.ofInt 2)) + let i5 ← list_nth_shared I32 ls 2#u32 + if not (i5 = 2#i32) then Result.fail Error.panic else Result.ret () @@ -427,15 +421,15 @@ structure StructWithTuple (T1 T2 : Type) where /- [no_nested_borrows::new_tuple1]: forward function -/ def new_tuple1 : Result (StructWithTuple U32 U32) := - Result.ret { p := ((U32.ofInt 1), (U32.ofInt 2)) } + Result.ret { p := (1#u32, 2#u32) } /- [no_nested_borrows::new_tuple2]: forward function -/ def new_tuple2 : Result (StructWithTuple I16 I16) := - Result.ret { p := ((I16.ofInt 1), (I16.ofInt 2)) } + Result.ret { p := (1#i16, 2#i16) } /- [no_nested_borrows::new_tuple3]: forward function -/ def new_tuple3 : Result (StructWithTuple U64 I64) := - Result.ret { p := ((U64.ofInt 1), (I64.ofInt 2)) } + Result.ret { p := (1#u64, 2#i64) } /- [no_nested_borrows::StructWithPair] -/ structure StructWithPair (T1 T2 : Type) where @@ -443,31 +437,31 @@ structure StructWithPair (T1 T2 : Type) where /- [no_nested_borrows::new_pair1]: forward function -/ def new_pair1 : Result (StructWithPair U32 U32) := - Result.ret { p := { x := (U32.ofInt 1), y := (U32.ofInt 2) } } + Result.ret { p := { x := 1#u32, y := 2#u32 } } /- [no_nested_borrows::test_constants]: forward function -/ def test_constants : Result Unit := do let swt ← new_tuple1 let (i, _) := swt.p - if not (i = (U32.ofInt 1)) + if not (i = 1#u32) then Result.fail Error.panic else do let swt0 ← new_tuple2 let (i0, _) := swt0.p - if not (i0 = (I16.ofInt 1)) + if not (i0 = 1#i16) then Result.fail Error.panic else do let swt1 ← new_tuple3 let (i1, _) := swt1.p - if not (i1 = (U64.ofInt 1)) + if not (i1 = 1#u64) then Result.fail Error.panic else do let swp ← new_pair1 - if not (swp.p.x = (U32.ofInt 1)) + if not (swp.p.x = 1#u32) then Result.fail Error.panic else Result.ret () @@ -492,21 +486,21 @@ def test_mem_replace (px : U32) : Result U32 := /- [no_nested_borrows::test_shared_borrow_bool1]: forward function -/ def test_shared_borrow_bool1 (b : Bool) : Result U32 := if b - then Result.ret (U32.ofInt 0) - else Result.ret (U32.ofInt 1) + then Result.ret 0#u32 + else Result.ret 1#u32 /- [no_nested_borrows::test_shared_borrow_bool2]: forward function -/ def test_shared_borrow_bool2 : Result U32 := - Result.ret (U32.ofInt 0) + Result.ret 0#u32 /- [no_nested_borrows::test_shared_borrow_enum1]: forward function -/ def test_shared_borrow_enum1 (l : List U32) : Result U32 := match l with - | List.Cons i l0 => Result.ret (U32.ofInt 1) - | List.Nil => Result.ret (U32.ofInt 0) + | List.Cons i l0 => Result.ret 1#u32 + | List.Nil => Result.ret 0#u32 /- [no_nested_borrows::test_shared_borrow_enum2]: forward function -/ def test_shared_borrow_enum2 : Result U32 := - Result.ret (U32.ofInt 0) + Result.ret 0#u32 end no_nested_borrows -- 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 --- backends/lean/Base/Primitives/Base.lean | 4 ++-- compiler/ExtractBase.ml | 4 ++-- compiler/ExtractBuiltin.ml | 34 ++++++++++++++++++++++++++++++++- compiler/FunsAnalysis.ml | 34 ++++++++++++++++++--------------- tests/lean/NoNestedBorrows.lean | 12 ++++++------ 5 files changed, 62 insertions(+), 26 deletions(-) diff --git a/backends/lean/Base/Primitives/Base.lean b/backends/lean/Base/Primitives/Base.lean index 2bd081c0..10af8f67 100644 --- a/backends/lean/Base/Primitives/Base.lean +++ b/backends/lean/Base/Primitives/Base.lean @@ -120,8 +120,8 @@ def Result.attach {α: Type} (o : Result α): Result { x : α // o = ret x } := -- MISC -- ---------- -@[simp] def core.mem.replace (a : Type) (x : a) (_ : a) : Result a := ret x -@[simp] def core.mem.replace_back (a : Type) (_ : a) (y : a) : Result a := ret y +@[simp] def core.mem.replace (a : Type) (x : a) (_ : a) : a := x +@[simp] def core.mem.replace_back (a : Type) (_ : a) (y : a) : a := y /-- Aeneas-translated function -- useful to reduce non-recursive definitions. Use with `simp [ aeneas ]` -/ 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; diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index a90d6ea2..d6d603ce 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -139,9 +139,9 @@ def test_list1 : Result Unit := /- [no_nested_borrows::test_box1]: forward function -/ def test_box1 : Result Unit := - let b := (I32.ofInt 1) + let b := 1#i32 let x := b - if not (x = (I32.ofInt 1)) + if not (x = 1#i32) then Result.fail Error.panic else Result.ret () @@ -316,7 +316,7 @@ divergent def list_rev_aux /- [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def list_rev (T : Type) (l : List T) : Result (List T) := - let li := mem.replace (List T) l List.Nil + let li := core.mem.replace (List T) l List.Nil list_rev_aux T li List.Nil /- [no_nested_borrows::test_list_functions]: forward function -/ @@ -478,10 +478,10 @@ def test_weird_borrows1 : Result Unit := /- [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def test_mem_replace (px : U32) : Result U32 := - let y := mem.replace U32 px (U32.ofInt 1) - if not (y = (U32.ofInt 0)) + let y := core.mem.replace U32 px 1#u32 + if not (y = 0#u32) then Result.fail Error.panic - else Result.ret (U32.ofInt 2) + else Result.ret 2#u32 /- [no_nested_borrows::test_shared_borrow_bool1]: forward function -/ def test_shared_borrow_bool1 (b : Bool) : Result U32 := -- 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(-) 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(-) 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(-) 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 --- backends/lean/Base/Primitives.lean | 4 +- backends/lean/Base/Primitives/Alloc.lean | 2 +- backends/lean/Base/Primitives/Array.lean | 403 ----------------- backends/lean/Base/Primitives/ArraySlice.lean | 560 ++++++++++++++++++++++++ backends/lean/Base/Primitives/Base.lean | 7 + backends/lean/Base/Primitives/CoreOps.lean | 37 ++ backends/lean/Base/Primitives/CoreOpsDeref.lean | 18 - backends/lean/Base/Primitives/Vec.lean | 2 +- compiler/Extract.ml | 45 +- compiler/ExtractBuiltin.ml | 304 ++++++++++++- compiler/LlbcAstUtils.ml | 19 +- compiler/Translate.ml | 10 +- 12 files changed, 948 insertions(+), 463 deletions(-) delete mode 100644 backends/lean/Base/Primitives/Array.lean create mode 100644 backends/lean/Base/Primitives/ArraySlice.lean create mode 100644 backends/lean/Base/Primitives/CoreOps.lean delete mode 100644 backends/lean/Base/Primitives/CoreOpsDeref.lean diff --git a/backends/lean/Base/Primitives.lean b/backends/lean/Base/Primitives.lean index 22378af7..613b6076 100644 --- a/backends/lean/Base/Primitives.lean +++ b/backends/lean/Base/Primitives.lean @@ -1,6 +1,6 @@ import Base.Primitives.Base import Base.Primitives.Scalar -import Base.Primitives.Array +import Base.Primitives.ArraySlice import Base.Primitives.Vec import Base.Primitives.Alloc -import Base.Primitives.CoreOpsDeref +import Base.Primitives.CoreOps diff --git a/backends/lean/Base/Primitives/Alloc.lean b/backends/lean/Base/Primitives/Alloc.lean index 0580421f..34590499 100644 --- a/backends/lean/Base/Primitives/Alloc.lean +++ b/backends/lean/Base/Primitives/Alloc.lean @@ -1,6 +1,6 @@ import Lean import Base.Primitives.Base -import Base.Primitives.CoreOpsDeref +import Base.Primitives.CoreOps open Primitives open Result diff --git a/backends/lean/Base/Primitives/Array.lean b/backends/lean/Base/Primitives/Array.lean deleted file mode 100644 index 49c84bee..00000000 --- a/backends/lean/Base/Primitives/Array.lean +++ /dev/null @@ -1,403 +0,0 @@ -/- Arrays/slices -/ -import Lean -import Lean.Meta.Tactic.Simp -import Init.Data.List.Basic -import Mathlib.Tactic.RunCmd -import Mathlib.Tactic.Linarith -import Base.IList -import Base.Primitives.Scalar -import Base.Primitives.Range -import Base.Arith -import Base.Progress.Base - -namespace Primitives - -open Result Error - -def Array (α : Type u) (n : Usize) := { l : List α // l.length = n.val } - -instance (a : Type u) (n : Usize) : Arith.HasIntProp (Array a n) where - prop_ty := λ v => v.val.len = n.val - prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] - -instance {α : Type u} {n : Usize} (p : Array α n → Prop) : Arith.HasIntProp (Subtype p) where - prop_ty := λ x => p x - prop := λ x => x.property - -@[simp] -abbrev Array.length {α : Type u} {n : Usize} (v : Array α n) : Int := v.val.len - -@[simp] -abbrev Array.v {α : Type u} {n : Usize} (v : Array α n) : List α := v.val - -example {α: Type u} {n : Usize} (v : Array α n) : v.length ≤ Scalar.max ScalarTy.Usize := by - scalar_tac - -def Array.make (α : Type u) (n : Usize) (init : List α) (hl : init.len = n.val := by decide) : - Array α n := ⟨ init, by simp [← List.len_eq_length]; apply hl ⟩ - -example : Array Int (Usize.ofInt 2) := Array.make Int (Usize.ofInt 2) [0, 1] - -@[simp] -abbrev Array.index {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i : Int) : α := - v.val.index i - -@[simp] -abbrev Array.slice {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i j : Int) : List α := - v.val.slice i j - -def Array.index_shared (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - --- For initialization -def Array.repeat (α : Type u) (n : Usize) (x : α) : Array α n := - ⟨ List.ireplicate n.val x, by have h := n.hmin; simp_all [Scalar.min] ⟩ - -@[pspec] -theorem Array.repeat_spec {α : Type u} (n : Usize) (x : α) : - ∃ a, Array.repeat α n x = a ∧ a.val = List.ireplicate n.val x := by - simp [Array.repeat] - -/- In the theorems below: we don't always need the `∃ ..`, but we use one - so that `progress` introduces an opaque variable and an equality. This - helps control the context. - -/ - -@[pspec] -theorem Array.index_shared_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_shared α n i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - --- This shouldn't be used -def Array.index_shared_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Array.index_mut (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Array.index_mut_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α n i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Array.index_mut_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (x: α) : Result (Array α n) := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some _ => - .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ - -@[pspec] -theorem Array.index_mut_back_spec {α : Type u} {n : Usize} (v: Array α n) (i: Usize) (x : α) - (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α n i x = ret nv ∧ - nv.val = v.val.update i.val x - := by - simp only [index_mut_back] - have h := List.indexOpt_bounds v.val i.val - split - . simp_all [length]; cases h <;> scalar_tac - . simp_all - -def Slice (α : Type u) := { l : List α // l.length ≤ Usize.max } - -instance (a : Type u) : Arith.HasIntProp (Slice a) where - prop_ty := λ v => 0 ≤ v.val.len ∧ v.val.len ≤ Scalar.max ScalarTy.Usize - prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] - -instance {α : Type u} (p : Slice α → Prop) : Arith.HasIntProp (Subtype p) where - prop_ty := λ x => p x - prop := λ x => x.property - -@[simp] -abbrev Slice.length {α : Type u} (v : Slice α) : Int := v.val.len - -@[simp] -abbrev Slice.v {α : Type u} (v : Slice α) : List α := v.val - -example {a: Type u} (v : Slice a) : v.length ≤ Scalar.max ScalarTy.Usize := by - scalar_tac - -def Slice.new (α : Type u): Slice α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ - --- TODO: very annoying that the α is an explicit parameter -def Slice.len (α : Type u) (v : Slice α) : Usize := - Usize.ofIntCore v.val.len (by scalar_tac) (by scalar_tac) - -@[simp] -theorem Slice.len_val {α : Type u} (v : Slice α) : (Slice.len α v).val = v.length := - by rfl - -@[simp] -abbrev Slice.index {α : Type u} [Inhabited α] (v: Slice α) (i: Int) : α := - v.val.index i - -@[simp] -abbrev Slice.slice {α : Type u} [Inhabited α] (s : Slice α) (i j : Int) : List α := - s.val.slice i j - -def Slice.index_shared (α : Type u) (v: Slice α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -/- In the theorems below: we don't always need the `∃ ..`, but we use one - so that `progress` introduces an opaque variable and an equality. This - helps control the context. - -/ - -@[pspec] -theorem Slice.index_shared_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_shared α i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - --- This shouldn't be used -def Slice.index_shared_back (α : Type u) (v: Slice α) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Slice.index_mut (α : Type u) (v: Slice α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Slice.index_mut_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Slice.index_mut_back (α : Type u) (v: Slice α) (i: Usize) (x: α) : Result (Slice α) := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some _ => - .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ - -@[pspec] -theorem Slice.index_mut_back_spec {α : Type u} (v: Slice α) (i: Usize) (x : α) - (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ - nv.val = v.val.update i.val x - := by - simp only [index_mut_back] - have h := List.indexOpt_bounds v.val i.val - split - . simp_all [length]; cases h <;> scalar_tac - . simp_all - -/- Array to slice/subslices -/ - -/- We could make this function not use the `Result` type. By making it monadic, we - push the user to use the `Array.to_slice_shared_spec` spec theorem below (through the - `progress` tactic), meaning `Array.to_slice_shared` should be considered as opaque. - All what the spec theorem reveals is that the "representative" lists are the same. -/ -def Array.to_slice_shared (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := - ret ⟨ v.val, by simp [← List.len_eq_length]; scalar_tac ⟩ - -@[pspec] -theorem Array.to_slice_shared_spec {α : Type u} {n : Usize} (v : Array α n) : - ∃ s, to_slice_shared α n v = ret s ∧ v.val = s.val := by simp [to_slice_shared] - -def Array.to_slice_mut (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := - to_slice_shared α n v - -@[pspec] -theorem Array.to_slice_mut_spec {α : Type u} {n : Usize} (v : Array α n) : - ∃ s, Array.to_slice_shared α n v = ret s ∧ v.val = s.val := to_slice_shared_spec v - -def Array.to_slice_mut_back (α : Type u) (n : Usize) (_ : Array α n) (s : Slice α) : Result (Array α n) := - if h: s.val.len = n.val then - ret ⟨ s.val, by simp [← List.len_eq_length, *] ⟩ - else fail panic - -@[pspec] -theorem Array.to_slice_mut_back_spec {α : Type u} {n : Usize} (a : Array α n) (ns : Slice α) (h : ns.val.len = n.val) : - ∃ na, to_slice_mut_back α n a ns = ret na ∧ na.val = ns.val - := by simp [to_slice_mut_back, *] - -def Array.subslice_shared (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := - -- TODO: not completely sure here - if r.start.val < r.end_.val ∧ r.end_.val ≤ a.val.len then - ret ⟨ a.val.slice r.start.val r.end_.val, - by - simp [← List.len_eq_length] - have := a.val.slice_len_le r.start.val r.end_.val - scalar_tac ⟩ - else - fail panic - -@[pspec] -theorem Array.subslice_shared_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : - ∃ s, subslice_shared α n a r = ret s ∧ - s.val = a.val.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) - := by - simp [subslice_shared, *] - intro i _ _ - have := List.index_slice r.start.val r.end_.val i a.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) - simp [*] - -def Array.subslice_mut (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := - Array.subslice_shared α n a r - -@[pspec] -theorem Array.subslice_mut_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : - ∃ s, subslice_mut α n a r = ret s ∧ - s.val = a.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) - := subslice_shared_spec a r h0 h1 - -def Array.subslice_mut_back (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) (s : Slice α) : Result (Array α n) := - -- TODO: not completely sure here - if h: r.start.val < r.end_.val ∧ r.end_.val ≤ a.length ∧ s.val.len = r.end_.val - r.start.val then - let s_beg := a.val.itake r.start.val - let s_end := a.val.idrop r.end_.val - have : s_beg.len = r.start.val := by - apply List.itake_len - . simp_all; scalar_tac - . scalar_tac - have : s_end.len = a.val.len - r.end_.val := by - apply List.idrop_len - . scalar_tac - . scalar_tac - let na := s_beg.append (s.val.append s_end) - have : na.len = a.val.len := by simp [*] - ret ⟨ na, by simp_all [← List.len_eq_length]; scalar_tac ⟩ - else - fail panic - --- TODO: it is annoying to write `.val` everywhere. We could leverage coercions, --- but: some symbols like `+` are already overloaded to be notations for monadic --- operations/ --- We should introduce special symbols for the monadic arithmetic operations --- (the use will never write those symbols directly). -@[pspec] -theorem Array.subslice_mut_back_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (s : Slice α) - (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : s.length = r.end_.val - r.start.val) : - ∃ na, subslice_mut_back α n a r s = ret na ∧ - (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ - (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = s.index (i - r.start.val)) ∧ - (∀ i, r.end_.val ≤ i → i < n.val → na.index i = a.index i) := by - simp [subslice_mut_back, *] - have h := List.replace_slice_index r.start.val r.end_.val a.val s.val - (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) - simp [List.replace_slice] at h - have ⟨ h0, h1, h2 ⟩ := h - clear h - split_conjs - . intro i _ _ - have := h0 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h1 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h2 i (by int_tac) (by int_tac) - simp [*] - -def Slice.subslice_shared (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := - -- TODO: not completely sure here - if r.start.val < r.end_.val ∧ r.end_.val ≤ s.length then - ret ⟨ s.val.slice r.start.val r.end_.val, - by - simp [← List.len_eq_length] - have := s.val.slice_len_le r.start.val r.end_.val - scalar_tac ⟩ - else - fail panic - -@[pspec] -theorem Slice.subslice_shared_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : - ∃ ns, subslice_shared α s r = ret ns ∧ - ns.val = s.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) - := by - simp [subslice_shared, *] - intro i _ _ - have := List.index_slice r.start.val r.end_.val i s.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) - simp [*] - -def Slice.subslice_mut (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := - Slice.subslice_shared α s r - -@[pspec] -theorem Slice.subslice_mut_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : - ∃ ns, subslice_mut α s r = ret ns ∧ - ns.val = s.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) - := subslice_shared_spec s r h0 h1 - -attribute [pp_dot] List.len List.length List.index -- use the dot notation when printing -set_option pp.coercions false -- do not print coercions with ↑ (this doesn't parse) - -def Slice.subslice_mut_back (α : Type u) (s : Slice α) (r : Range Usize) (ss : Slice α) : Result (Slice α) := - -- TODO: not completely sure here - if h: r.start.val < r.end_.val ∧ r.end_.val ≤ s.length ∧ ss.val.len = r.end_.val - r.start.val then - let s_beg := s.val.itake r.start.val - let s_end := s.val.idrop r.end_.val - have : s_beg.len = r.start.val := by - apply List.itake_len - . simp_all; scalar_tac - . scalar_tac - have : s_end.len = s.val.len - r.end_.val := by - apply List.idrop_len - . scalar_tac - . scalar_tac - let ns := s_beg.append (ss.val.append s_end) - have : ns.len = s.val.len := by simp [*] - ret ⟨ ns, by simp_all [← List.len_eq_length]; scalar_tac ⟩ - else - fail panic - -@[pspec] -theorem Slice.subslice_mut_back_spec {α : Type u} [Inhabited α] (a : Slice α) (r : Range Usize) (ss : Slice α) - (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : ss.length = r.end_.val - r.start.val) : - ∃ na, subslice_mut_back α a r ss = ret na ∧ - (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ - (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = ss.index (i - r.start.val)) ∧ - (∀ i, r.end_.val ≤ i → i < a.length → na.index i = a.index i) := by - simp [subslice_mut_back, *] - have h := List.replace_slice_index r.start.val r.end_.val a.val ss.val - (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) - simp [List.replace_slice, *] at h - have ⟨ h0, h1, h2 ⟩ := h - clear h - split_conjs - . intro i _ _ - have := h0 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h1 i (by int_tac) (by int_tac) - simp [*] - . intro i _ _ - have := h2 i (by int_tac) (by int_tac) - simp [*] - -end Primitives diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean new file mode 100644 index 00000000..47807a0d --- /dev/null +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -0,0 +1,560 @@ +/- Arrays/Slices -/ +import Lean +import Lean.Meta.Tactic.Simp +import Init.Data.List.Basic +import Mathlib.Tactic.RunCmd +import Mathlib.Tactic.Linarith +import Base.IList +import Base.Primitives.Scalar +import Base.Primitives.Range +import Base.Primitives.CoreOps +import Base.Arith +import Base.Progress.Base + +namespace Primitives + +open Result Error + +def Array (α : Type u) (n : Usize) := { l : List α // l.length = n.val } + +instance (a : Type u) (n : Usize) : Arith.HasIntProp (Array a n) where + prop_ty := λ v => v.val.len = n.val + prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] + +instance {α : Type u} {n : Usize} (p : Array α n → Prop) : Arith.HasIntProp (Subtype p) where + prop_ty := λ x => p x + prop := λ x => x.property + +@[simp] +abbrev Array.length {α : Type u} {n : Usize} (v : Array α n) : Int := v.val.len + +@[simp] +abbrev Array.v {α : Type u} {n : Usize} (v : Array α n) : List α := v.val + +example {α: Type u} {n : Usize} (v : Array α n) : v.length ≤ Scalar.max ScalarTy.Usize := by + scalar_tac + +def Array.make (α : Type u) (n : Usize) (init : List α) (hl : init.len = n.val := by decide) : + Array α n := ⟨ init, by simp [← List.len_eq_length]; apply hl ⟩ + +example : Array Int (Usize.ofInt 2) := Array.make Int (Usize.ofInt 2) [0, 1] + +@[simp] +abbrev Array.index {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i : Int) : α := + v.val.index i + +@[simp] +abbrev Array.slice {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i j : Int) : List α := + v.val.slice i j + +def Array.index_shared (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +-- For initialization +def Array.repeat (α : Type u) (n : Usize) (x : α) : Array α n := + ⟨ List.ireplicate n.val x, by have h := n.hmin; simp_all [Scalar.min] ⟩ + +@[pspec] +theorem Array.repeat_spec {α : Type u} (n : Usize) (x : α) : + ∃ a, Array.repeat α n x = a ∧ a.val = List.ireplicate n.val x := by + simp [Array.repeat] + +/- In the theorems below: we don't always need the `∃ ..`, but we use one + so that `progress` introduces an opaque variable and an equality. This + helps control the context. + -/ + +@[pspec] +theorem Array.index_shared_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) + (hbound : i.val < v.length) : + ∃ x, v.index_shared α n i = ret x ∧ x = v.val.index i.val := by + simp only [index_shared] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) + simp [*] + +-- This shouldn't be used +def Array.index_shared_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (_: α) : Result Unit := + if i.val < List.length v.val then + .ret () + else + .fail arrayOutOfBounds + +def Array.index_mut (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +@[pspec] +theorem Array.index_mut_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) + (hbound : i.val < v.length) : + ∃ x, v.index_mut α n i = ret x ∧ x = v.val.index i.val := by + simp only [index_mut] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) + simp [*] + +def Array.index_mut_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (x: α) : Result (Array α n) := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some _ => + .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ + +@[pspec] +theorem Array.index_mut_back_spec {α : Type u} {n : Usize} (v: Array α n) (i: Usize) (x : α) + (hbound : i.val < v.length) : + ∃ nv, v.index_mut_back α n i x = ret nv ∧ + nv.val = v.val.update i.val x + := by + simp only [index_mut_back] + have h := List.indexOpt_bounds v.val i.val + split + . simp_all [length]; cases h <;> scalar_tac + . simp_all + +def Slice (α : Type u) := { l : List α // l.length ≤ Usize.max } + +instance (a : Type u) : Arith.HasIntProp (Slice a) where + prop_ty := λ v => 0 ≤ v.val.len ∧ v.val.len ≤ Scalar.max ScalarTy.Usize + prop := λ ⟨ _, l ⟩ => by simp[Scalar.max, List.len_eq_length, *] + +instance {α : Type u} (p : Slice α → Prop) : Arith.HasIntProp (Subtype p) where + prop_ty := λ x => p x + prop := λ x => x.property + +@[simp] +abbrev Slice.length {α : Type u} (v : Slice α) : Int := v.val.len + +@[simp] +abbrev Slice.v {α : Type u} (v : Slice α) : List α := v.val + +example {a: Type u} (v : Slice a) : v.length ≤ Scalar.max ScalarTy.Usize := by + scalar_tac + +def Slice.new (α : Type u): Slice α := ⟨ [], by apply Scalar.cMax_suffices .Usize; simp ⟩ + +-- TODO: very annoying that the α is an explicit parameter +def Slice.len (α : Type u) (v : Slice α) : Usize := + Usize.ofIntCore v.val.len (by scalar_tac) (by scalar_tac) + +@[simp] +theorem Slice.len_val {α : Type u} (v : Slice α) : (Slice.len α v).val = v.length := + by rfl + +@[simp] +abbrev Slice.index {α : Type u} [Inhabited α] (v: Slice α) (i: Int) : α := + v.val.index i + +@[simp] +abbrev Slice.slice {α : Type u} [Inhabited α] (s : Slice α) (i j : Int) : List α := + s.val.slice i j + +def Slice.index_shared (α : Type u) (v: Slice α) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +/- In the theorems below: we don't always need the `∃ ..`, but we use one + so that `progress` introduces an opaque variable and an equality. This + helps control the context. + -/ + +@[pspec] +theorem Slice.index_shared_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) + (hbound : i.val < v.length) : + ∃ x, v.index_shared α i = ret x ∧ x = v.val.index i.val := by + simp only [index_shared] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) + simp [*] + +-- This shouldn't be used +def Slice.index_shared_back (α : Type u) (v: Slice α) (i: Usize) (_: α) : Result Unit := + if i.val < List.length v.val then + .ret () + else + .fail arrayOutOfBounds + +def Slice.index_mut (α : Type u) (v: Slice α) (i: Usize) : Result α := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some x => ret x + +@[pspec] +theorem Slice.index_mut_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) + (hbound : i.val < v.length) : + ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by + simp only [index_mut] + -- TODO: dependent rewrite + have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) + simp [*] + +def Slice.index_mut_back (α : Type u) (v: Slice α) (i: Usize) (x: α) : Result (Slice α) := + match v.val.indexOpt i.val with + | none => fail .arrayOutOfBounds + | some _ => + .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ + +@[pspec] +theorem Slice.index_mut_back_spec {α : Type u} (v: Slice α) (i: Usize) (x : α) + (hbound : i.val < v.length) : + ∃ nv, v.index_mut_back α i x = ret nv ∧ + nv.val = v.val.update i.val x + := by + simp only [index_mut_back] + have h := List.indexOpt_bounds v.val i.val + split + . simp_all [length]; cases h <;> scalar_tac + . simp_all + +/- Array to slice/subslices -/ + +/- We could make this function not use the `Result` type. By making it monadic, we + push the user to use the `Array.to_slice_shared_spec` spec theorem below (through the + `progress` tactic), meaning `Array.to_slice_shared` should be considered as opaque. + All what the spec theorem reveals is that the "representative" lists are the same. -/ +def Array.to_slice_shared (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := + ret ⟨ v.val, by simp [← List.len_eq_length]; scalar_tac ⟩ + +@[pspec] +theorem Array.to_slice_shared_spec {α : Type u} {n : Usize} (v : Array α n) : + ∃ s, to_slice_shared α n v = ret s ∧ v.val = s.val := by simp [to_slice_shared] + +def Array.to_slice_mut (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := + to_slice_shared α n v + +@[pspec] +theorem Array.to_slice_mut_spec {α : Type u} {n : Usize} (v : Array α n) : + ∃ s, Array.to_slice_shared α n v = ret s ∧ v.val = s.val := to_slice_shared_spec v + +def Array.to_slice_mut_back (α : Type u) (n : Usize) (_ : Array α n) (s : Slice α) : Result (Array α n) := + if h: s.val.len = n.val then + ret ⟨ s.val, by simp [← List.len_eq_length, *] ⟩ + else fail panic + +@[pspec] +theorem Array.to_slice_mut_back_spec {α : Type u} {n : Usize} (a : Array α n) (ns : Slice α) (h : ns.val.len = n.val) : + ∃ na, to_slice_mut_back α n a ns = ret na ∧ na.val = ns.val + := by simp [to_slice_mut_back, *] + +def Array.subslice_shared (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := + -- TODO: not completely sure here + if r.start.val < r.end_.val ∧ r.end_.val ≤ a.val.len then + ret ⟨ a.val.slice r.start.val r.end_.val, + by + simp [← List.len_eq_length] + have := a.val.slice_len_le r.start.val r.end_.val + scalar_tac ⟩ + else + fail panic + +@[pspec] +theorem Array.subslice_shared_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) + (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : + ∃ s, subslice_shared α n a r = ret s ∧ + s.val = a.val.slice r.start.val r.end_.val ∧ + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) + := by + simp [subslice_shared, *] + intro i _ _ + have := List.index_slice r.start.val r.end_.val i a.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) + simp [*] + +def Array.subslice_mut (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := + Array.subslice_shared α n a r + +@[pspec] +theorem Array.subslice_mut_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) + (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : + ∃ s, subslice_mut α n a r = ret s ∧ + s.val = a.slice r.start.val r.end_.val ∧ + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) + := subslice_shared_spec a r h0 h1 + +def Array.subslice_mut_back (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) (s : Slice α) : Result (Array α n) := + -- TODO: not completely sure here + if h: r.start.val < r.end_.val ∧ r.end_.val ≤ a.length ∧ s.val.len = r.end_.val - r.start.val then + let s_beg := a.val.itake r.start.val + let s_end := a.val.idrop r.end_.val + have : s_beg.len = r.start.val := by + apply List.itake_len + . simp_all; scalar_tac + . scalar_tac + have : s_end.len = a.val.len - r.end_.val := by + apply List.idrop_len + . scalar_tac + . scalar_tac + let na := s_beg.append (s.val.append s_end) + have : na.len = a.val.len := by simp [*] + ret ⟨ na, by simp_all [← List.len_eq_length]; scalar_tac ⟩ + else + fail panic + +-- TODO: it is annoying to write `.val` everywhere. We could leverage coercions, +-- but: some symbols like `+` are already overloaded to be notations for monadic +-- operations/ +-- We should introduce special symbols for the monadic arithmetic operations +-- (the use will never write those symbols directly). +@[pspec] +theorem Array.subslice_mut_back_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (s : Slice α) + (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : s.length = r.end_.val - r.start.val) : + ∃ na, subslice_mut_back α n a r s = ret na ∧ + (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ + (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = s.index (i - r.start.val)) ∧ + (∀ i, r.end_.val ≤ i → i < n.val → na.index i = a.index i) := by + simp [subslice_mut_back, *] + have h := List.replace_slice_index r.start.val r.end_.val a.val s.val + (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) + simp [List.replace_slice] at h + have ⟨ h0, h1, h2 ⟩ := h + clear h + split_conjs + . intro i _ _ + have := h0 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h1 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h2 i (by int_tac) (by int_tac) + simp [*] + +def Slice.subslice_shared (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := + -- TODO: not completely sure here + if r.start.val < r.end_.val ∧ r.end_.val ≤ s.length then + ret ⟨ s.val.slice r.start.val r.end_.val, + by + simp [← List.len_eq_length] + have := s.val.slice_len_le r.start.val r.end_.val + scalar_tac ⟩ + else + fail panic + +@[pspec] +theorem Slice.subslice_shared_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) + (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : + ∃ ns, subslice_shared α s r = ret ns ∧ + ns.val = s.slice r.start.val r.end_.val ∧ + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) + := by + simp [subslice_shared, *] + intro i _ _ + have := List.index_slice r.start.val r.end_.val i s.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) + simp [*] + +def Slice.subslice_mut (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := + Slice.subslice_shared α s r + +@[pspec] +theorem Slice.subslice_mut_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) + (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : + ∃ ns, subslice_mut α s r = ret ns ∧ + ns.val = s.slice r.start.val r.end_.val ∧ + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) + := subslice_shared_spec s r h0 h1 + +attribute [pp_dot] List.len List.length List.index -- use the dot notation when printing +set_option pp.coercions false -- do not print coercions with ↑ (this doesn't parse) + +def Slice.subslice_mut_back (α : Type u) (s : Slice α) (r : Range Usize) (ss : Slice α) : Result (Slice α) := + -- TODO: not completely sure here + if h: r.start.val < r.end_.val ∧ r.end_.val ≤ s.length ∧ ss.val.len = r.end_.val - r.start.val then + let s_beg := s.val.itake r.start.val + let s_end := s.val.idrop r.end_.val + have : s_beg.len = r.start.val := by + apply List.itake_len + . simp_all; scalar_tac + . scalar_tac + have : s_end.len = s.val.len - r.end_.val := by + apply List.idrop_len + . scalar_tac + . scalar_tac + let ns := s_beg.append (ss.val.append s_end) + have : ns.len = s.val.len := by simp [*] + ret ⟨ ns, by simp_all [← List.len_eq_length]; scalar_tac ⟩ + else + fail panic + +@[pspec] +theorem Slice.subslice_mut_back_spec {α : Type u} [Inhabited α] (a : Slice α) (r : Range Usize) (ss : Slice α) + (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : ss.length = r.end_.val - r.start.val) : + ∃ na, subslice_mut_back α a r ss = ret na ∧ + (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ + (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = ss.index (i - r.start.val)) ∧ + (∀ i, r.end_.val ≤ i → i < a.length → na.index i = a.index i) := by + simp [subslice_mut_back, *] + have h := List.replace_slice_index r.start.val r.end_.val a.val ss.val + (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) + simp [List.replace_slice, *] at h + have ⟨ h0, h1, h2 ⟩ := h + clear h + split_conjs + . intro i _ _ + have := h0 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h1 i (by int_tac) (by int_tac) + simp [*] + . intro i _ _ + have := h2 i (by int_tac) (by int_tac) + simp [*] + +/- Trait declaration: [core::slice::index::private_slice_index::Sealed] -/ +structure core.slice.index.private_slice_index.Sealed (Self : Type) where + +/- Trait declaration: [core::slice::index::SliceIndex] -/ +structure core.slice.index.SliceIndex (Self T0 : Type) where + sealedInst :core.slice.index.private_slice_index.Sealed Self + Output : Type + get : Self → T0 → Result (Option Output) + get_mut : Self → T0 → Result (Option Output) + get_mut_back : Self → T0 → Option Output → Result T0 + get_unchecked : Self → ConstRawPtr T0 → Result (ConstRawPtr Output) + get_unchecked_mut : Self → MutRawPtr T0 → Result (MutRawPtr Output) + index : Self → T0 → Result Output + index_mut : Self → T0 → Result Output + index_mut_back : Self → T0 → Output → Result T0 + +/- [core::slice::index::[T]::index]: forward function -/ +def core.slice.index.Slice.index + (T0 I : Type) (inst : core.slice.index.SliceIndex I (Slice T0)) + (slice : Slice T0) (i : I) : Result inst.Output := do + let x ← inst.get i slice + match x with + | none => fail panic + | some x => ret x + +/- [core::slice::index::Range:::get]: forward function -/ +def core.slice.index.Range.get (T0 : Type) (i : Range Usize) (slice : Slice T0) : + Result (Option (Slice T0)) := + sorry -- TODO + +/- [core::slice::index::Range::get_mut]: forward function -/ +def core.slice.index.Range.get_mut + (T0 : Type) : Range Usize → Slice T0 → Result (Option (Slice T0)) := + sorry -- TODO + +/- [core::slice::index::Range::get_mut]: backward function 0 -/ +def core.slice.index.Range.get_mut_back + (T0 : Type) : + Range Usize → Slice T0 → Option (Slice T0) → Result (Slice T0) := + sorry -- TODO + +/- [core::slice::index::Range::get_unchecked]: forward function -/ +def core.slice.index.Range.get_unchecked + (T0 : Type) : + Range Usize → ConstRawPtr (Slice T0) → Result (ConstRawPtr (Slice T0)) := + -- Don't know what the model should be - for now we always fail to make + -- sure code which uses it fails + fun _ _ => fail panic + +/- [core::slice::index::Range::get_unchecked_mut]: forward function -/ +def core.slice.index.Range.get_unchecked_mut + (T0 : Type) : + Range Usize → MutRawPtr (Slice T0) → Result (MutRawPtr (Slice T0)) := + -- Don't know what the model should be - for now we always fail to make + -- sure code which uses it fails + fun _ _ => fail panic + +/- [core::slice::index::Range::index]: forward function -/ +def core.slice.index.Range.index + (T0 : Type) : Range Usize → Slice T0 → Result (Slice T0) := + sorry -- TODO + +/- [core::slice::index::Range::index_mut]: forward function -/ +def core.slice.index.Range.index_mut + (T0 : Type) : Range Usize → Slice T0 → Result (Slice T0) := + sorry -- TODO + +/- [core::slice::index::Range::index_mut]: backward function 0 -/ +def core.slice.index.Range.index_mut_back + (T0 : Type) : Range Usize → Slice T0 → Slice T0 → Result (Slice T0) := + sorry -- TODO + +/- [core::slice::index::[T]::index_mut]: forward function -/ +def core.slice.index.Slice.index_mut + (T0 I : Type) (inst : core.slice.index.SliceIndex I (Slice T0)) : + Slice T0 → I → Result inst.Output := + sorry -- TODO + +/- [core::slice::index::[T]::index_mut]: backward function 0 -/ +def core.slice.index.Slice.index_mut_back + (T0 I : Type) (inst : core.slice.index.SliceIndex I (Slice T0)) : + Slice T0 → I → inst.Output → Result (Slice T0) := + sorry -- TODO + +/- [core::array::[T; N]::index]: forward function -/ +def core.array.Array.index + (T0 I : Type) (N : Usize) (inst : core.ops.index.Index (Slice T0) I) : + Array T0 N → I → Result inst.Output := + sorry -- TODO + +/- [core::array::[T; N]::index_mut]: forward function -/ +def core.array.Array.index_mut + (T0 I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T0) I) : + Array T0 N → I → Result inst.indexInst.Output := + sorry -- TODO + +/- [core::array::[T; N]::index_mut]: backward function 0 -/ +def core.array.Array.index_mut_back + (T0 I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T0) I) : + Array T0 N → I → inst.indexInst.Output → Result (Array T0 N) := + sorry -- TODO + +/- Trait implementation: [core::slice::index::[T]] -/ +def core.slice.index.Slice.coreopsindexIndexInst (T0 I : Type) + (inst : core.slice.index.SliceIndex I (Slice T0)) : + core.ops.index.Index (Slice T0) I := { + Output := inst.Output + index := core.slice.index.Slice.index T0 I inst +} + +/- Trait implementation: [core::slice::index::private_slice_index::Range] -/ +def core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst + : core.slice.index.private_slice_index.Sealed (Range Usize) := {} + +/- Trait implementation: [core::slice::index::Range] -/ +def core.slice.index.Range.coresliceindexSliceIndexInst (T0 : Type) : + core.slice.index.SliceIndex (Range Usize) (Slice T0) := { + sealedInst := + core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst + Output := Slice T0 + get := core.slice.index.Range.get T0 + get_mut := core.slice.index.Range.get_mut T0 + get_mut_back := core.slice.index.Range.get_mut_back T0 + get_unchecked := core.slice.index.Range.get_unchecked T0 + get_unchecked_mut := core.slice.index.Range.get_unchecked_mut T0 + index := core.slice.index.Range.index T0 + index_mut := core.slice.index.Range.index_mut T0 + index_mut_back := core.slice.index.Range.index_mut_back T0 +} + +/- Trait implementation: [core::slice::index::[T]] -/ +def core.slice.index.Slice.coreopsindexIndexMutInst (T0 I : Type) + (inst : core.slice.index.SliceIndex I (Slice T0)) : + core.ops.index.IndexMut (Slice T0) I := { + indexInst := core.slice.index.Slice.coreopsindexIndexInst T0 I inst + index_mut := core.slice.index.Slice.index_mut T0 I inst + index_mut_back := core.slice.index.Slice.index_mut_back T0 I inst +} + +/- Trait implementation: [core::array::[T; N]] -/ +def core.array.Array.coreopsindexIndexInst (T0 I : Type) (N : Usize) + (inst : core.ops.index.Index (Slice T0) I) : + core.ops.index.Index (Array T0 N) I := { + Output := inst.Output + index := core.array.Array.index T0 I N inst +} + +/- Trait implementation: [core::array::[T; N]] -/ +def core.array.Array.coreopsindexIndexMutInst (T0 I : Type) (N : Usize) + (inst : core.ops.index.IndexMut (Slice T0) I) : + core.ops.index.IndexMut (Array T0 N) I := { + indexInst := core.array.Array.coreopsindexIndexInst T0 I N inst.indexInst + index_mut := core.array.Array.index_mut T0 I N inst + index_mut_back := core.array.Array.index_mut_back T0 I N inst +} + +end Primitives diff --git a/backends/lean/Base/Primitives/Base.lean b/backends/lean/Base/Primitives/Base.lean index 10af8f67..7fc33251 100644 --- a/backends/lean/Base/Primitives/Base.lean +++ b/backends/lean/Base/Primitives/Base.lean @@ -127,4 +127,11 @@ def Result.attach {α: Type} (o : Result α): Result { x : α // o = ret x } := Use with `simp [ aeneas ]` -/ register_simp_attr aeneas +-- We don't really use raw pointers for now +structure MutRawPtr (T : Type) where + v : T + +structure ConstRawPtr (T : Type) where + v : T + end Primitives diff --git a/backends/lean/Base/Primitives/CoreOps.lean b/backends/lean/Base/Primitives/CoreOps.lean new file mode 100644 index 00000000..da458f66 --- /dev/null +++ b/backends/lean/Base/Primitives/CoreOps.lean @@ -0,0 +1,37 @@ +import Lean +import Base.Primitives.Base + +open Primitives +open Result + +namespace core.ops + +namespace index -- core.ops.index + +/- Trait declaration: [core::ops::index::Index] -/ +structure Index (Self Idx : Type) where + Output : Type + index : Self → Idx → Result Output + +/- Trait declaration: [core::ops::index::IndexMut] -/ +structure IndexMut (Self Idx : Type) where + indexInst : Index Self Idx + index_mut : Self → Idx → Result indexInst.Output + index_mut_back : Self → Idx → indexInst.Output → Result Self + +end index -- core.ops.index + +namespace deref -- core.ops.deref + +structure Deref (Self : Type) where + Target : Type + deref : Self → Result Target + +structure DerefMut (Self : Type) where + derefInst : Deref Self + deref_mut : Self → Result derefInst.Target + deref_mut_back : Self → derefInst.Target → Result Self + +end deref -- core.ops.deref + +end core.ops diff --git a/backends/lean/Base/Primitives/CoreOpsDeref.lean b/backends/lean/Base/Primitives/CoreOpsDeref.lean deleted file mode 100644 index 2b540012..00000000 --- a/backends/lean/Base/Primitives/CoreOpsDeref.lean +++ /dev/null @@ -1,18 +0,0 @@ -import Lean -import Base.Primitives.Base - -open Primitives -open Result - -namespace core.ops.deref - -structure Deref (Self : Type) where - Target : Type - deref : Self → Result Target - -structure DerefMut (Self : Type) where - derefInst : Deref Self - deref_mut : Self → Result derefInst.Target - deref_mut_back : Self → derefInst.Target → Result Self - -end core.ops.deref diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index c4c4d9f2..99fcedc6 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -6,7 +6,7 @@ import Mathlib.Tactic.RunCmd import Mathlib.Tactic.Linarith import Base.IList import Base.Primitives.Scalar -import Base.Primitives.Array +import Base.Primitives.ArraySlice import Base.Arith import Base.Progress.Base 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 862c6f939b001e4fe0556cc73af71210e7b96ea2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 15:38:23 +0200 Subject: Regenerate the Lean array test --- tests/lean/Array/Funs.lean | 319 +++++++++++++++++++++------------------------ 1 file changed, 150 insertions(+), 169 deletions(-) diff --git a/tests/lean/Array/Funs.lean b/tests/lean/Array/Funs.lean index d3cb29d2..899bf856 100644 --- a/tests/lean/Array/Funs.lean +++ b/tests/lean/Array/Funs.lean @@ -6,35 +6,39 @@ open Primitives namespace array +/- [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def incr (x : U32) : Result U32 := + x + 1#u32 + /- [array::array_to_shared_slice_]: forward function -/ def array_to_shared_slice_ - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result (Slice T0) := - Array.to_slice_shared T0 (Usize.ofInt 32) s + (T0 : Type) (s : Array T0 32#usize) : Result (Slice T0) := + Array.to_slice_shared T0 32#usize s /- [array::array_to_mut_slice_]: forward function -/ def array_to_mut_slice_ - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result (Slice T0) := - Array.to_slice_mut T0 (Usize.ofInt 32) s + (T0 : Type) (s : Array T0 32#usize) : Result (Slice T0) := + Array.to_slice_mut T0 32#usize s /- [array::array_to_mut_slice_]: backward function 0 -/ def array_to_mut_slice__back - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (ret0 : Slice T0) : - Result (Array T0 (Usize.ofInt 32)) + (T0 : Type) (s : Array T0 32#usize) (ret0 : Slice T0) : + Result (Array T0 32#usize) := - Array.to_slice_mut_back T0 (Usize.ofInt 32) s ret0 + Array.to_slice_mut_back T0 32#usize s ret0 /- [array::array_len]: forward function -/ -def array_len (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result Usize := +def array_len (T0 : Type) (s : Array T0 32#usize) : Result Usize := do - let s0 ← Array.to_slice_shared T0 (Usize.ofInt 32) s + let s0 ← Array.to_slice_shared T0 32#usize s let i := Slice.len T0 s0 Result.ret i /- [array::shared_array_len]: forward function -/ -def shared_array_len - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result Usize := +def shared_array_len (T0 : Type) (s : Array T0 32#usize) : Result Usize := do - let s0 ← Array.to_slice_shared T0 (Usize.ofInt 32) s + let s0 ← Array.to_slice_shared T0 32#usize s let i := Slice.len T0 s0 Result.ret i @@ -45,29 +49,28 @@ def shared_slice_len (T0 : Type) (s : Slice T0) : Result Usize := /- [array::index_array_shared]: forward function -/ def index_array_shared - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (i : Usize) : Result T0 := - Array.index_shared T0 (Usize.ofInt 32) s i + (T0 : Type) (s : Array T0 32#usize) (i : Usize) : Result T0 := + Array.index_shared T0 32#usize s i /- [array::index_array_u32]: forward function -/ -def index_array_u32 - (s : Array U32 (Usize.ofInt 32)) (i : Usize) : Result U32 := - Array.index_shared U32 (Usize.ofInt 32) s i +def index_array_u32 (s : Array U32 32#usize) (i : Usize) : Result U32 := + Array.index_shared U32 32#usize s i /- [array::index_array_copy]: forward function -/ -def index_array_copy (x : Array U32 (Usize.ofInt 32)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 32) x (Usize.ofInt 0) +def index_array_copy (x : Array U32 32#usize) : Result U32 := + Array.index_shared U32 32#usize x 0#usize /- [array::index_mut_array]: forward function -/ def index_mut_array - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (i : Usize) : Result T0 := - Array.index_mut T0 (Usize.ofInt 32) s i + (T0 : Type) (s : Array T0 32#usize) (i : Usize) : Result T0 := + Array.index_mut T0 32#usize s i /- [array::index_mut_array]: backward function 0 -/ def index_mut_array_back - (T0 : Type) (s : Array T0 (Usize.ofInt 32)) (i : Usize) (ret0 : T0) : - Result (Array T0 (Usize.ofInt 32)) + (T0 : Type) (s : Array T0 32#usize) (i : Usize) (ret0 : T0) : + Result (Array T0 32#usize) := - Array.index_mut_back T0 (Usize.ofInt 32) s i ret0 + Array.index_mut_back T0 32#usize s i ret0 /- [array::index_slice]: forward function -/ def index_slice (T0 : Type) (s : Slice T0) (i : Usize) : Result T0 := @@ -85,100 +88,103 @@ def index_mut_slice_back /- [array::slice_subslice_shared_]: forward function -/ def slice_subslice_shared_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := - Slice.subslice_shared U32 x (Range.mk y z) + core.slice.index.Slice.index U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } /- [array::slice_subslice_mut_]: forward function -/ def slice_subslice_mut_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := - Slice.subslice_mut U32 x (Range.mk y z) + core.slice.index.Slice.index_mut U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } /- [array::slice_subslice_mut_]: backward function 0 -/ def slice_subslice_mut__back (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : Result (Slice U32) := - Slice.subslice_mut_back U32 x (Range.mk y z) ret0 + core.slice.index.Slice.index_mut_back U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } ret0 /- [array::array_to_slice_shared_]: forward function -/ -def array_to_slice_shared_ - (x : Array U32 (Usize.ofInt 32)) : Result (Slice U32) := - Array.to_slice_shared U32 (Usize.ofInt 32) x +def array_to_slice_shared_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice_shared U32 32#usize x /- [array::array_to_slice_mut_]: forward function -/ -def array_to_slice_mut_ - (x : Array U32 (Usize.ofInt 32)) : Result (Slice U32) := - Array.to_slice_mut U32 (Usize.ofInt 32) x +def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice_mut U32 32#usize x /- [array::array_to_slice_mut_]: backward function 0 -/ def array_to_slice_mut__back - (x : Array U32 (Usize.ofInt 32)) (ret0 : Slice U32) : - Result (Array U32 (Usize.ofInt 32)) - := - Array.to_slice_mut_back U32 (Usize.ofInt 32) x ret0 + (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := + Array.to_slice_mut_back U32 32#usize x ret0 /- [array::array_subslice_shared_]: forward function -/ def array_subslice_shared_ - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) : - Result (Slice U32) - := - Array.subslice_shared U32 (Usize.ofInt 32) x (Range.mk y z) + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } /- [array::array_subslice_mut_]: forward function -/ def array_subslice_mut_ - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) : - Result (Slice U32) - := - Array.subslice_mut U32 (Usize.ofInt 32) x (Range.mk y z) + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index_mut U32 (Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } /- [array::array_subslice_mut_]: backward function 0 -/ def array_subslice_mut__back - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) (ret0 : Slice U32) : - Result (Array U32 (Usize.ofInt 32)) + (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : + Result (Array U32 32#usize) := - Array.subslice_mut_back U32 (Usize.ofInt 32) x (Range.mk y z) ret0 + core.array.Array.index_mut_back U32 (Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } ret0 /- [array::index_slice_0]: forward function -/ def index_slice_0 (T0 : Type) (s : Slice T0) : Result T0 := - Slice.index_shared T0 s (Usize.ofInt 0) + Slice.index_shared T0 s 0#usize /- [array::index_array_0]: forward function -/ -def index_array_0 (T0 : Type) (s : Array T0 (Usize.ofInt 32)) : Result T0 := - Array.index_shared T0 (Usize.ofInt 32) s (Usize.ofInt 0) +def index_array_0 (T0 : Type) (s : Array T0 32#usize) : Result T0 := + Array.index_shared T0 32#usize s 0#usize /- [array::index_index_array]: forward function -/ def index_index_array - (s : Array (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32)) (i : Usize) - (j : Usize) : + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : Result U32 := do - let a ← - Array.index_shared (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i - Array.index_shared U32 (Usize.ofInt 32) a j + let a ← Array.index_shared (Array U32 32#usize) 32#usize s i + Array.index_shared U32 32#usize a j /- [array::update_update_array]: forward function -/ def update_update_array - (s : Array (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32)) (i : Usize) - (j : Usize) : + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : Result Unit := do - let a ← Array.index_mut (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i - let a0 ← Array.index_mut_back U32 (Usize.ofInt 32) a j (U32.ofInt 0) - let _ ← - Array.index_mut_back (Array U32 (Usize.ofInt 32)) (Usize.ofInt 32) s i a0 + let a ← Array.index_mut (Array U32 32#usize) 32#usize s i + let a0 ← Array.index_mut_back U32 32#usize a j 0#u32 + let _ ← Array.index_mut_back (Array U32 32#usize) 32#usize s i a0 Result.ret () /- [array::array_local_deep_copy]: forward function -/ -def array_local_deep_copy (x : Array U32 (Usize.ofInt 32)) : Result Unit := +def array_local_deep_copy (x : Array U32 32#usize) : Result Unit := Result.ret () /- [array::take_array]: forward function -/ -def take_array (a : Array U32 (Usize.ofInt 2)) : Result Unit := +def take_array (a : Array U32 2#usize) : Result Unit := Result.ret () /- [array::take_array_borrow]: forward function -/ -def take_array_borrow (a : Array U32 (Usize.ofInt 2)) : Result Unit := +def take_array_borrow (a : Array U32 2#usize) : Result Unit := Result.ret () /- [array::take_slice]: forward function -/ @@ -193,148 +199,133 @@ def take_mut_slice (s : Slice U32) : Result (Slice U32) := /- [array::take_all]: forward function -/ def take_all : Result Unit := do - let _ ← - take_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let _ ← - take_array_borrow - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let _ ← take_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s ← - Array.to_slice_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice_shared U32 2#usize + (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let _ ← take_slice s let s0 ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s1 ← take_mut_slice s0 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s1 + Array.to_slice_mut_back U32 2#usize + (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret () /- [array::index_array]: forward function -/ -def index_array (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def index_array (x : Array U32 2#usize) : Result U32 := + Array.index_shared U32 2#usize x 0#usize /- [array::index_array_borrow]: forward function -/ -def index_array_borrow (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def index_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_shared U32 2#usize x 0#usize /- [array::index_slice_u32_0]: forward function -/ def index_slice_u32_0 (x : Slice U32) : Result U32 := - Slice.index_shared U32 x (Usize.ofInt 0) + Slice.index_shared U32 x 0#usize /- [array::index_mut_slice_u32_0]: forward function -/ def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := - Slice.index_shared U32 x (Usize.ofInt 0) + Slice.index_shared U32 x 0#usize /- [array::index_mut_slice_u32_0]: backward function 0 -/ def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := do - let _ ← Slice.index_shared U32 x (Usize.ofInt 0) + let _ ← Slice.index_shared U32 x 0#usize Result.ret x /- [array::index_all]: forward function -/ def index_all : Result U32 := do - let i ← - index_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let i0 ← - index_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + let i ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i0 ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i1 ← i + i0 - let i2 ← - index_array_borrow - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + let i2 ← index_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i3 ← i1 + i2 let s ← - Array.to_slice_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice_shared U32 2#usize + (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i4 ← index_slice_u32_0 s let i5 ← i3 + i4 let s0 ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i6 ← index_mut_slice_u32_0 s0 let i7 ← i5 + i6 let s1 ← index_mut_slice_u32_0_back s0 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s1 + Array.to_slice_mut_back U32 2#usize + (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret i7 /- [array::update_array]: forward function -/ -def update_array (x : Array U32 (Usize.ofInt 2)) : Result Unit := +def update_array (x : Array U32 2#usize) : Result Unit := do - let _ ← - Array.index_mut_back U32 (Usize.ofInt 2) x (Usize.ofInt 0) (U32.ofInt 1) + let _ ← Array.index_mut_back U32 2#usize x 0#usize 1#u32 Result.ret () /- [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def update_array_mut_borrow - (x : Array U32 (Usize.ofInt 2)) : Result (Array U32 (Usize.ofInt 2)) := - Array.index_mut_back U32 (Usize.ofInt 2) x (Usize.ofInt 0) (U32.ofInt 1) + (x : Array U32 2#usize) : Result (Array U32 2#usize) := + Array.index_mut_back U32 2#usize x 0#usize 1#u32 /- [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def update_mut_slice (x : Slice U32) : Result (Slice U32) := - Slice.index_mut_back U32 x (Usize.ofInt 0) (U32.ofInt 1) + Slice.index_mut_back U32 x 0#usize 1#u32 /- [array::update_all]: forward function -/ def update_all : Result Unit := do - let _ ← - update_array - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let x ← - update_array_mut_borrow - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) - let s ← Array.to_slice_mut U32 (Usize.ofInt 2) x + let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let x ← update_array_mut_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s ← Array.to_slice_mut U32 2#usize x let s0 ← update_mut_slice s - let _ ← Array.to_slice_mut_back U32 (Usize.ofInt 2) x s0 + let _ ← Array.to_slice_mut_back U32 2#usize x s0 Result.ret () /- [array::range_all]: forward function -/ def range_all : Result Unit := do let s ← - Array.subslice_mut U32 (Usize.ofInt 4) - (Array.make U32 (Usize.ofInt 4) [ - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0) - ]) (Range.mk (Usize.ofInt 1) (Usize.ofInt 3)) + core.array.Array.index_mut U32 (Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } let s0 ← update_mut_slice s let _ ← - Array.subslice_mut_back U32 (Usize.ofInt 4) - (Array.make U32 (Usize.ofInt 4) [ - (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0), (U32.ofInt 0) - ]) (Range.mk (Usize.ofInt 1) (Usize.ofInt 3)) s0 + core.array.Array.index_mut_back U32 (Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } s0 Result.ret () /- [array::deref_array_borrow]: forward function -/ -def deref_array_borrow (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def deref_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_shared U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: forward function -/ -def deref_array_mut_borrow (x : Array U32 (Usize.ofInt 2)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) +def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_shared U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: backward function 0 -/ def deref_array_mut_borrow_back - (x : Array U32 (Usize.ofInt 2)) : Result (Array U32 (Usize.ofInt 2)) := + (x : Array U32 2#usize) : Result (Array U32 2#usize) := do - let _ ← Array.index_shared U32 (Usize.ofInt 2) x (Usize.ofInt 0) + let _ ← Array.index_shared U32 2#usize x 0#usize Result.ret x /- [array::take_array_t]: forward function -/ -def take_array_t (a : Array T (Usize.ofInt 2)) : Result Unit := +def take_array_t (a : Array T 2#usize) : Result Unit := Result.ret () /- [array::non_copyable_array]: forward function -/ def non_copyable_array : Result Unit := do - let _ ← take_array_t (Array.make T (Usize.ofInt 2) [ T.A, T.B ]) + let _ ← take_array_t (Array.make T 2#usize [ T.A, T.B ]) Result.ret () /- [array::sum]: loop 0: forward function -/ @@ -345,13 +336,13 @@ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := do let i1 ← Slice.index_shared U32 s i let sum1 ← sum0 + i1 - let i2 ← i + (Usize.ofInt 1) + let i2 ← i + 1#usize sum_loop s sum1 i2 else Result.ret sum0 /- [array::sum]: forward function -/ def sum (s : Slice U32) : Result U32 := - sum_loop s (U32.ofInt 0) (Usize.ofInt 0) + sum_loop s 0#u32 0#usize /- [array::sum2]: loop 0: forward function -/ divergent def sum2_loop @@ -364,7 +355,7 @@ divergent def sum2_loop let i2 ← Slice.index_shared U32 s2 i let i3 ← i1 + i2 let sum1 ← sum0 + i3 - let i4 ← i + (Usize.ofInt 1) + let i4 ← i + 1#usize sum2_loop s s2 sum1 i4 else Result.ret sum0 @@ -374,27 +365,25 @@ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := let i0 := Slice.len U32 s2 if not (i = i0) then Result.fail Error.panic - else sum2_loop s s2 (U32.ofInt 0) (Usize.ofInt 0) + else sum2_loop s s2 0#u32 0#usize /- [array::f0]: forward function -/ def f0 : Result Unit := do let s ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - let s0 ← Slice.index_mut_back U32 s (Usize.ofInt 0) (U32.ofInt 1) + Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← Slice.index_mut_back U32 s 0#usize 1#u32 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) s0 + Array.to_slice_mut_back U32 2#usize + (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 Result.ret () /- [array::f1]: forward function -/ def f1 : Result Unit := do let _ ← - Array.index_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - (Usize.ofInt 0) (U32.ofInt 1) + Array.index_mut_back U32 2#usize + (Array.make U32 2#usize [ 1#u32, 2#u32 ]) 0#usize 1#u32 Result.ret () /- [array::f2]: forward function -/ @@ -402,57 +391,49 @@ def f2 (i : U32) : Result Unit := Result.ret () /- [array::f4]: forward function -/ -def f4 - (x : Array U32 (Usize.ofInt 32)) (y : Usize) (z : Usize) : - Result (Slice U32) - := - Array.subslice_shared U32 (Usize.ofInt 32) x (Range.mk y z) +def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } /- [array::f3]: forward function -/ def f3 : Result U32 := do let i ← - Array.index_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - (Usize.ofInt 0) + Array.index_shared U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize let _ ← f2 i - let b := Array.repeat U32 (Usize.ofInt 32) (U32.ofInt 0) + let b := Array.repeat U32 32#usize 0#u32 let s ← - Array.to_slice_shared U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 1), (U32.ofInt 2) ]) - let s0 ← f4 b (Usize.ofInt 16) (Usize.ofInt 18) + Array.to_slice_shared U32 2#usize + (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← f4 b 16#usize 18#usize sum2 s s0 /- [array::SZ] -/ -def sz_body : Result Usize := Result.ret (Usize.ofInt 32) +def sz_body : Result Usize := Result.ret 32#usize def sz_c : Usize := eval_global sz_body (by simp) /- [array::f5]: forward function -/ -def f5 (x : Array U32 (Usize.ofInt 32)) : Result U32 := - Array.index_shared U32 (Usize.ofInt 32) x (Usize.ofInt 0) +def f5 (x : Array U32 32#usize) : Result U32 := + Array.index_shared U32 32#usize x 0#usize /- [array::ite]: forward function -/ def ite : Result Unit := do let s ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s0 ← - Array.to_slice_mut U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) + Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s1 ← index_mut_slice_u32_0_back s0 let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s1 + Array.to_slice_mut_back U32 2#usize + (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 let s2 ← index_mut_slice_u32_0_back s let _ ← - Array.to_slice_mut_back U32 (Usize.ofInt 2) - (Array.make U32 (Usize.ofInt 2) [ (U32.ofInt 0), (U32.ofInt 0) ]) s2 + Array.to_slice_mut_back U32 2#usize + (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s2 Result.ret () -/- [array::array]: forward function -/ -def array (LEN : Usize) : Result (Array U8 LEN) := - let a := Array.repeat U8 LEN (U8.ofInt 0) - Result.ret a - end array -- 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 --- Makefile | 6 +- backends/lean/Base/Primitives/ArraySlice.lean | 61 +- backends/lean/Base/Primitives/Range.lean | 2 +- backends/lean/Base/Primitives/Vec.lean | 74 +- backends/lean/Base/Progress/Progress.lean | 3 +- 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 + 12 files changed, 2778 insertions(+), 2775 deletions(-) create mode 100644 compiler/ExtractTypes.ml diff --git a/Makefile b/Makefile index 2c996345..958ae8d7 100644 --- a/Makefile +++ b/Makefile @@ -142,7 +142,8 @@ tcoq-loops: OPTIONS += -use-fuel -no-split-files tlean-loops: SUBDIR := thol4-loops: SUBDIR := misc-loops -trans-hashmap: OPTIONS += -no-state -test-trans-units +# TODO: reactivate -test-trans-units +trans-hashmap: OPTIONS += -no-state trans-hashmap: SUBDIR := hashmap tfstar-hashmap: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap: OPTIONS += -use-fuel @@ -150,7 +151,8 @@ tlean-hashmap: SUBDIR := tlean-hashmap: OPTIONS += -no-gen-lib-entry # We add a custom import in the Hashmap.lean file: we do not want to overwrite it thol4-hashmap: OPTIONS += -trans-hashmap_main: OPTIONS += -test-trans-units +# TODO: reactivate -test-trans-units +trans-hashmap_main: OPTIONS += trans-hashmap_main: SUBDIR := hashmap_on_disk tfstar-hashmap_main: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap_main: OPTIONS += -use-fuel diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean index 47807a0d..615e0783 100644 --- a/backends/lean/Base/Primitives/ArraySlice.lean +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -13,7 +13,7 @@ import Base.Progress.Base namespace Primitives -open Result Error +open Result Error core.ops.range def Array (α : Type u) (n : Usize) := { l : List α // l.length = n.val } @@ -406,7 +406,7 @@ structure core.slice.index.private_slice_index.Sealed (Self : Type) where /- Trait declaration: [core::slice::index::SliceIndex] -/ structure core.slice.index.SliceIndex (Self T0 : Type) where - sealedInst :core.slice.index.private_slice_index.Sealed Self + sealedInst : core.slice.index.private_slice_index.Sealed Self Output : Type get : Self → T0 → Result (Option Output) get_mut : Self → T0 → Result (Option Output) @@ -557,4 +557,61 @@ def core.array.Array.coreopsindexIndexMutInst (T0 I : Type) (N : Usize) index_mut_back := core.array.Array.index_mut_back T0 I N inst } +/- [core::slice::index::usize::get]: forward function -/ +def core.slice.index.Usize.get + (T : Type) : Usize → Slice T → Result (Option T) := + sorry -- TODO + +/- [core::slice::index::usize::get_mut]: forward function -/ +def core.slice.index.Usize.get_mut + (T : Type) : Usize → Slice T → Result (Option T) := + sorry -- TODO + +/- [core::slice::index::usize::get_mut]: backward function 0 -/ +def core.slice.index.Usize.get_mut_back + (T : Type) : Usize → Slice T → Option T → Result (Slice T) := + sorry -- TODO + +/- [core::slice::index::usize::get_unchecked]: forward function -/ +def core.slice.index.Usize.get_unchecked + (T : Type) : Usize → ConstRawPtr (Slice T) → Result (ConstRawPtr T) := + sorry -- TODO + +/- [core::slice::index::usize::get_unchecked_mut]: forward function -/ +def core.slice.index.Usize.get_unchecked_mut + (T : Type) : Usize → MutRawPtr (Slice T) → Result (MutRawPtr T) := + sorry -- TODO + +/- [core::slice::index::usize::index]: forward function -/ +def core.slice.index.Usize.index (T : Type) : Usize → Slice T → Result T := + sorry -- TODO + +/- [core::slice::index::usize::index_mut]: forward function -/ +def core.slice.index.Usize.index_mut (T : Type) : Usize → Slice T → Result T := + sorry -- TODO + +/- [core::slice::index::usize::index_mut]: backward function 0 -/ +def core.slice.index.Usize.index_mut_back + (T : Type) : Usize → Slice T → T → Result (Slice T) := + sorry -- TODO + +/- Trait implementation: [core::slice::index::private_slice_index::usize] -/ +def core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst + : core.slice.index.private_slice_index.Sealed Usize := {} + +/- Trait implementation: [core::slice::index::usize] -/ +def core.slice.index.usize.coresliceindexSliceIndexInst (T : Type) : + core.slice.index.SliceIndex Usize (Slice T) := { + sealedInst := core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst + Output := T + get := core.slice.index.Usize.get T + get_mut := core.slice.index.Usize.get_mut T + get_mut_back := core.slice.index.Usize.get_mut_back T + get_unchecked := core.slice.index.Usize.get_unchecked T + get_unchecked_mut := core.slice.index.Usize.get_unchecked_mut T + index := core.slice.index.Usize.index T + index_mut := core.slice.index.Usize.index_mut T + index_mut_back := core.slice.index.Usize.index_mut_back T +} + end Primitives diff --git a/backends/lean/Base/Primitives/Range.lean b/backends/lean/Base/Primitives/Range.lean index 26cbee42..a268bcba 100644 --- a/backends/lean/Base/Primitives/Range.lean +++ b/backends/lean/Base/Primitives/Range.lean @@ -11,7 +11,7 @@ import Base.Progress.Base namespace Primitives -structure Range (α : Type u) where +structure core.ops.range.Range (α : Type u) where mk :: start: α end_: α diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index 99fcedc6..e1b7e87b 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -14,6 +14,8 @@ namespace Primitives open Result Error +namespace alloc.vec + def Vec (α : Type u) := { l : List α // l.length ≤ Usize.max } instance (a : Type u) : Arith.HasIntProp (Vec a) where @@ -79,7 +81,7 @@ theorem Vec.insert_spec {α : Type u} (v: Vec α) (i: Usize) (x: α) ∃ nv, v.insert α i x = ret nv ∧ nv.val = v.val.update i.val x := by simp [insert, *] -def Vec.index_shared (α : Type u) (v: Vec α) (i: Usize) : Result α := +def Vec.index_usize (α : Type u) (v: Vec α) (i: Usize) : Result α := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some x => ret x @@ -90,51 +92,65 @@ def Vec.index_shared (α : Type u) (v: Vec α) (i: Usize) : Result α := -/ @[pspec] -theorem Vec.index_shared_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) +theorem Vec.index_usize_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) (hbound : i.val < v.length) : - ∃ x, v.index_shared α i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] + ∃ x, v.index_usize α i = ret x ∧ x = v.val.index i.val := by + simp only [index_usize] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) simp [*] --- This shouldn't be used -def Vec.index_back (α : Type u) (v: Vec α) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Vec.index_mut (α : Type u) (v: Vec α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Vec.index_mut_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Vec.index_mut_back (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := +def Vec.update_usize (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some _ => .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ @[pspec] -theorem Vec.index_mut_back_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) +theorem Vec.update_usize_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ + ∃ nv, v.update_usize α i x = ret nv ∧ nv.val = v.val.update i.val x := by - simp only [index_mut_back] + simp only [update_usize] have h := List.indexOpt_bounds v.val i.val split . simp_all [length]; cases h <;> scalar_tac . simp_all +/- [alloc::vec::Vec::index]: forward function -/ +def Vec.index (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (self : Vec T) (i : I) : Result inst.Output := + sorry -- TODO + +/- [alloc::vec::Vec::index_mut]: forward function -/ +def Vec.index_mut (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (self : Vec T) (i : I) : Result inst.Output := + sorry -- TODO + +/- [alloc::vec::Vec::index_mut]: backward function 0 -/ +def Vec.index_mut_back + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (self : Vec T) (i : I) (x : inst.Output) : Result (alloc.vec.Vec T) := + sorry -- TODO + +/- Trait implementation: [alloc::vec::Vec] -/ +def Vec.coreopsindexIndexInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.Index (alloc.vec.Vec T) I := { + Output := inst.Output + index := Vec.index T I inst +} + +/- Trait implementation: [alloc::vec::Vec] -/ +def Vec.coreopsindexIndexMutInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.IndexMut (alloc.vec.Vec T) I := { + indexInst := Vec.coreopsindexIndexInst T I inst + index_mut := Vec.index_mut T I inst + index_mut_back := Vec.index_mut_back T I inst +} + +end alloc.vec + end Primitives diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index ecf05dab..24c6f912 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -383,6 +383,7 @@ namespace Test -- #eval showStoredPSpec -- #eval showStoredPSpecClass -- #eval showStoredPSpecExprClass + open alloc.vec example {ty} {x y : Scalar ty} (hmin : Scalar.min ty ≤ x.val + y.val) @@ -408,7 +409,7 @@ namespace Test `α : Type u` where u is quantified, while here we use `α : Type 0` -/ example {α : Type} (v: Vec α) (i: Usize) (x : α) (hbounds : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ + ∃ nv, v.update_usize α i x = ret nv ∧ nv.val = v.val.update i.val x := by progress simp [*] 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 4e70d285b35d25c172e7bedd204ec885ef91d146 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 25 Oct 2023 18:46:44 +0200 Subject: Regenerate the hashmap files --- tests/lean/Hashmap/Funs.lean | 217 +++++++++++++++++++++++++----------------- tests/lean/Hashmap/Types.lean | 2 +- 2 files changed, 133 insertions(+), 86 deletions(-) diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index 01c61de4..8464c432 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -12,18 +12,22 @@ def hash_key (k : Usize) : Result Usize := /- [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function -/ divergent def HashMap.allocate_slots_loop - (T : Type) (slots : Vec (List T)) (n : Usize) : Result (Vec (List T)) := - if n > (Usize.ofInt 0) + (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : + Result (alloc.vec.Vec (List T)) + := + if n > 0#usize then do - let slots0 ← Vec.push (List T) slots List.Nil - let n0 ← n - (Usize.ofInt 1) + let slots0 ← alloc.vec.Vec.push (List T) slots List.Nil + let n0 ← n - 1#usize HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots /- [hashmap::HashMap::{0}::allocate_slots]: forward function -/ def HashMap.allocate_slots - (T : Type) (slots : Vec (List T)) (n : Usize) : Result (Vec (List T)) := + (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : + Result (alloc.vec.Vec (List T)) + := HashMap.allocate_slots_loop T slots n /- [hashmap::HashMap::{0}::new_with_capacity]: forward function -/ @@ -33,13 +37,13 @@ def HashMap.new_with_capacity Result (HashMap T) := do - let v := Vec.new (List T) + let v := alloc.vec.Vec.new (List T) let slots ← HashMap.allocate_slots T v capacity let i ← capacity * max_load_dividend let i0 ← i / max_load_divisor Result.ret { - num_entries := (Usize.ofInt 0), + num_entries := 0#usize, max_load_factor := (max_load_dividend, max_load_divisor), max_load := i0, slots := slots @@ -47,18 +51,23 @@ def HashMap.new_with_capacity /- [hashmap::HashMap::{0}::new]: forward function -/ def HashMap.new (T : Type) : Result (HashMap T) := - HashMap.new_with_capacity T (Usize.ofInt 32) (Usize.ofInt 4) (Usize.ofInt 5) + HashMap.new_with_capacity T 32#usize 4#usize 5#usize /- [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.clear_loop - (T : Type) (slots : Vec (List T)) (i : Usize) : Result (Vec (List T)) := - let i0 := Vec.len (List T) slots + (T : Type) (slots : alloc.vec.Vec (List T)) (i : Usize) : + Result (alloc.vec.Vec (List T)) + := + let i0 := alloc.vec.Vec.len (List T) slots if i < i0 then do - let i1 ← i + (Usize.ofInt 1) - let slots0 ← Vec.index_mut_back (List T) slots i List.Nil + let i1 ← i + 1#usize + let slots0 ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots + i List.Nil HashMap.clear_loop T slots0 i1 else Result.ret slots @@ -66,8 +75,8 @@ divergent def HashMap.clear_loop (there is a single backward function, and the forward function returns ()) -/ def HashMap.clear (T : Type) (self : HashMap T) : Result (HashMap T) := do - let v ← HashMap.clear_loop T self.slots (Usize.ofInt 0) - Result.ret { self with num_entries := (Usize.ofInt 0), slots := v } + let v ← HashMap.clear_loop T self.slots 0#usize + Result.ret { self with num_entries := 0#usize, slots := v } /- [hashmap::HashMap::{0}::len]: forward function -/ def HashMap.len (T : Type) (self : HashMap T) : Result Usize := @@ -115,21 +124,30 @@ def HashMap.insert_no_resize := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let inserted ← HashMap.insert_in_list T key value l if inserted then do - let i0 ← self.num_entries + (Usize.ofInt 1) + let i0 ← self.num_entries + 1#usize let l0 ← HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } else do let l0 ← HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } /- [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function @@ -152,27 +170,35 @@ def HashMap.move_elements_from_list /- [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.move_elements_loop - (T : Type) (ntable : HashMap T) (slots : Vec (List T)) (i : Usize) : - Result ((HashMap T) × (Vec (List T))) + (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) + : + Result ((HashMap T) × (alloc.vec.Vec (List T))) := - let i0 := Vec.len (List T) slots + let i0 := alloc.vec.Vec.len (List T) slots if i < i0 then do - let l ← Vec.index_mut (List T) slots i - let ls := mem.replace (List T) l List.Nil + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots + i + let ls := core.mem.replace (List T) l List.Nil let ntable0 ← HashMap.move_elements_from_list T ntable ls - let i1 ← i + (Usize.ofInt 1) - let l0 := mem.replace_back (List T) l List.Nil - let slots0 ← Vec.index_mut_back (List T) slots i l0 + let i1 ← i + 1#usize + let l0 := core.mem.replace_back (List T) l List.Nil + let slots0 ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots + i l0 HashMap.move_elements_loop T ntable0 slots0 i1 else Result.ret (ntable, slots) /- [hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.move_elements - (T : Type) (ntable : HashMap T) (slots : Vec (List T)) (i : Usize) : - Result ((HashMap T) × (Vec (List T))) + (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) + : + Result ((HashMap T) × (alloc.vec.Vec (List T))) := HashMap.move_elements_loop T ntable slots i @@ -181,17 +207,16 @@ def HashMap.move_elements def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := do let max_usize ← Scalar.cast .Usize core_u32_max - let capacity := Vec.len (List T) self.slots - let n1 ← max_usize / (Usize.ofInt 2) + let capacity := alloc.vec.Vec.len (List T) self.slots + let n1 ← max_usize / 2#usize let (i, i0) := self.max_load_factor let i1 ← n1 / i if capacity <= i1 then do - let i2 ← capacity * (Usize.ofInt 2) + let i2 ← capacity * 2#usize let ntable ← HashMap.new_with_capacity T i2 i i0 - let (ntable0, _) ← - HashMap.move_elements T ntable self.slots (Usize.ofInt 0) + let (ntable0, _) ← HashMap.move_elements T ntable self.slots 0#usize Result.ret { ntable0 @@ -233,9 +258,12 @@ def HashMap.contains_key (T : Type) (self : HashMap T) (key : Usize) : Result Bool := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod HashMap.contains_key_in_list T key l /- [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function -/ @@ -256,9 +284,12 @@ def HashMap.get_in_list (T : Type) (key : Usize) (ls : List T) : Result T := def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod HashMap.get_in_list T key l /- [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function -/ @@ -298,9 +329,12 @@ def HashMap.get_mut_in_list_back def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod HashMap.get_mut_in_list T l key /- [hashmap::HashMap::{0}::get_mut]: backward function 0 -/ @@ -310,11 +344,17 @@ def HashMap.get_mut_back := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let l0 ← HashMap.get_mut_in_list_back T l key ret0 - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } /- [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function -/ @@ -324,12 +364,12 @@ divergent def HashMap.remove_from_list_loop | List.Cons ckey t tl => if ckey = key then - let mv_ls := mem.replace (List T) (List.Cons ckey t tl) List.Nil + let mv_ls := core.mem.replace (List T) (List.Cons ckey t tl) List.Nil match mv_ls with - | List.Cons i cvalue tl0 => Result.ret (Option.some cvalue) + | List.Cons i cvalue tl0 => Result.ret (some cvalue) | List.Nil => Result.fail Error.panic else HashMap.remove_from_list_loop T key tl - | List.Nil => Result.ret Option.none + | List.Nil => Result.ret none /- [hashmap::HashMap::{0}::remove_from_list]: forward function -/ def HashMap.remove_from_list @@ -343,7 +383,7 @@ divergent def HashMap.remove_from_list_loop_back | List.Cons ckey t tl => if ckey = key then - let mv_ls := mem.replace (List T) (List.Cons ckey t tl) List.Nil + let mv_ls := core.mem.replace (List T) (List.Cons ckey t tl) List.Nil match mv_ls with | List.Cons i cvalue tl0 => Result.ret tl0 | List.Nil => Result.fail Error.panic @@ -363,84 +403,91 @@ def HashMap.remove (T : Type) (self : HashMap T) (key : Usize) : Result (Option T) := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let x ← HashMap.remove_from_list T key l match x with - | Option.none => Result.ret Option.none - | Option.some x0 => - do - let _ ← self.num_entries - (Usize.ofInt 1) - Result.ret (Option.some x0) + | none => Result.ret none + | some x0 => do + let _ ← self.num_entries - 1#usize + Result.ret (some x0) /- [hashmap::HashMap::{0}::remove]: backward function 0 -/ def HashMap.remove_back (T : Type) (self : HashMap T) (key : Usize) : Result (HashMap T) := do let hash ← hash_key key - let i := Vec.len (List T) self.slots + let i := alloc.vec.Vec.len (List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod let x ← HashMap.remove_from_list T key l match x with - | Option.none => + | none => do let l0 ← HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } - | Option.some x0 => + | some x0 => do - let i0 ← self.num_entries - (Usize.ofInt 1) + let i0 ← self.num_entries - 1#usize let l0 ← HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) + self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } /- [hashmap::test1]: forward function -/ def test1 : Result Unit := do let hm ← HashMap.new U64 - let hm0 ← HashMap.insert U64 hm (Usize.ofInt 0) (U64.ofInt 42) - let hm1 ← HashMap.insert U64 hm0 (Usize.ofInt 128) (U64.ofInt 18) - let hm2 ← HashMap.insert U64 hm1 (Usize.ofInt 1024) (U64.ofInt 138) - let hm3 ← HashMap.insert U64 hm2 (Usize.ofInt 1056) (U64.ofInt 256) - let i ← HashMap.get U64 hm3 (Usize.ofInt 128) - if not (i = (U64.ofInt 18)) + let hm0 ← HashMap.insert U64 hm 0#usize 42#u64 + let hm1 ← HashMap.insert U64 hm0 128#usize 18#u64 + let hm2 ← HashMap.insert U64 hm1 1024#usize 138#u64 + let hm3 ← HashMap.insert U64 hm2 1056#usize 256#u64 + let i ← HashMap.get U64 hm3 128#usize + if not (i = 18#u64) then Result.fail Error.panic else do - let hm4 ← - HashMap.get_mut_back U64 hm3 (Usize.ofInt 1024) (U64.ofInt 56) - let i0 ← HashMap.get U64 hm4 (Usize.ofInt 1024) - if not (i0 = (U64.ofInt 56)) + let hm4 ← HashMap.get_mut_back U64 hm3 1024#usize 56#u64 + let i0 ← HashMap.get U64 hm4 1024#usize + if not (i0 = 56#u64) then Result.fail Error.panic else do - let x ← HashMap.remove U64 hm4 (Usize.ofInt 1024) + let x ← HashMap.remove U64 hm4 1024#usize match x with - | Option.none => Result.fail Error.panic - | Option.some x0 => - if not (x0 = (U64.ofInt 56)) + | none => Result.fail Error.panic + | some x0 => + if not (x0 = 56#u64) then Result.fail Error.panic else do - let hm5 ← HashMap.remove_back U64 hm4 (Usize.ofInt 1024) - let i1 ← HashMap.get U64 hm5 (Usize.ofInt 0) - if not (i1 = (U64.ofInt 42)) + let hm5 ← HashMap.remove_back U64 hm4 1024#usize + let i1 ← HashMap.get U64 hm5 0#usize + if not (i1 = 42#u64) then Result.fail Error.panic else do - let i2 ← HashMap.get U64 hm5 (Usize.ofInt 128) - if not (i2 = (U64.ofInt 18)) + let i2 ← HashMap.get U64 hm5 128#usize + if not (i2 = 18#u64) then Result.fail Error.panic else do - let i3 ← HashMap.get U64 hm5 (Usize.ofInt 1056) - if not (i3 = (U64.ofInt 256)) + let i3 ← HashMap.get U64 hm5 1056#usize + if not (i3 = 256#u64) then Result.fail Error.panic else Result.ret () -/- Unit test for [hashmap::test1] -/ -#assert (test1 == .ret ()) - end hashmap diff --git a/tests/lean/Hashmap/Types.lean b/tests/lean/Hashmap/Types.lean index 6455798d..e007bce0 100644 --- a/tests/lean/Hashmap/Types.lean +++ b/tests/lean/Hashmap/Types.lean @@ -15,6 +15,6 @@ structure HashMap (T : Type) where num_entries : Usize max_load_factor : (Usize × Usize) max_load : Usize - slots : Vec (List T) + slots : alloc.vec.Vec (List T) end hashmap -- 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(-) 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 --- backends/lean/Base/Primitives/ArraySlice.lean | 164 ++++++++----------------- compiler/Extract.ml | 2 +- compiler/ExtractBase.ml | 165 ++++++++++++++++---------- compiler/ExtractTypes.ml | 48 ++++---- compiler/Translate.ml | 21 +--- 5 files changed, 180 insertions(+), 220 deletions(-) diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean index 615e0783..2a080ca6 100644 --- a/backends/lean/Base/Primitives/ArraySlice.lean +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -40,14 +40,14 @@ def Array.make (α : Type u) (n : Usize) (init : List α) (hl : init.len = n.val example : Array Int (Usize.ofInt 2) := Array.make Int (Usize.ofInt 2) [0, 1] @[simp] -abbrev Array.index {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i : Int) : α := +abbrev Array.index_s {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i : Int) : α := v.val.index i @[simp] abbrev Array.slice {α : Type u} {n : Usize} [Inhabited α] (v : Array α n) (i j : Int) : List α := v.val.slice i j -def Array.index_shared (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := +def Array.index_usize (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some x => ret x @@ -67,48 +67,27 @@ theorem Array.repeat_spec {α : Type u} (n : Usize) (x : α) : -/ @[pspec] -theorem Array.index_shared_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) +theorem Array.index_usize_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) (hbound : i.val < v.length) : - ∃ x, v.index_shared α n i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] + ∃ x, v.index_usize α n i = ret x ∧ x = v.val.index i.val := by + simp only [index_usize] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) simp [*] --- This shouldn't be used -def Array.index_shared_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (_: α) : Result Unit := - if i.val < List.length v.val then - .ret () - else - .fail arrayOutOfBounds - -def Array.index_mut (α : Type u) (n : Usize) (v: Array α n) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Array.index_mut_spec {α : Type u} {n : Usize} [Inhabited α] (v: Array α n) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α n i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Array.index_mut_back (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (x: α) : Result (Array α n) := +def Array.update_usize (α : Type u) (n : Usize) (v: Array α n) (i: Usize) (x: α) : Result (Array α n) := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some _ => .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ @[pspec] -theorem Array.index_mut_back_spec {α : Type u} {n : Usize} (v: Array α n) (i: Usize) (x : α) +theorem Array.update_usize_spec {α : Type u} {n : Usize} (v: Array α n) (i: Usize) (x : α) (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α n i x = ret nv ∧ + ∃ nv, v.update_usize α n i x = ret nv ∧ nv.val = v.val.update i.val x := by - simp only [index_mut_back] + simp only [update_usize] have h := List.indexOpt_bounds v.val i.val split . simp_all [length]; cases h <;> scalar_tac @@ -144,14 +123,14 @@ theorem Slice.len_val {α : Type u} (v : Slice α) : (Slice.len α v).val = v.le by rfl @[simp] -abbrev Slice.index {α : Type u} [Inhabited α] (v: Slice α) (i: Int) : α := +abbrev Slice.index_s {α : Type u} [Inhabited α] (v: Slice α) (i: Int) : α := v.val.index i @[simp] abbrev Slice.slice {α : Type u} [Inhabited α] (s : Slice α) (i j : Int) : List α := s.val.slice i j -def Slice.index_shared (α : Type u) (v: Slice α) (i: Usize) : Result α := +def Slice.index_usize (α : Type u) (v: Slice α) (i: Usize) : Result α := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some x => ret x @@ -162,10 +141,10 @@ def Slice.index_shared (α : Type u) (v: Slice α) (i: Usize) : Result α := -/ @[pspec] -theorem Slice.index_shared_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) +theorem Slice.index_usize_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) (hbound : i.val < v.length) : - ∃ x, v.index_shared α i = ret x ∧ x = v.val.index i.val := by - simp only [index_shared] + ∃ x, v.index_usize α i = ret x ∧ x = v.val.index i.val := by + simp only [index_usize] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) simp [*] @@ -177,33 +156,19 @@ def Slice.index_shared_back (α : Type u) (v: Slice α) (i: Usize) (_: α) : Res else .fail arrayOutOfBounds -def Slice.index_mut (α : Type u) (v: Slice α) (i: Usize) : Result α := - match v.val.indexOpt i.val with - | none => fail .arrayOutOfBounds - | some x => ret x - -@[pspec] -theorem Slice.index_mut_spec {α : Type u} [Inhabited α] (v: Slice α) (i: Usize) - (hbound : i.val < v.length) : - ∃ x, v.index_mut α i = ret x ∧ x = v.val.index i.val := by - simp only [index_mut] - -- TODO: dependent rewrite - have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) - simp [*] - -def Slice.index_mut_back (α : Type u) (v: Slice α) (i: Usize) (x: α) : Result (Slice α) := +def Slice.update_usize (α : Type u) (v: Slice α) (i: Usize) (x: α) : Result (Slice α) := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some _ => .ret ⟨ v.val.update i.val x, by have := v.property; simp [*] ⟩ @[pspec] -theorem Slice.index_mut_back_spec {α : Type u} (v: Slice α) (i: Usize) (x : α) +theorem Slice.update_usize_spec {α : Type u} (v: Slice α) (i: Usize) (x : α) (hbound : i.val < v.length) : - ∃ nv, v.index_mut_back α i x = ret nv ∧ + ∃ nv, v.update_usize α i x = ret nv ∧ nv.val = v.val.update i.val x := by - simp only [index_mut_back] + simp only [update_usize] have h := List.indexOpt_bounds v.val i.val split . simp_all [length]; cases h <;> scalar_tac @@ -212,34 +177,27 @@ theorem Slice.index_mut_back_spec {α : Type u} (v: Slice α) (i: Usize) (x : α /- Array to slice/subslices -/ /- We could make this function not use the `Result` type. By making it monadic, we - push the user to use the `Array.to_slice_shared_spec` spec theorem below (through the - `progress` tactic), meaning `Array.to_slice_shared` should be considered as opaque. + push the user to use the `Array.to_slice_spec` spec theorem below (through the + `progress` tactic), meaning `Array.to_slice` should be considered as opaque. All what the spec theorem reveals is that the "representative" lists are the same. -/ -def Array.to_slice_shared (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := +def Array.to_slice (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := ret ⟨ v.val, by simp [← List.len_eq_length]; scalar_tac ⟩ @[pspec] -theorem Array.to_slice_shared_spec {α : Type u} {n : Usize} (v : Array α n) : - ∃ s, to_slice_shared α n v = ret s ∧ v.val = s.val := by simp [to_slice_shared] - -def Array.to_slice_mut (α : Type u) (n : Usize) (v : Array α n) : Result (Slice α) := - to_slice_shared α n v +theorem Array.to_slice_spec {α : Type u} {n : Usize} (v : Array α n) : + ∃ s, to_slice α n v = ret s ∧ v.val = s.val := by simp [to_slice] -@[pspec] -theorem Array.to_slice_mut_spec {α : Type u} {n : Usize} (v : Array α n) : - ∃ s, Array.to_slice_shared α n v = ret s ∧ v.val = s.val := to_slice_shared_spec v - -def Array.to_slice_mut_back (α : Type u) (n : Usize) (_ : Array α n) (s : Slice α) : Result (Array α n) := +def Array.from_slice (α : Type u) (n : Usize) (_ : Array α n) (s : Slice α) : Result (Array α n) := if h: s.val.len = n.val then ret ⟨ s.val, by simp [← List.len_eq_length, *] ⟩ else fail panic @[pspec] -theorem Array.to_slice_mut_back_spec {α : Type u} {n : Usize} (a : Array α n) (ns : Slice α) (h : ns.val.len = n.val) : - ∃ na, to_slice_mut_back α n a ns = ret na ∧ na.val = ns.val - := by simp [to_slice_mut_back, *] +theorem Array.from_slice_spec {α : Type u} {n : Usize} (a : Array α n) (ns : Slice α) (h : ns.val.len = n.val) : + ∃ na, from_slice α n a ns = ret na ∧ na.val = ns.val + := by simp [from_slice, *] -def Array.subslice_shared (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := +def Array.subslice (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := -- TODO: not completely sure here if r.start.val < r.end_.val ∧ r.end_.val ≤ a.val.len then ret ⟨ a.val.slice r.start.val r.end_.val, @@ -251,29 +209,18 @@ def Array.subslice_shared (α : Type u) (n : Usize) (a : Array α n) (r : Range fail panic @[pspec] -theorem Array.subslice_shared_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) +theorem Array.subslice_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : - ∃ s, subslice_shared α n a r = ret s ∧ + ∃ s, subslice α n a r = ret s ∧ s.val = a.val.slice r.start.val r.end_.val ∧ (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) := by - simp [subslice_shared, *] + simp [subslice, *] intro i _ _ have := List.index_slice r.start.val r.end_.val i a.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) simp [*] -def Array.subslice_mut (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) : Result (Slice α) := - Array.subslice_shared α n a r - -@[pspec] -theorem Array.subslice_mut_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ a.val.len) : - ∃ s, subslice_mut α n a r = ret s ∧ - s.val = a.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → s.val.index i = a.val.index (r.start.val + i)) - := subslice_shared_spec a r h0 h1 - -def Array.subslice_mut_back (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) (s : Slice α) : Result (Array α n) := +def Array.update_subslice (α : Type u) (n : Usize) (a : Array α n) (r : Range Usize) (s : Slice α) : Result (Array α n) := -- TODO: not completely sure here if h: r.start.val < r.end_.val ∧ r.end_.val ≤ a.length ∧ s.val.len = r.end_.val - r.start.val then let s_beg := a.val.itake r.start.val @@ -298,13 +245,13 @@ def Array.subslice_mut_back (α : Type u) (n : Usize) (a : Array α n) (r : Rang -- We should introduce special symbols for the monadic arithmetic operations -- (the use will never write those symbols directly). @[pspec] -theorem Array.subslice_mut_back_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (s : Slice α) +theorem Array.update_subslice_spec {α : Type u} {n : Usize} [Inhabited α] (a : Array α n) (r : Range Usize) (s : Slice α) (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : s.length = r.end_.val - r.start.val) : - ∃ na, subslice_mut_back α n a r s = ret na ∧ - (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ - (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = s.index (i - r.start.val)) ∧ - (∀ i, r.end_.val ≤ i → i < n.val → na.index i = a.index i) := by - simp [subslice_mut_back, *] + ∃ na, update_subslice α n a r s = ret na ∧ + (∀ i, 0 ≤ i → i < r.start.val → na.index_s i = a.index_s i) ∧ + (∀ i, r.start.val ≤ i → i < r.end_.val → na.index_s i = s.index_s (i - r.start.val)) ∧ + (∀ i, r.end_.val ≤ i → i < n.val → na.index_s i = a.index_s i) := by + simp [update_subslice, *] have h := List.replace_slice_index r.start.val r.end_.val a.val s.val (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) simp [List.replace_slice] at h @@ -321,7 +268,7 @@ theorem Array.subslice_mut_back_spec {α : Type u} {n : Usize} [Inhabited α] (a have := h2 i (by int_tac) (by int_tac) simp [*] -def Slice.subslice_shared (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := +def Slice.subslice (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := -- TODO: not completely sure here if r.start.val < r.end_.val ∧ r.end_.val ≤ s.length then ret ⟨ s.val.slice r.start.val r.end_.val, @@ -333,32 +280,21 @@ def Slice.subslice_shared (α : Type u) (s : Slice α) (r : Range Usize) : Resul fail panic @[pspec] -theorem Slice.subslice_shared_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) +theorem Slice.subslice_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : - ∃ ns, subslice_shared α s r = ret ns ∧ + ∃ ns, subslice α s r = ret ns ∧ ns.val = s.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) + (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index_s i = s.index_s (r.start.val + i)) := by - simp [subslice_shared, *] + simp [subslice, *] intro i _ _ have := List.index_slice r.start.val r.end_.val i s.val (by scalar_tac) (by scalar_tac) (by trivial) (by scalar_tac) simp [*] -def Slice.subslice_mut (α : Type u) (s : Slice α) (r : Range Usize) : Result (Slice α) := - Slice.subslice_shared α s r - -@[pspec] -theorem Slice.subslice_mut_spec {α : Type u} [Inhabited α] (s : Slice α) (r : Range Usize) - (h0 : r.start.val < r.end_.val) (h1 : r.end_.val ≤ s.val.len) : - ∃ ns, subslice_mut α s r = ret ns ∧ - ns.val = s.slice r.start.val r.end_.val ∧ - (∀ i, 0 ≤ i → i + r.start.val < r.end_.val → ns.index i = s.index (r.start.val + i)) - := subslice_shared_spec s r h0 h1 - attribute [pp_dot] List.len List.length List.index -- use the dot notation when printing set_option pp.coercions false -- do not print coercions with ↑ (this doesn't parse) -def Slice.subslice_mut_back (α : Type u) (s : Slice α) (r : Range Usize) (ss : Slice α) : Result (Slice α) := +def Slice.update_subslice (α : Type u) (s : Slice α) (r : Range Usize) (ss : Slice α) : Result (Slice α) := -- TODO: not completely sure here if h: r.start.val < r.end_.val ∧ r.end_.val ≤ s.length ∧ ss.val.len = r.end_.val - r.start.val then let s_beg := s.val.itake r.start.val @@ -378,13 +314,13 @@ def Slice.subslice_mut_back (α : Type u) (s : Slice α) (r : Range Usize) (ss : fail panic @[pspec] -theorem Slice.subslice_mut_back_spec {α : Type u} [Inhabited α] (a : Slice α) (r : Range Usize) (ss : Slice α) +theorem Slice.update_subslice_spec {α : Type u} [Inhabited α] (a : Slice α) (r : Range Usize) (ss : Slice α) (_ : r.start.val < r.end_.val) (_ : r.end_.val ≤ a.length) (_ : ss.length = r.end_.val - r.start.val) : - ∃ na, subslice_mut_back α a r ss = ret na ∧ - (∀ i, 0 ≤ i → i < r.start.val → na.index i = a.index i) ∧ - (∀ i, r.start.val ≤ i → i < r.end_.val → na.index i = ss.index (i - r.start.val)) ∧ - (∀ i, r.end_.val ≤ i → i < a.length → na.index i = a.index i) := by - simp [subslice_mut_back, *] + ∃ na, update_subslice α a r ss = ret na ∧ + (∀ i, 0 ≤ i → i < r.start.val → na.index_s i = a.index_s i) ∧ + (∀ i, r.start.val ≤ i → i < r.end_.val → na.index_s i = ss.index_s (i - r.start.val)) ∧ + (∀ i, r.end_.val ≤ i → i < a.length → na.index_s i = a.index_s i) := by + simp [update_subslice, *] have h := List.replace_slice_index r.start.val r.end_.val a.val ss.val (by scalar_tac) (by scalar_tac) (by scalar_tac) (by scalar_tac) simp [List.replace_slice, *] at h 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(-) 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 --- backends/lean/Base/Primitives/ArraySlice.lean | 128 +++++++++++++------------- compiler/ExtractBuiltin.ml | 32 +++++-- 2 files changed, 88 insertions(+), 72 deletions(-) diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean index 2a080ca6..cfc9a6b2 100644 --- a/backends/lean/Base/Primitives/ArraySlice.lean +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -341,110 +341,110 @@ theorem Slice.update_subslice_spec {α : Type u} [Inhabited α] (a : Slice α) ( structure core.slice.index.private_slice_index.Sealed (Self : Type) where /- Trait declaration: [core::slice::index::SliceIndex] -/ -structure core.slice.index.SliceIndex (Self T0 : Type) where +structure core.slice.index.SliceIndex (Self T : Type) where sealedInst : core.slice.index.private_slice_index.Sealed Self Output : Type - get : Self → T0 → Result (Option Output) - get_mut : Self → T0 → Result (Option Output) - get_mut_back : Self → T0 → Option Output → Result T0 - get_unchecked : Self → ConstRawPtr T0 → Result (ConstRawPtr Output) - get_unchecked_mut : Self → MutRawPtr T0 → Result (MutRawPtr Output) - index : Self → T0 → Result Output - index_mut : Self → T0 → Result Output - index_mut_back : Self → T0 → Output → Result T0 + get : Self → T → Result (Option Output) + get_mut : Self → T → Result (Option Output) + get_mut_back : Self → T → Option Output → Result T + get_unchecked : Self → ConstRawPtr T → Result (ConstRawPtr Output) + get_unchecked_mut : Self → MutRawPtr T → Result (MutRawPtr Output) + index : Self → T → Result Output + index_mut : Self → T → Result Output + index_mut_back : Self → T → Output → Result T /- [core::slice::index::[T]::index]: forward function -/ def core.slice.index.Slice.index - (T0 I : Type) (inst : core.slice.index.SliceIndex I (Slice T0)) - (slice : Slice T0) (i : I) : Result inst.Output := do + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) + (slice : Slice T) (i : I) : Result inst.Output := do let x ← inst.get i slice match x with | none => fail panic | some x => ret x /- [core::slice::index::Range:::get]: forward function -/ -def core.slice.index.Range.get (T0 : Type) (i : Range Usize) (slice : Slice T0) : - Result (Option (Slice T0)) := +def core.slice.index.Range.get (T : Type) (i : Range Usize) (slice : Slice T) : + Result (Option (Slice T)) := sorry -- TODO /- [core::slice::index::Range::get_mut]: forward function -/ def core.slice.index.Range.get_mut - (T0 : Type) : Range Usize → Slice T0 → Result (Option (Slice T0)) := + (T : Type) : Range Usize → Slice T → Result (Option (Slice T)) := sorry -- TODO /- [core::slice::index::Range::get_mut]: backward function 0 -/ def core.slice.index.Range.get_mut_back - (T0 : Type) : - Range Usize → Slice T0 → Option (Slice T0) → Result (Slice T0) := + (T : Type) : + Range Usize → Slice T → Option (Slice T) → Result (Slice T) := sorry -- TODO /- [core::slice::index::Range::get_unchecked]: forward function -/ def core.slice.index.Range.get_unchecked - (T0 : Type) : - Range Usize → ConstRawPtr (Slice T0) → Result (ConstRawPtr (Slice T0)) := + (T : Type) : + Range Usize → ConstRawPtr (Slice T) → Result (ConstRawPtr (Slice T)) := -- Don't know what the model should be - for now we always fail to make -- sure code which uses it fails fun _ _ => fail panic /- [core::slice::index::Range::get_unchecked_mut]: forward function -/ def core.slice.index.Range.get_unchecked_mut - (T0 : Type) : - Range Usize → MutRawPtr (Slice T0) → Result (MutRawPtr (Slice T0)) := + (T : Type) : + Range Usize → MutRawPtr (Slice T) → Result (MutRawPtr (Slice T)) := -- Don't know what the model should be - for now we always fail to make -- sure code which uses it fails fun _ _ => fail panic /- [core::slice::index::Range::index]: forward function -/ def core.slice.index.Range.index - (T0 : Type) : Range Usize → Slice T0 → Result (Slice T0) := + (T : Type) : Range Usize → Slice T → Result (Slice T) := sorry -- TODO /- [core::slice::index::Range::index_mut]: forward function -/ def core.slice.index.Range.index_mut - (T0 : Type) : Range Usize → Slice T0 → Result (Slice T0) := + (T : Type) : Range Usize → Slice T → Result (Slice T) := sorry -- TODO /- [core::slice::index::Range::index_mut]: backward function 0 -/ def core.slice.index.Range.index_mut_back - (T0 : Type) : Range Usize → Slice T0 → Slice T0 → Result (Slice T0) := + (T : Type) : Range Usize → Slice T → Slice T → Result (Slice T) := sorry -- TODO /- [core::slice::index::[T]::index_mut]: forward function -/ def core.slice.index.Slice.index_mut - (T0 I : Type) (inst : core.slice.index.SliceIndex I (Slice T0)) : - Slice T0 → I → Result inst.Output := + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) : + Slice T → I → Result inst.Output := sorry -- TODO /- [core::slice::index::[T]::index_mut]: backward function 0 -/ def core.slice.index.Slice.index_mut_back - (T0 I : Type) (inst : core.slice.index.SliceIndex I (Slice T0)) : - Slice T0 → I → inst.Output → Result (Slice T0) := + (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) : + Slice T → I → inst.Output → Result (Slice T) := sorry -- TODO /- [core::array::[T; N]::index]: forward function -/ def core.array.Array.index - (T0 I : Type) (N : Usize) (inst : core.ops.index.Index (Slice T0) I) : - Array T0 N → I → Result inst.Output := + (T I : Type) (N : Usize) (inst : core.ops.index.Index (Slice T) I) + (a : Array T N) (i : I) : Result inst.Output := sorry -- TODO /- [core::array::[T; N]::index_mut]: forward function -/ def core.array.Array.index_mut - (T0 I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T0) I) : - Array T0 N → I → Result inst.indexInst.Output := + (T I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T) I) + (a : Array T N) (i : I) : Result inst.indexInst.Output := sorry -- TODO /- [core::array::[T; N]::index_mut]: backward function 0 -/ def core.array.Array.index_mut_back - (T0 I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T0) I) : - Array T0 N → I → inst.indexInst.Output → Result (Array T0 N) := + (T I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T) I) + (a : Array T N) (i : I) (x : inst.indexInst.Output) : Result (Array T N) := sorry -- TODO /- Trait implementation: [core::slice::index::[T]] -/ -def core.slice.index.Slice.coreopsindexIndexInst (T0 I : Type) - (inst : core.slice.index.SliceIndex I (Slice T0)) : - core.ops.index.Index (Slice T0) I := { +def core.slice.index.Slice.coreopsindexIndexInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.Index (Slice T) I := { Output := inst.Output - index := core.slice.index.Slice.index T0 I inst + index := core.slice.index.Slice.index T I inst } /- Trait implementation: [core::slice::index::private_slice_index::Range] -/ @@ -452,45 +452,45 @@ def core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_index : core.slice.index.private_slice_index.Sealed (Range Usize) := {} /- Trait implementation: [core::slice::index::Range] -/ -def core.slice.index.Range.coresliceindexSliceIndexInst (T0 : Type) : - core.slice.index.SliceIndex (Range Usize) (Slice T0) := { +def core.slice.index.Range.coresliceindexSliceIndexInst (T : Type) : + core.slice.index.SliceIndex (Range Usize) (Slice T) := { sealedInst := core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst - Output := Slice T0 - get := core.slice.index.Range.get T0 - get_mut := core.slice.index.Range.get_mut T0 - get_mut_back := core.slice.index.Range.get_mut_back T0 - get_unchecked := core.slice.index.Range.get_unchecked T0 - get_unchecked_mut := core.slice.index.Range.get_unchecked_mut T0 - index := core.slice.index.Range.index T0 - index_mut := core.slice.index.Range.index_mut T0 - index_mut_back := core.slice.index.Range.index_mut_back T0 + Output := Slice T + get := core.slice.index.Range.get T + get_mut := core.slice.index.Range.get_mut T + get_mut_back := core.slice.index.Range.get_mut_back T + get_unchecked := core.slice.index.Range.get_unchecked T + get_unchecked_mut := core.slice.index.Range.get_unchecked_mut T + index := core.slice.index.Range.index T + index_mut := core.slice.index.Range.index_mut T + index_mut_back := core.slice.index.Range.index_mut_back T } /- Trait implementation: [core::slice::index::[T]] -/ -def core.slice.index.Slice.coreopsindexIndexMutInst (T0 I : Type) - (inst : core.slice.index.SliceIndex I (Slice T0)) : - core.ops.index.IndexMut (Slice T0) I := { - indexInst := core.slice.index.Slice.coreopsindexIndexInst T0 I inst - index_mut := core.slice.index.Slice.index_mut T0 I inst - index_mut_back := core.slice.index.Slice.index_mut_back T0 I inst +def core.slice.index.Slice.coreopsindexIndexMutInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.IndexMut (Slice T) I := { + indexInst := core.slice.index.Slice.coreopsindexIndexInst T I inst + index_mut := core.slice.index.Slice.index_mut T I inst + index_mut_back := core.slice.index.Slice.index_mut_back T I inst } /- Trait implementation: [core::array::[T; N]] -/ -def core.array.Array.coreopsindexIndexInst (T0 I : Type) (N : Usize) - (inst : core.ops.index.Index (Slice T0) I) : - core.ops.index.Index (Array T0 N) I := { +def core.array.Array.coreopsindexIndexInst (T I : Type) (N : Usize) + (inst : core.ops.index.Index (Slice T) I) : + core.ops.index.Index (Array T N) I := { Output := inst.Output - index := core.array.Array.index T0 I N inst + index := core.array.Array.index T I N inst } /- Trait implementation: [core::array::[T; N]] -/ -def core.array.Array.coreopsindexIndexMutInst (T0 I : Type) (N : Usize) - (inst : core.ops.index.IndexMut (Slice T0) I) : - core.ops.index.IndexMut (Array T0 N) I := { - indexInst := core.array.Array.coreopsindexIndexInst T0 I N inst.indexInst - index_mut := core.array.Array.index_mut T0 I N inst - index_mut_back := core.array.Array.index_mut_back T0 I N inst +def core.array.Array.coreopsindexIndexMutInst (T I : Type) (N : Usize) + (inst : core.ops.index.IndexMut (Slice T) I) : + core.ops.index.IndexMut (Array T N) I := { + indexInst := core.array.Array.coreopsindexIndexInst T I N inst.indexInst + index_mut := core.array.Array.index_mut T I N inst + index_mut_back := core.array.Array.index_mut_back T I N inst } /- [core::slice::index::usize::get]: forward function -/ 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 c380ab1699a115edf88e9d83234a4423333e52bf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 14:12:09 +0200 Subject: Regenerate the array files for Lean --- tests/lean/Array/Funs.lean | 206 +++++++++++++++++++++----------------------- tests/lean/Array/Types.lean | 8 +- 2 files changed, 103 insertions(+), 111 deletions(-) diff --git a/tests/lean/Array/Funs.lean b/tests/lean/Array/Funs.lean index 899bf856..32ae6248 100644 --- a/tests/lean/Array/Funs.lean +++ b/tests/lean/Array/Funs.lean @@ -13,89 +13,87 @@ def incr (x : U32) : Result U32 := /- [array::array_to_shared_slice_]: forward function -/ def array_to_shared_slice_ - (T0 : Type) (s : Array T0 32#usize) : Result (Slice T0) := - Array.to_slice_shared T0 32#usize s + (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s /- [array::array_to_mut_slice_]: forward function -/ -def array_to_mut_slice_ - (T0 : Type) (s : Array T0 32#usize) : Result (Slice T0) := - Array.to_slice_mut T0 32#usize s +def array_to_mut_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s /- [array::array_to_mut_slice_]: backward function 0 -/ def array_to_mut_slice__back - (T0 : Type) (s : Array T0 32#usize) (ret0 : Slice T0) : - Result (Array T0 32#usize) + (T : Type) (s : Array T 32#usize) (ret0 : Slice T) : + Result (Array T 32#usize) := - Array.to_slice_mut_back T0 32#usize s ret0 + Array.from_slice T 32#usize s ret0 /- [array::array_len]: forward function -/ -def array_len (T0 : Type) (s : Array T0 32#usize) : Result Usize := +def array_len (T : Type) (s : Array T 32#usize) : Result Usize := do - let s0 ← Array.to_slice_shared T0 32#usize s - let i := Slice.len T0 s0 + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 Result.ret i /- [array::shared_array_len]: forward function -/ -def shared_array_len (T0 : Type) (s : Array T0 32#usize) : Result Usize := +def shared_array_len (T : Type) (s : Array T 32#usize) : Result Usize := do - let s0 ← Array.to_slice_shared T0 32#usize s - let i := Slice.len T0 s0 + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 Result.ret i /- [array::shared_slice_len]: forward function -/ -def shared_slice_len (T0 : Type) (s : Slice T0) : Result Usize := - let i := Slice.len T0 s +def shared_slice_len (T : Type) (s : Slice T) : Result Usize := + let i := Slice.len T s Result.ret i /- [array::index_array_shared]: forward function -/ def index_array_shared - (T0 : Type) (s : Array T0 32#usize) (i : Usize) : Result T0 := - Array.index_shared T0 32#usize s i + (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i /- [array::index_array_u32]: forward function -/ def index_array_u32 (s : Array U32 32#usize) (i : Usize) : Result U32 := - Array.index_shared U32 32#usize s i + Array.index_usize U32 32#usize s i /- [array::index_array_copy]: forward function -/ def index_array_copy (x : Array U32 32#usize) : Result U32 := - Array.index_shared U32 32#usize x 0#usize + Array.index_usize U32 32#usize x 0#usize /- [array::index_mut_array]: forward function -/ -def index_mut_array - (T0 : Type) (s : Array T0 32#usize) (i : Usize) : Result T0 := - Array.index_mut T0 32#usize s i +def index_mut_array (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i /- [array::index_mut_array]: backward function 0 -/ def index_mut_array_back - (T0 : Type) (s : Array T0 32#usize) (i : Usize) (ret0 : T0) : - Result (Array T0 32#usize) + (T : Type) (s : Array T 32#usize) (i : Usize) (ret0 : T) : + Result (Array T 32#usize) := - Array.index_mut_back T0 32#usize s i ret0 + Array.update_usize T 32#usize s i ret0 /- [array::index_slice]: forward function -/ -def index_slice (T0 : Type) (s : Slice T0) (i : Usize) : Result T0 := - Slice.index_shared T0 s i +def index_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i /- [array::index_mut_slice]: forward function -/ -def index_mut_slice (T0 : Type) (s : Slice T0) (i : Usize) : Result T0 := - Slice.index_mut T0 s i +def index_mut_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i /- [array::index_mut_slice]: backward function 0 -/ def index_mut_slice_back - (T0 : Type) (s : Slice T0) (i : Usize) (ret0 : T0) : Result (Slice T0) := - Slice.index_mut_back T0 s i ret0 + (T : Type) (s : Slice T) (i : Usize) (ret0 : T) : Result (Slice T) := + Slice.update_usize T s i ret0 /- [array::slice_subslice_shared_]: forward function -/ def slice_subslice_shared_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := - core.slice.index.Slice.index U32 (Range Usize) + core.slice.index.Slice.index U32 (core.ops.range.Range Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32) x { start := y, end_ := z } /- [array::slice_subslice_mut_]: forward function -/ def slice_subslice_mut_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := - core.slice.index.Slice.index_mut U32 (Range Usize) + core.slice.index.Slice.index_mut U32 (core.ops.range.Range Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32) x { start := y, end_ := z } @@ -104,37 +102,37 @@ def slice_subslice_mut__back (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : Result (Slice U32) := - core.slice.index.Slice.index_mut_back U32 (Range Usize) + core.slice.index.Slice.index_mut_back U32 (core.ops.range.Range Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32) x { start := y, end_ := z } ret0 /- [array::array_to_slice_shared_]: forward function -/ def array_to_slice_shared_ (x : Array U32 32#usize) : Result (Slice U32) := - Array.to_slice_shared U32 32#usize x + Array.to_slice U32 32#usize x /- [array::array_to_slice_mut_]: forward function -/ def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := - Array.to_slice_mut U32 32#usize x + Array.to_slice U32 32#usize x /- [array::array_to_slice_mut_]: backward function 0 -/ def array_to_slice_mut__back (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := - Array.to_slice_mut_back U32 32#usize x ret0 + Array.from_slice U32 32#usize x ret0 /- [array::array_subslice_shared_]: forward function -/ def array_subslice_shared_ (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := - core.array.Array.index U32 (Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexInst U32 (Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x { start := y, end_ := z } /- [array::array_subslice_mut_]: forward function -/ def array_subslice_mut_ (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := - core.array.Array.index_mut U32 (Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x { start := y, end_ := z } /- [array::array_subslice_mut_]: backward function 0 -/ @@ -142,18 +140,18 @@ def array_subslice_mut__back (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := - core.array.Array.index_mut_back U32 (Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x { start := y, end_ := z } ret0 /- [array::index_slice_0]: forward function -/ -def index_slice_0 (T0 : Type) (s : Slice T0) : Result T0 := - Slice.index_shared T0 s 0#usize +def index_slice_0 (T : Type) (s : Slice T) : Result T := + Slice.index_usize T s 0#usize /- [array::index_array_0]: forward function -/ -def index_array_0 (T0 : Type) (s : Array T0 32#usize) : Result T0 := - Array.index_shared T0 32#usize s 0#usize +def index_array_0 (T : Type) (s : Array T 32#usize) : Result T := + Array.index_usize T 32#usize s 0#usize /- [array::index_index_array]: forward function -/ def index_index_array @@ -161,8 +159,8 @@ def index_index_array Result U32 := do - let a ← Array.index_shared (Array U32 32#usize) 32#usize s i - Array.index_shared U32 32#usize a j + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + Array.index_usize U32 32#usize a j /- [array::update_update_array]: forward function -/ def update_update_array @@ -170,9 +168,9 @@ def update_update_array Result Unit := do - let a ← Array.index_mut (Array U32 32#usize) 32#usize s i - let a0 ← Array.index_mut_back U32 32#usize a j 0#u32 - let _ ← Array.index_mut_back (Array U32 32#usize) 32#usize s i a0 + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + let a0 ← Array.update_usize U32 32#usize a j 0#u32 + let _ ← Array.update_usize (Array U32 32#usize) 32#usize s i a0 Result.ret () /- [array::array_local_deep_copy]: forward function -/ @@ -202,37 +200,35 @@ def take_all : Result Unit := let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let _ ← take_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s ← - Array.to_slice_shared U32 2#usize - (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let _ ← take_slice s let s0 ← - Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s1 ← take_mut_slice s0 let _ ← - Array.to_slice_mut_back U32 2#usize - (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret () /- [array::index_array]: forward function -/ def index_array (x : Array U32 2#usize) : Result U32 := - Array.index_shared U32 2#usize x 0#usize + Array.index_usize U32 2#usize x 0#usize /- [array::index_array_borrow]: forward function -/ def index_array_borrow (x : Array U32 2#usize) : Result U32 := - Array.index_shared U32 2#usize x 0#usize + Array.index_usize U32 2#usize x 0#usize /- [array::index_slice_u32_0]: forward function -/ def index_slice_u32_0 (x : Slice U32) : Result U32 := - Slice.index_shared U32 x 0#usize + Slice.index_usize U32 x 0#usize /- [array::index_mut_slice_u32_0]: forward function -/ def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := - Slice.index_shared U32 x 0#usize + Slice.index_usize U32 x 0#usize /- [array::index_mut_slice_u32_0]: backward function 0 -/ def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := do - let _ ← Slice.index_shared U32 x 0#usize + let _ ← Slice.index_usize U32 x 0#usize Result.ret x /- [array::index_all]: forward function -/ @@ -244,60 +240,60 @@ def index_all : Result U32 := let i2 ← index_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i3 ← i1 + i2 let s ← - Array.to_slice_shared U32 2#usize - (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i4 ← index_slice_u32_0 s let i5 ← i3 + i4 let s0 ← - Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let i6 ← index_mut_slice_u32_0 s0 let i7 ← i5 + i6 let s1 ← index_mut_slice_u32_0_back s0 let _ ← - Array.to_slice_mut_back U32 2#usize - (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret i7 /- [array::update_array]: forward function -/ def update_array (x : Array U32 2#usize) : Result Unit := do - let _ ← Array.index_mut_back U32 2#usize x 0#usize 1#u32 + let _ ← Array.update_usize U32 2#usize x 0#usize 1#u32 Result.ret () /- [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def update_array_mut_borrow (x : Array U32 2#usize) : Result (Array U32 2#usize) := - Array.index_mut_back U32 2#usize x 0#usize 1#u32 + Array.update_usize U32 2#usize x 0#usize 1#u32 /- [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def update_mut_slice (x : Slice U32) : Result (Slice U32) := - Slice.index_mut_back U32 x 0#usize 1#u32 + Slice.update_usize U32 x 0#usize 1#u32 /- [array::update_all]: forward function -/ def update_all : Result Unit := do let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let x ← update_array_mut_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) - let s ← Array.to_slice_mut U32 2#usize x + let s ← Array.to_slice U32 2#usize x let s0 ← update_mut_slice s - let _ ← Array.to_slice_mut_back U32 2#usize x s0 + let _ ← Array.from_slice U32 2#usize x s0 Result.ret () /- [array::range_all]: forward function -/ def range_all : Result Unit := do let s ← - core.array.Array.index_mut U32 (Range Usize) 4#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) { start := 1#usize, end_ := 3#usize } let s0 ← update_mut_slice s let _ ← - core.array.Array.index_mut_back U32 (Range Usize) 4#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 (Range Usize) + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) { start := 1#usize, end_ := 3#usize } s0 @@ -305,27 +301,27 @@ def range_all : Result Unit := /- [array::deref_array_borrow]: forward function -/ def deref_array_borrow (x : Array U32 2#usize) : Result U32 := - Array.index_shared U32 2#usize x 0#usize + Array.index_usize U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: forward function -/ def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := - Array.index_shared U32 2#usize x 0#usize + Array.index_usize U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: backward function 0 -/ def deref_array_mut_borrow_back (x : Array U32 2#usize) : Result (Array U32 2#usize) := do - let _ ← Array.index_shared U32 2#usize x 0#usize + let _ ← Array.index_usize U32 2#usize x 0#usize Result.ret x /- [array::take_array_t]: forward function -/ -def take_array_t (a : Array T 2#usize) : Result Unit := +def take_array_t (a : Array AB 2#usize) : Result Unit := Result.ret () /- [array::non_copyable_array]: forward function -/ def non_copyable_array : Result Unit := do - let _ ← take_array_t (Array.make T 2#usize [ T.A, T.B ]) + let _ ← take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) Result.ret () /- [array::sum]: loop 0: forward function -/ @@ -334,7 +330,7 @@ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := if i < i0 then do - let i1 ← Slice.index_shared U32 s i + let i1 ← Slice.index_usize U32 s i let sum1 ← sum0 + i1 let i2 ← i + 1#usize sum_loop s sum1 i2 @@ -351,8 +347,8 @@ divergent def sum2_loop if i < i0 then do - let i1 ← Slice.index_shared U32 s i - let i2 ← Slice.index_shared U32 s2 i + let i1 ← Slice.index_usize U32 s i + let i2 ← Slice.index_usize U32 s2 i let i3 ← i1 + i2 let sum1 ← sum0 + i3 let i4 ← i + 1#usize @@ -371,19 +367,18 @@ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := def f0 : Result Unit := do let s ← - Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) - let s0 ← Slice.index_mut_back U32 s 0#usize 1#u32 + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← Slice.update_usize U32 s 0#usize 1#u32 let _ ← - Array.to_slice_mut_back U32 2#usize - (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 Result.ret () /- [array::f1]: forward function -/ def f1 : Result Unit := do let _ ← - Array.index_mut_back U32 2#usize - (Array.make U32 2#usize [ 1#u32, 2#u32 ]) 0#usize 1#u32 + Array.update_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize 1#u32 Result.ret () /- [array::f2]: forward function -/ @@ -392,22 +387,21 @@ def f2 (i : U32) : Result Unit := /- [array::f4]: forward function -/ def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := - core.array.Array.index U32 (Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexInst U32 (Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x { start := y, end_ := z } /- [array::f3]: forward function -/ def f3 : Result U32 := do let i ← - Array.index_shared U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + Array.index_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) 0#usize let _ ← f2 i let b := Array.repeat U32 32#usize 0#u32 let s ← - Array.to_slice_shared U32 2#usize - (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) let s0 ← f4 b 16#usize 18#usize sum2 s s0 @@ -417,23 +411,21 @@ def sz_c : Usize := eval_global sz_body (by simp) /- [array::f5]: forward function -/ def f5 (x : Array U32 32#usize) : Result U32 := - Array.index_shared U32 32#usize x 0#usize + Array.index_usize U32 32#usize x 0#usize /- [array::ite]: forward function -/ def ite : Result Unit := do let s ← - Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s0 ← - Array.to_slice_mut U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) let s1 ← index_mut_slice_u32_0_back s0 let _ ← - Array.to_slice_mut_back U32 2#usize - (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 let s2 ← index_mut_slice_u32_0_back s let _ ← - Array.to_slice_mut_back U32 2#usize - (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s2 + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s2 Result.ret () end array diff --git a/tests/lean/Array/Types.lean b/tests/lean/Array/Types.lean index 72241276..60fa81ab 100644 --- a/tests/lean/Array/Types.lean +++ b/tests/lean/Array/Types.lean @@ -5,9 +5,9 @@ open Primitives namespace array -/- [array::T] -/ -inductive T := -| A : T -| B : T +/- [array::AB] -/ +inductive AB := +| A : AB +| B : AB end array -- 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(-) 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 bfafe1f4d1cb69c9b921a77c7193c92b45cc21df Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 14:45:19 +0200 Subject: Regenerate several test files for Lean --- tests/lean/Constants.lean | 29 ++++---- tests/lean/External/Funs.lean | 16 ++--- tests/lean/Loops/Funs.lean | 161 +++++++++++++++++++++++------------------- tests/lean/Paper.lean | 48 ++++++------- 4 files changed, 132 insertions(+), 122 deletions(-) diff --git a/tests/lean/Constants.lean b/tests/lean/Constants.lean index b0cdaa90..2603cbbf 100644 --- a/tests/lean/Constants.lean +++ b/tests/lean/Constants.lean @@ -6,7 +6,7 @@ open Primitives namespace constants /- [constants::X0] -/ -def x0_body : Result U32 := Result.ret (U32.ofInt 0) +def x0_body : Result U32 := Result.ret 0#u32 def x0_c : U32 := eval_global x0_body (by simp) /- [constants::X1] -/ @@ -14,15 +14,15 @@ def x1_body : Result U32 := Result.ret core_u32_max def x1_c : U32 := eval_global x1_body (by simp) /- [constants::X2] -/ -def x2_body : Result U32 := Result.ret (U32.ofInt 3) +def x2_body : Result U32 := Result.ret 3#u32 def x2_c : U32 := eval_global x2_body (by simp) /- [constants::incr]: forward function -/ def incr (n : U32) : Result U32 := - n + (U32.ofInt 1) + n + 1#u32 /- [constants::X3] -/ -def x3_body : Result U32 := incr (U32.ofInt 32) +def x3_body : Result U32 := incr 32#u32 def x3_c : U32 := eval_global x3_body (by simp) /- [constants::mk_pair0]: forward function -/ @@ -39,20 +39,19 @@ def mk_pair1 (x : U32) (y : U32) : Result (Pair U32 U32) := Result.ret { x := x, y := y } /- [constants::P0] -/ -def p0_body : Result (U32 × U32) := mk_pair0 (U32.ofInt 0) (U32.ofInt 1) +def p0_body : Result (U32 × U32) := mk_pair0 0#u32 1#u32 def p0_c : (U32 × U32) := eval_global p0_body (by simp) /- [constants::P1] -/ -def p1_body : Result (Pair U32 U32) := mk_pair1 (U32.ofInt 0) (U32.ofInt 1) +def p1_body : Result (Pair U32 U32) := mk_pair1 0#u32 1#u32 def p1_c : Pair U32 U32 := eval_global p1_body (by simp) /- [constants::P2] -/ -def p2_body : Result (U32 × U32) := Result.ret ((U32.ofInt 0), (U32.ofInt 1)) +def p2_body : Result (U32 × U32) := Result.ret (0#u32, 1#u32) def p2_c : (U32 × U32) := eval_global p2_body (by simp) /- [constants::P3] -/ -def p3_body : Result (Pair U32 U32) := - Result.ret { x := (U32.ofInt 0), y := (U32.ofInt 1) } +def p3_body : Result (Pair U32 U32) := Result.ret { x := 0#u32, y := 1#u32 } def p3_c : Pair U32 U32 := eval_global p3_body (by simp) /- [constants::Wrap] -/ @@ -64,7 +63,7 @@ def Wrap.new (T : Type) (val : T) : Result (Wrap T) := Result.ret { val := val } /- [constants::Y] -/ -def y_body : Result (Wrap I32) := Wrap.new I32 (I32.ofInt 2) +def y_body : Result (Wrap I32) := Wrap.new I32 2#i32 def y_c : Wrap I32 := eval_global y_body (by simp) /- [constants::unwrap_y]: forward function -/ @@ -76,7 +75,7 @@ def yval_body : Result I32 := unwrap_y def yval_c : I32 := eval_global yval_body (by simp) /- [constants::get_z1::Z1] -/ -def get_z1_z1_body : Result I32 := Result.ret (I32.ofInt 3) +def get_z1_z1_body : Result I32 := Result.ret 3#i32 def get_z1_z1_c : I32 := eval_global get_z1_z1_body (by simp) /- [constants::get_z1]: forward function -/ @@ -88,7 +87,7 @@ def add (a : I32) (b : I32) : Result I32 := a + b /- [constants::Q1] -/ -def q1_body : Result I32 := Result.ret (I32.ofInt 5) +def q1_body : Result I32 := Result.ret 5#i32 def q1_c : I32 := eval_global q1_body (by simp) /- [constants::Q2] -/ @@ -96,7 +95,7 @@ def q2_body : Result I32 := Result.ret q1_c def q2_c : I32 := eval_global q2_body (by simp) /- [constants::Q3] -/ -def q3_body : Result I32 := add q2_c (I32.ofInt 3) +def q3_body : Result I32 := add q2_c 3#i32 def q3_c : I32 := eval_global q3_body (by simp) /- [constants::get_z2]: forward function -/ @@ -107,7 +106,7 @@ def get_z2 : Result I32 := add q1_c i0 /- [constants::S1] -/ -def s1_body : Result U32 := Result.ret (U32.ofInt 6) +def s1_body : Result U32 := Result.ret 6#u32 def s1_c : U32 := eval_global s1_body (by simp) /- [constants::S2] -/ @@ -119,7 +118,7 @@ def s3_body : Result (Pair U32 U32) := Result.ret p3_c def s3_c : Pair U32 U32 := eval_global s3_body (by simp) /- [constants::S4] -/ -def s4_body : Result (Pair U32 U32) := mk_pair1 (U32.ofInt 7) (U32.ofInt 8) +def s4_body : Result (Pair U32 U32) := mk_pair1 7#u32 8#u32 def s4_c : Pair U32 U32 := eval_global s4_body (by simp) end constants diff --git a/tests/lean/External/Funs.lean b/tests/lean/External/Funs.lean index 055d7860..55fb07be 100644 --- a/tests/lean/External/Funs.lean +++ b/tests/lean/External/Funs.lean @@ -30,14 +30,14 @@ def swap_back def test_new_non_zero_u32 (x : U32) (st : State) : Result (State × core.num.nonzero.NonZeroU32) := do - let (st0, opt) ← core.num.nonzero.NonZeroU32.new x st - core.option.Option.unwrap core.num.nonzero.NonZeroU32 opt st0 + let (st0, o) ← core.num.nonzero.NonZeroU32.new x st + core.option.Option.unwrap core.num.nonzero.NonZeroU32 o st0 /- [external::test_vec]: forward function -/ def test_vec : Result Unit := do - let v := Vec.new U32 - let _ ← Vec.push U32 v (U32.ofInt 0) + let v := alloc.vec.Vec.new U32 + let _ ← alloc.vec.Vec.push U32 v 0#u32 Result.ret () /- Unit test for [external::test_vec] -/ @@ -75,14 +75,14 @@ def test_custom_swap_back (x : U32) (y : U32) (st : State) (st0 : State) : Result (State × (U32 × U32)) := - custom_swap_back U32 x y st (U32.ofInt 1) st0 + custom_swap_back U32 x y st 1#u32 st0 /- [external::test_swap_non_zero]: forward function -/ def test_swap_non_zero (x : U32) (st : State) : Result (State × U32) := do - let (st0, _) ← swap U32 x (U32.ofInt 0) st - let (st1, (x0, _)) ← swap_back U32 x (U32.ofInt 0) st st0 - if x0 = (U32.ofInt 0) + let (st0, _) ← swap U32 x 0#u32 st + let (st1, (x0, _)) ← swap_back U32 x 0#u32 st st0 + if x0 = 0#u32 then Result.fail Error.panic else Result.ret (st1, x0) diff --git a/tests/lean/Loops/Funs.lean b/tests/lean/Loops/Funs.lean index 5fbe200f..f9c7569e 100644 --- a/tests/lean/Loops/Funs.lean +++ b/tests/lean/Loops/Funs.lean @@ -11,13 +11,13 @@ divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := if i < max then do let s0 ← s + i - let i0 ← i + (U32.ofInt 1) + let i0 ← i + 1#u32 sum_loop max i0 s0 - else s * (U32.ofInt 2) + else s * 2#u32 /- [loops::sum]: forward function -/ def sum (max : U32) : Result U32 := - sum_loop max (U32.ofInt 0) (U32.ofInt 0) + sum_loop max 0#u32 0#u32 /- [loops::sum_with_mut_borrows]: loop 0: forward function -/ divergent def sum_with_mut_borrows_loop @@ -26,13 +26,13 @@ divergent def sum_with_mut_borrows_loop then do let ms0 ← ms + mi - let mi0 ← mi + (U32.ofInt 1) + let mi0 ← mi + 1#u32 sum_with_mut_borrows_loop max mi0 ms0 - else ms * (U32.ofInt 2) + else ms * 2#u32 /- [loops::sum_with_mut_borrows]: forward function -/ def sum_with_mut_borrows (max : U32) : Result U32 := - sum_with_mut_borrows_loop max (U32.ofInt 0) (U32.ofInt 0) + sum_with_mut_borrows_loop max 0#u32 0#u32 /- [loops::sum_with_shared_borrows]: loop 0: forward function -/ divergent def sum_with_shared_borrows_loop @@ -40,31 +40,34 @@ divergent def sum_with_shared_borrows_loop if i < max then do - let i0 ← i + (U32.ofInt 1) + let i0 ← i + 1#u32 let s0 ← s + i0 sum_with_shared_borrows_loop max i0 s0 - else s * (U32.ofInt 2) + else s * 2#u32 /- [loops::sum_with_shared_borrows]: forward function -/ def sum_with_shared_borrows (max : U32) : Result U32 := - sum_with_shared_borrows_loop max (U32.ofInt 0) (U32.ofInt 0) + sum_with_shared_borrows_loop max 0#u32 0#u32 /- [loops::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ -divergent def clear_loop (v : Vec U32) (i : Usize) : Result (Vec U32) := - let i0 := Vec.len U32 v +divergent def clear_loop + (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := + let i0 := alloc.vec.Vec.len U32 v if i < i0 then do - let i1 ← i + (Usize.ofInt 1) - let v0 ← Vec.index_mut_back U32 v i (U32.ofInt 0) + let i1 ← i + 1#usize + let v0 ← + alloc.vec.Vec.index_mut_back U32 Usize + (core.slice.index.usize.coresliceindexSliceIndexInst U32) v i 0#u32 clear_loop v0 i1 else Result.ret v /- [loops::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ -def clear (v : Vec U32) : Result (Vec U32) := - clear_loop v (Usize.ofInt 0) +def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := + clear_loop v 0#usize /- [loops::list_mem]: loop 0: forward function -/ divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := @@ -83,10 +86,10 @@ divergent def list_nth_mut_loop_loop (T : Type) (ls : List T) (i : U32) : Result T := match ls with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut_loop_loop T tl i0 | List.Nil => Result.fail Error.panic @@ -99,11 +102,11 @@ divergent def list_nth_mut_loop_loop_back (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := match ls with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret0 Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic @@ -118,10 +121,10 @@ divergent def list_nth_shared_loop_loop (T : Type) (ls : List T) (i : U32) : Result T := match ls with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_shared_loop_loop T tl i0 | List.Nil => Result.fail Error.panic @@ -138,9 +141,13 @@ divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := | List.Nil => Result.fail Error.panic /- [loops::get_elem_mut]: forward function -/ -def get_elem_mut (slots : Vec (List Usize)) (x : Usize) : Result Usize := +def get_elem_mut + (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := do - let l ← Vec.index_mut (List Usize) slots (Usize.ofInt 0) + let l ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize get_elem_mut_loop x l /- [loops::get_elem_mut]: loop 0: backward function 0 -/ @@ -158,13 +165,18 @@ divergent def get_elem_mut_loop_back /- [loops::get_elem_mut]: backward function 0 -/ def get_elem_mut_back - (slots : Vec (List Usize)) (x : Usize) (ret0 : Usize) : - Result (Vec (List Usize)) + (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret0 : Usize) : + Result (alloc.vec.Vec (List Usize)) := do - let l ← Vec.index_mut (List Usize) slots (Usize.ofInt 0) + let l ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize let l0 ← get_elem_mut_loop_back x l ret0 - Vec.index_mut_back (List Usize) slots (Usize.ofInt 0) l0 + alloc.vec.Vec.index_mut_back (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) slots + 0#usize l0 /- [loops::get_elem_shared]: loop 0: forward function -/ divergent def get_elem_shared_loop @@ -176,9 +188,13 @@ divergent def get_elem_shared_loop | List.Nil => Result.fail Error.panic /- [loops::get_elem_shared]: forward function -/ -def get_elem_shared (slots : Vec (List Usize)) (x : Usize) : Result Usize := +def get_elem_shared + (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := do - let l ← Vec.index_shared (List Usize) slots (Usize.ofInt 0) + let l ← + alloc.vec.Vec.index (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize get_elem_shared_loop x l /- [loops::id_mut]: forward function -/ @@ -198,10 +214,10 @@ divergent def list_nth_mut_loop_with_id_loop (T : Type) (i : U32) (ls : List T) : Result T := match ls with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut_loop_with_id_loop T i0 tl | List.Nil => Result.fail Error.panic @@ -216,11 +232,11 @@ divergent def list_nth_mut_loop_with_id_loop_back (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := match ls with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret0 Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic @@ -238,12 +254,11 @@ divergent def list_nth_shared_loop_with_id_loop (T : Type) (i : U32) (ls : List T) : Result T := match ls with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_loop_with_id_loop T i0 tl + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_with_id_loop T i0 tl | List.Nil => Result.fail Error.panic /- [loops::list_nth_shared_loop_with_id]: forward function -/ @@ -260,12 +275,11 @@ divergent def list_nth_mut_loop_pair_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_mut_loop_pair_loop T tl0 tl1 i0 + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_pair_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -283,11 +297,11 @@ divergent def list_nth_mut_loop_pair_loop_back'a | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl0) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret0 Result.ret (List.Cons x0 tl00) | List.Nil => Result.fail Error.panic @@ -309,11 +323,11 @@ divergent def list_nth_mut_loop_pair_loop_back'b | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret0 Result.ret (List.Cons x1 tl10) | List.Nil => Result.fail Error.panic @@ -333,12 +347,11 @@ divergent def list_nth_shared_loop_pair_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) - else - do - let i0 ← i - (U32.ofInt 1) - list_nth_shared_loop_pair_loop T tl0 tl1 i0 + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_pair_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -354,11 +367,11 @@ divergent def list_nth_mut_loop_pair_merge_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut_loop_pair_merge_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -377,12 +390,12 @@ divergent def list_nth_mut_loop_pair_merge_loop_back | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then let (t, t0) := ret0 Result.ret (List.Cons t tl0, List.Cons t0 tl1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let (tl00, tl10) ← list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 Result.ret (List.Cons x0 tl00, List.Cons x1 tl10) @@ -403,11 +416,11 @@ divergent def list_nth_shared_loop_pair_merge_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_shared_loop_pair_merge_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -424,11 +437,11 @@ divergent def list_nth_mut_shared_loop_pair_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut_shared_loop_pair_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -447,11 +460,11 @@ divergent def list_nth_mut_shared_loop_pair_loop_back | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl0) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl00 ← list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret0 Result.ret (List.Cons x0 tl00) @@ -472,11 +485,11 @@ divergent def list_nth_mut_shared_loop_pair_merge_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -495,11 +508,11 @@ divergent def list_nth_mut_shared_loop_pair_merge_loop_back | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl0) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl00 ← list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 Result.ret (List.Cons x0 tl00) @@ -520,11 +533,11 @@ divergent def list_nth_shared_mut_loop_pair_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_shared_mut_loop_pair_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -543,11 +556,11 @@ divergent def list_nth_shared_mut_loop_pair_loop_back | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl10 ← list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret0 Result.ret (List.Cons x1 tl10) @@ -568,11 +581,11 @@ divergent def list_nth_shared_mut_loop_pair_merge_loop | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (x0, x1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i0 | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic @@ -591,11 +604,11 @@ divergent def list_nth_shared_mut_loop_pair_merge_loop_back | List.Cons x0 tl0 => match ls1 with | List.Cons x1 tl1 => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl1) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl10 ← list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 Result.ret (List.Cons x1 tl10) diff --git a/tests/lean/Paper.lean b/tests/lean/Paper.lean index c15c5e4b..ae4dd243 100644 --- a/tests/lean/Paper.lean +++ b/tests/lean/Paper.lean @@ -8,13 +8,13 @@ namespace paper /- [paper::ref_incr]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def ref_incr (x : I32) : Result I32 := - x + (I32.ofInt 1) + x + 1#i32 /- [paper::test_incr]: forward function -/ def test_incr : Result Unit := do - let x ← ref_incr (I32.ofInt 0) - if not (x = (I32.ofInt 1)) + let x ← ref_incr 0#i32 + if not (x = 1#i32) then Result.fail Error.panic else Result.ret () @@ -37,19 +37,18 @@ def choose_back /- [paper::test_choose]: forward function -/ def test_choose : Result Unit := do - let z ← choose I32 true (I32.ofInt 0) (I32.ofInt 0) - let z0 ← z + (I32.ofInt 1) - if not (z0 = (I32.ofInt 1)) + let z ← choose I32 true 0#i32 0#i32 + let z0 ← z + 1#i32 + if not (z0 = 1#i32) then Result.fail Error.panic else do - let (x, y) ← choose_back I32 true (I32.ofInt 0) (I32.ofInt 0) z0 - if not (x = (I32.ofInt 1)) + let (x, y) ← choose_back I32 true 0#i32 0#i32 z0 + if not (x = 1#i32) then Result.fail Error.panic - else - if not (y = (I32.ofInt 0)) - then Result.fail Error.panic - else Result.ret () + else if not (y = 0#i32) + then Result.fail Error.panic + else Result.ret () /- Unit test for [paper::test_choose] -/ #assert (test_choose == .ret ()) @@ -63,10 +62,10 @@ inductive List (T : Type) := divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret x else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 list_nth_mut T tl i0 | List.Nil => Result.fail Error.panic @@ -75,11 +74,11 @@ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := match l with | List.Cons x tl => - if i = (U32.ofInt 0) + if i = 0#u32 then Result.ret (List.Cons ret0 tl) else do - let i0 ← i - (U32.ofInt 1) + let i0 ← i - 1#u32 let tl0 ← list_nth_mut_back T tl i0 ret0 Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic @@ -90,20 +89,19 @@ divergent def sum (l : List I32) : Result I32 := | List.Cons x tl => do let i ← sum tl x + i - | List.Nil => Result.ret (I32.ofInt 0) + | List.Nil => Result.ret 0#i32 /- [paper::test_nth]: forward function -/ def test_nth : Result Unit := do let l := List.Nil - let l0 := List.Cons (I32.ofInt 3) l - let l1 := List.Cons (I32.ofInt 2) l0 - let x ← list_nth_mut I32 (List.Cons (I32.ofInt 1) l1) (U32.ofInt 2) - let x0 ← x + (I32.ofInt 1) - let l2 ← - list_nth_mut_back I32 (List.Cons (I32.ofInt 1) l1) (U32.ofInt 2) x0 + let l0 := List.Cons 3#i32 l + let l1 := List.Cons 2#i32 l0 + let x ← list_nth_mut I32 (List.Cons 1#i32 l1) 2#u32 + let x0 ← x + 1#i32 + let l2 ← list_nth_mut_back I32 (List.Cons 1#i32 l1) 2#u32 x0 let i ← sum l2 - if not (i = (I32.ofInt 7)) + if not (i = 7#i32) then Result.fail Error.panic else Result.ret () @@ -115,7 +113,7 @@ def call_choose (p : (U32 × U32)) : Result U32 := do let (px, py) := p let pz ← choose U32 true px py - let pz0 ← pz + (U32.ofInt 1) + let pz0 ← pz + 1#u32 let (px0, _) ← choose_back U32 true px py pz0 Result.ret px0 -- cgit v1.2.3 From 76e7a6e4c4ead2e48bc56118b38347b59f4f30db Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 14:50:57 +0200 Subject: Regenerate the betree example for Lean --- tests/lean/BetreeMain/Funs.lean | 79 ++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 40 deletions(-) diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 6681731f..0901d449 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -40,39 +40,39 @@ def betree.store_leaf_node /- [betree_main::betree::fresh_node_id]: forward function -/ def betree.fresh_node_id (counter : U64) : Result U64 := do - let _ ← counter + (U64.ofInt 1) + let _ ← counter + 1#u64 Result.ret counter /- [betree_main::betree::fresh_node_id]: backward function 0 -/ def betree.fresh_node_id_back (counter : U64) : Result U64 := - counter + (U64.ofInt 1) + counter + 1#u64 /- [betree_main::betree::NodeIdCounter::{0}::new]: forward function -/ def betree.NodeIdCounter.new : Result betree.NodeIdCounter := - Result.ret { next_node_id := (U64.ofInt 0) } + Result.ret { next_node_id := 0#u64 } /- [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function -/ def betree.NodeIdCounter.fresh_id (self : betree.NodeIdCounter) : Result U64 := do - let _ ← self.next_node_id + (U64.ofInt 1) + let _ ← self.next_node_id + 1#u64 Result.ret self.next_node_id /- [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 -/ def betree.NodeIdCounter.fresh_id_back (self : betree.NodeIdCounter) : Result betree.NodeIdCounter := do - let i ← self.next_node_id + (U64.ofInt 1) + let i ← self.next_node_id + 1#u64 Result.ret { next_node_id := i } /- [betree_main::betree::upsert_update]: forward function -/ def betree.upsert_update (prev : Option U64) (st : betree.UpsertFunState) : Result U64 := match prev with - | Option.none => + | none => match st with | betree.UpsertFunState.Add v => Result.ret v - | betree.UpsertFunState.Sub i => Result.ret (U64.ofInt 0) - | Option.some prev0 => + | betree.UpsertFunState.Sub i => Result.ret 0#u64 + | some prev0 => match st with | betree.UpsertFunState.Add v => do @@ -83,29 +83,28 @@ def betree.upsert_update | betree.UpsertFunState.Sub v => if prev0 >= v then prev0 - v - else Result.ret (U64.ofInt 0) + else Result.ret 0#u64 /- [betree_main::betree::List::{1}::len]: forward function -/ divergent def betree.List.len (T : Type) (self : betree.List T) : Result U64 := match self with - | betree.List.Cons t tl => - do - let i ← betree.List.len T tl - (U64.ofInt 1) + i - | betree.List.Nil => Result.ret (U64.ofInt 0) + | betree.List.Cons t tl => do + let i ← betree.List.len T tl + 1#u64 + i + | betree.List.Nil => Result.ret 0#u64 /- [betree_main::betree::List::{1}::split_at]: forward function -/ divergent def betree.List.split_at (T : Type) (self : betree.List T) (n : U64) : Result ((betree.List T) × (betree.List T)) := - if n = (U64.ofInt 0) + if n = 0#u64 then Result.ret (betree.List.Nil, self) else match self with | betree.List.Cons hd tl => do - let i ← n - (U64.ofInt 1) + let i ← n - 1#u64 let p ← betree.List.split_at T tl i let (ls0, ls1) := p let l := ls0 @@ -116,13 +115,13 @@ divergent def betree.List.split_at (there is a single backward function, and the forward function returns ()) -/ def betree.List.push_front (T : Type) (self : betree.List T) (x : T) : Result (betree.List T) := - let tl := mem.replace (betree.List T) self betree.List.Nil + let tl := core.mem.replace (betree.List T) self betree.List.Nil let l := tl Result.ret (betree.List.Cons x l) /- [betree_main::betree::List::{1}::pop_front]: forward function -/ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := - let ls := mem.replace (betree.List T) self betree.List.Nil + let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret x | betree.List.Nil => Result.fail Error.panic @@ -130,7 +129,7 @@ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := /- [betree_main::betree::List::{1}::pop_front]: backward function 0 -/ def betree.List.pop_front_back (T : Type) (self : betree.List T) : Result (betree.List T) := - let ls := mem.replace (betree.List T) self betree.List.Nil + let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret tl | betree.List.Nil => Result.fail Error.panic @@ -256,7 +255,7 @@ divergent def betree.Node.apply_upserts let v ← betree.upsert_update prev s let msgs0 ← betree.List.pop_front_back (U64 × betree.Message) msgs - betree.Node.apply_upserts msgs0 (Option.some v) key st + betree.Node.apply_upserts msgs0 (some v) key st else do let (st0, v) ← core.option.Option.unwrap U64 prev st @@ -286,7 +285,7 @@ divergent def betree.Node.apply_upserts_back let v ← betree.upsert_update prev s let msgs0 ← betree.List.pop_front_back (U64 × betree.Message) msgs - betree.Node.apply_upserts_back msgs0 (Option.some v) key st + betree.Node.apply_upserts_back msgs0 (some v) key st else do let (_, v) ← core.option.Option.unwrap U64 prev st @@ -300,12 +299,12 @@ divergent def betree.Node.lookup_in_bindings | betree.List.Cons hd tl => let (i, i0) := hd if i = key - then Result.ret (Option.some i0) + then Result.ret (some i0) else if i > key - then Result.ret Option.none + then Result.ret none else betree.Node.lookup_in_bindings key tl - | betree.List.Nil => Result.ret Option.none + | betree.List.Nil => Result.ret none /- [betree_main::betree::Internal::{4}::lookup_in_children]: forward function -/ mutual divergent def betree.Internal.lookup_in_children @@ -348,13 +347,13 @@ divergent def betree.Node.lookup if k != key then do - let (st1, opt) ← + let (st1, o) ← betree.Internal.lookup_in_children (betree.Internal.mk i i0 n n0) key st0 let _ ← betree.Node.lookup_first_message_for_key_back key msgs (betree.List.Cons (k, msg) l) - Result.ret (st1, opt) + Result.ret (st1, o) else match msg with | betree.Message.Insert v => @@ -362,13 +361,13 @@ divergent def betree.Node.lookup let _ ← betree.Node.lookup_first_message_for_key_back key msgs (betree.List.Cons (k, betree.Message.Insert v) l) - Result.ret (st0, Option.some v) + Result.ret (st0, some v) | betree.Message.Delete => do let _ ← betree.Node.lookup_first_message_for_key_back key msgs (betree.List.Cons (k, betree.Message.Delete) l) - Result.ret (st0, Option.none) + Result.ret (st0, none) | betree.Message.Upsert ufs => do let (st1, v) ← @@ -387,21 +386,21 @@ divergent def betree.Node.lookup let msgs0 ← betree.Node.lookup_first_message_for_key_back key msgs pending0 let (st3, _) ← betree.store_internal_node i1 msgs0 st2 - Result.ret (st3, Option.some v0) + Result.ret (st3, some v0) | betree.List.Nil => do - let (st1, opt) ← + let (st1, o) ← betree.Internal.lookup_in_children (betree.Internal.mk i i0 n n0) key st0 let _ ← betree.Node.lookup_first_message_for_key_back key msgs betree.List.Nil - Result.ret (st1, opt) + Result.ret (st1, o) | betree.Node.Leaf node => do let (st0, bindings) ← betree.load_leaf_node node.id st - let opt ← betree.Node.lookup_in_bindings key bindings - Result.ret (st0, opt) + let o ← betree.Node.lookup_in_bindings key bindings + Result.ret (st0, o) /- [betree_main::betree::Node::{5}::lookup]: backward function 0 -/ divergent def betree.Node.lookup_back @@ -560,7 +559,7 @@ def betree.Node.apply_to_internal match m with | betree.Message.Insert prev => do - let v ← betree.upsert_update (Option.some prev) s + let v ← betree.upsert_update (some prev) s let msgs1 ← betree.List.pop_front_back (U64 × betree.Message) msgs0 let msgs2 ← @@ -569,7 +568,7 @@ def betree.Node.apply_to_internal betree.Node.lookup_first_message_for_key_back key msgs msgs2 | betree.Message.Delete => do - let v ← betree.upsert_update Option.none s + let v ← betree.upsert_update none s let msgs1 ← betree.List.pop_front_back (U64 × betree.Message) msgs0 let msgs2 ← @@ -665,7 +664,7 @@ def betree.Node.apply_to_leaf | betree.Message.Upsert s => do let (_, i) := hd - let v ← betree.upsert_update (Option.some i) s + let v ← betree.upsert_update (some i) s let bindings1 ← betree.List.pop_front_back (U64 × U64) bindings0 let bindings2 ← betree.List.push_front (U64 × U64) bindings1 (key, v) @@ -681,7 +680,7 @@ def betree.Node.apply_to_leaf betree.Node.lookup_mut_in_bindings_back key bindings bindings0 | betree.Message.Upsert s => do - let v ← betree.upsert_update Option.none s + let v ← betree.upsert_update none s let bindings1 ← betree.List.push_front (U64 × U64) bindings0 (key, v) betree.Node.lookup_mut_in_bindings_back key bindings bindings1 @@ -808,7 +807,7 @@ divergent def betree.Node.apply_messages let (st0, content) ← betree.load_leaf_node node.id st let content0 ← betree.Node.apply_messages_to_leaf content msgs let len ← betree.List.len (U64 × U64) content0 - let i ← (U64.ofInt 2) * params.split_size + let i ← 2#u64 * params.split_size if len >= i then do @@ -858,7 +857,7 @@ divergent def betree.Node.apply_messages_back let (st0, content) ← betree.load_leaf_node node.id st let content0 ← betree.Node.apply_messages_to_leaf content msgs let len ← betree.List.len (U64 × U64) content0 - let i ← (U64.ofInt 2) * params.split_size + let i ← 2#u64 * params.split_size if len >= i then do @@ -918,7 +917,7 @@ def betree.BeTree.new params := { min_flush_size := min_flush_size, split_size := split_size }, node_id_cnt := node_id_cnt0, - root := (betree.Node.Leaf { id := id, size := (U64.ofInt 0) }) + root := (betree.Node.Leaf { id := id, size := 0#u64 }) }) /- [betree_main::betree::BeTree::{6}::apply]: forward function -/ -- 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 +- tests/lean/HashmapMain/Funs.lean | 226 +++++++++++++++++++++---------------- tests/lean/HashmapMain/Types.lean | 2 +- 5 files changed, 147 insertions(+), 106 deletions(-) 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), diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index 848b1a35..74fa8653 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -13,21 +13,21 @@ def hashmap.hash_key (k : Usize) : Result Usize := /- [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function -/ divergent def hashmap.HashMap.allocate_slots_loop - (T : Type) (slots : Vec (hashmap.List T)) (n : Usize) : - Result (Vec (hashmap.List T)) + (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : + Result (alloc.vec.Vec (hashmap.List T)) := - if n > (Usize.ofInt 0) + if n > 0#usize then do - let slots0 ← Vec.push (hashmap.List T) slots hashmap.List.Nil - let n0 ← n - (Usize.ofInt 1) + let slots0 ← alloc.vec.Vec.push (hashmap.List T) slots hashmap.List.Nil + let n0 ← n - 1#usize hashmap.HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots /- [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function -/ def hashmap.HashMap.allocate_slots - (T : Type) (slots : Vec (hashmap.List T)) (n : Usize) : - Result (Vec (hashmap.List T)) + (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : + Result (alloc.vec.Vec (hashmap.List T)) := hashmap.HashMap.allocate_slots_loop T slots n @@ -38,13 +38,13 @@ def hashmap.HashMap.new_with_capacity Result (hashmap.HashMap T) := do - let v := Vec.new (hashmap.List T) + let v := alloc.vec.Vec.new (hashmap.List T) let slots ← hashmap.HashMap.allocate_slots T v capacity let i ← capacity * max_load_dividend let i0 ← i / max_load_divisor Result.ret { - num_entries := (Usize.ofInt 0), + num_entries := 0#usize, max_load_factor := (max_load_dividend, max_load_divisor), max_load := i0, slots := slots @@ -52,22 +52,23 @@ def hashmap.HashMap.new_with_capacity /- [hashmap_main::hashmap::HashMap::{0}::new]: forward function -/ def hashmap.HashMap.new (T : Type) : Result (hashmap.HashMap T) := - hashmap.HashMap.new_with_capacity T (Usize.ofInt 32) (Usize.ofInt 4) - (Usize.ofInt 5) + hashmap.HashMap.new_with_capacity T 32#usize 4#usize 5#usize /- [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.clear_loop - (T : Type) (slots : Vec (hashmap.List T)) (i : Usize) : - Result (Vec (hashmap.List T)) + (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : + Result (alloc.vec.Vec (hashmap.List T)) := - let i0 := Vec.len (hashmap.List T) slots + let i0 := alloc.vec.Vec.len (hashmap.List T) slots if i < i0 then do - let i1 ← i + (Usize.ofInt 1) + let i1 ← i + 1#usize let slots0 ← - Vec.index_mut_back (hashmap.List T) slots i hashmap.List.Nil + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) slots i hashmap.List.Nil hashmap.HashMap.clear_loop T slots0 i1 else Result.ret slots @@ -76,8 +77,8 @@ divergent def hashmap.HashMap.clear_loop def hashmap.HashMap.clear (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do - let v ← hashmap.HashMap.clear_loop T self.slots (Usize.ofInt 0) - Result.ret { self with num_entries := (Usize.ofInt 0), slots := v } + let v ← hashmap.HashMap.clear_loop T self.slots 0#usize + Result.ret { self with num_entries := 0#usize, slots := v } /- [hashmap_main::hashmap::HashMap::{0}::len]: forward function -/ def hashmap.HashMap.len (T : Type) (self : hashmap.HashMap T) : Result Usize := @@ -130,21 +131,30 @@ def hashmap.HashMap.insert_no_resize := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let inserted ← hashmap.HashMap.insert_in_list T key value l if inserted then do - let i0 ← self.num_entries + (Usize.ofInt 1) + let i0 ← self.num_entries + 1#usize let l0 ← hashmap.HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } else do let l0 ← hashmap.HashMap.insert_in_list_back T key value l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with slots := v } /- [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function @@ -171,29 +181,35 @@ def hashmap.HashMap.move_elements_from_list /- [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.move_elements_loop - (T : Type) (ntable : hashmap.HashMap T) (slots : Vec (hashmap.List T)) - (i : Usize) : - Result ((hashmap.HashMap T) × (Vec (hashmap.List T))) + (T : Type) (ntable : hashmap.HashMap T) + (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : + Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) := - let i0 := Vec.len (hashmap.List T) slots + let i0 := alloc.vec.Vec.len (hashmap.List T) slots if i < i0 then do - let l ← Vec.index_mut (hashmap.List T) slots i - let ls := mem.replace (hashmap.List T) l hashmap.List.Nil + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) slots i + let ls := core.mem.replace (hashmap.List T) l hashmap.List.Nil let ntable0 ← hashmap.HashMap.move_elements_from_list T ntable ls - let i1 ← i + (Usize.ofInt 1) - let l0 := mem.replace_back (hashmap.List T) l hashmap.List.Nil - let slots0 ← Vec.index_mut_back (hashmap.List T) slots i l0 + let i1 ← i + 1#usize + let l0 := core.mem.replace_back (hashmap.List T) l hashmap.List.Nil + let slots0 ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) slots i l0 hashmap.HashMap.move_elements_loop T ntable0 slots0 i1 else Result.ret (ntable, slots) /- [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.move_elements - (T : Type) (ntable : hashmap.HashMap T) (slots : Vec (hashmap.List T)) - (i : Usize) : - Result ((hashmap.HashMap T) × (Vec (hashmap.List T))) + (T : Type) (ntable : hashmap.HashMap T) + (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : + Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) := hashmap.HashMap.move_elements_loop T ntable slots i @@ -203,17 +219,17 @@ def hashmap.HashMap.try_resize (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do let max_usize ← Scalar.cast .Usize core_u32_max - let capacity := Vec.len (hashmap.List T) self.slots - let n1 ← max_usize / (Usize.ofInt 2) + let capacity := alloc.vec.Vec.len (hashmap.List T) self.slots + let n1 ← max_usize / 2#usize let (i, i0) := self.max_load_factor let i1 ← n1 / i if capacity <= i1 then do - let i2 ← capacity * (Usize.ofInt 2) + let i2 ← capacity * 2#usize let ntable ← hashmap.HashMap.new_with_capacity T i2 i i0 let (ntable0, _) ← - hashmap.HashMap.move_elements T ntable self.slots (Usize.ofInt 0) + hashmap.HashMap.move_elements T ntable self.slots 0#usize Result.ret { ntable0 @@ -255,9 +271,12 @@ def hashmap.HashMap.contains_key (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result Bool := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod hashmap.HashMap.contains_key_in_list T key l /- [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function -/ @@ -280,9 +299,12 @@ def hashmap.HashMap.get (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_shared (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod hashmap.HashMap.get_in_list T key l /- [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function -/ @@ -327,9 +349,12 @@ def hashmap.HashMap.get_mut (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod hashmap.HashMap.get_mut_in_list T l key /- [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 -/ @@ -339,11 +364,17 @@ def hashmap.HashMap.get_mut_back := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let l0 ← hashmap.HashMap.get_mut_in_list_back T l key ret0 - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } /- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function -/ @@ -354,13 +385,13 @@ divergent def hashmap.HashMap.remove_from_list_loop if ckey = key then let mv_ls := - mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) + core.mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) hashmap.List.Nil match mv_ls with - | hashmap.List.Cons i cvalue tl0 => Result.ret (Option.some cvalue) + | hashmap.List.Cons i cvalue tl0 => Result.ret (some cvalue) | hashmap.List.Nil => Result.fail Error.panic else hashmap.HashMap.remove_from_list_loop T key tl - | hashmap.List.Nil => Result.ret Option.none + | hashmap.List.Nil => Result.ret none /- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function -/ def hashmap.HashMap.remove_from_list @@ -375,7 +406,7 @@ divergent def hashmap.HashMap.remove_from_list_loop_back if ckey = key then let mv_ls := - mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) + core.mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) hashmap.List.Nil match mv_ls with | hashmap.List.Cons i cvalue tl0 => Result.ret tl0 @@ -396,16 +427,18 @@ def hashmap.HashMap.remove (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result (Option T) := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let x ← hashmap.HashMap.remove_from_list T key l match x with - | Option.none => Result.ret Option.none - | Option.some x0 => - do - let _ ← self.num_entries - (Usize.ofInt 1) - Result.ret (Option.some x0) + | none => Result.ret none + | some x0 => do + let _ ← self.num_entries - 1#usize + Result.ret (some x0) /- [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 -/ def hashmap.HashMap.remove_back @@ -414,75 +447,75 @@ def hashmap.HashMap.remove_back := do let hash ← hashmap.hash_key key - let i := Vec.len (hashmap.List T) self.slots + let i := alloc.vec.Vec.len (hashmap.List T) self.slots let hash_mod ← hash % i - let l ← Vec.index_mut (hashmap.List T) self.slots hash_mod + let l ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + self.slots hash_mod let x ← hashmap.HashMap.remove_from_list T key l match x with - | Option.none => + | none => do let l0 ← hashmap.HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with slots := v } - | Option.some x0 => + | some x0 => do - let i0 ← self.num_entries - (Usize.ofInt 1) + let i0 ← self.num_entries - 1#usize let l0 ← hashmap.HashMap.remove_from_list_back T key l - let v ← Vec.index_mut_back (hashmap.List T) self.slots hash_mod l0 + let v ← + alloc.vec.Vec.index_mut_back (hashmap.List T) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List + T)) self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } /- [hashmap_main::hashmap::test1]: forward function -/ def hashmap.test1 : Result Unit := do let hm ← hashmap.HashMap.new U64 - let hm0 ← hashmap.HashMap.insert U64 hm (Usize.ofInt 0) (U64.ofInt 42) - let hm1 ← hashmap.HashMap.insert U64 hm0 (Usize.ofInt 128) (U64.ofInt 18) - let hm2 ← - hashmap.HashMap.insert U64 hm1 (Usize.ofInt 1024) (U64.ofInt 138) - let hm3 ← - hashmap.HashMap.insert U64 hm2 (Usize.ofInt 1056) (U64.ofInt 256) - let i ← hashmap.HashMap.get U64 hm3 (Usize.ofInt 128) - if not (i = (U64.ofInt 18)) + let hm0 ← hashmap.HashMap.insert U64 hm 0#usize 42#u64 + let hm1 ← hashmap.HashMap.insert U64 hm0 128#usize 18#u64 + let hm2 ← hashmap.HashMap.insert U64 hm1 1024#usize 138#u64 + let hm3 ← hashmap.HashMap.insert U64 hm2 1056#usize 256#u64 + let i ← hashmap.HashMap.get U64 hm3 128#usize + if not (i = 18#u64) then Result.fail Error.panic else do - let hm4 ← - hashmap.HashMap.get_mut_back U64 hm3 (Usize.ofInt 1024) - (U64.ofInt 56) - let i0 ← hashmap.HashMap.get U64 hm4 (Usize.ofInt 1024) - if not (i0 = (U64.ofInt 56)) + let hm4 ← hashmap.HashMap.get_mut_back U64 hm3 1024#usize 56#u64 + let i0 ← hashmap.HashMap.get U64 hm4 1024#usize + if not (i0 = 56#u64) then Result.fail Error.panic else do - let x ← hashmap.HashMap.remove U64 hm4 (Usize.ofInt 1024) + let x ← hashmap.HashMap.remove U64 hm4 1024#usize match x with - | Option.none => Result.fail Error.panic - | Option.some x0 => - if not (x0 = (U64.ofInt 56)) + | none => Result.fail Error.panic + | some x0 => + if not (x0 = 56#u64) then Result.fail Error.panic else do - let hm5 ← - hashmap.HashMap.remove_back U64 hm4 (Usize.ofInt 1024) - let i1 ← hashmap.HashMap.get U64 hm5 (Usize.ofInt 0) - if not (i1 = (U64.ofInt 42)) + let hm5 ← hashmap.HashMap.remove_back U64 hm4 1024#usize + let i1 ← hashmap.HashMap.get U64 hm5 0#usize + if not (i1 = 42#u64) then Result.fail Error.panic else do - let i2 ← hashmap.HashMap.get U64 hm5 (Usize.ofInt 128) - if not (i2 = (U64.ofInt 18)) + let i2 ← hashmap.HashMap.get U64 hm5 128#usize + if not (i2 = 18#u64) then Result.fail Error.panic else do - let i3 ← - hashmap.HashMap.get U64 hm5 (Usize.ofInt 1056) - if not (i3 = (U64.ofInt 256)) + let i3 ← hashmap.HashMap.get U64 hm5 1056#usize + if not (i3 = 256#u64) then Result.fail Error.panic else Result.ret () -/- Unit test for [hashmap_main::hashmap::test1] -/ -#assert (hashmap.test1 == .ret ()) - /- [hashmap_main::insert_on_disk]: forward function -/ def insert_on_disk (key : Usize) (value : U64) (st : State) : Result (State × Unit) := @@ -496,7 +529,4 @@ def insert_on_disk def main : Result Unit := Result.ret () -/- Unit test for [hashmap_main::main] -/ -#assert (main == .ret ()) - end hashmap_main diff --git a/tests/lean/HashmapMain/Types.lean b/tests/lean/HashmapMain/Types.lean index 2b5cbd6c..065c109b 100644 --- a/tests/lean/HashmapMain/Types.lean +++ b/tests/lean/HashmapMain/Types.lean @@ -15,7 +15,7 @@ structure hashmap.HashMap (T : Type) where num_entries : Usize max_load_factor : (Usize × Usize) max_load : Usize - slots : Vec (hashmap.List T) + slots : alloc.vec.Vec (hashmap.List T) /- The state type used in the state-error monad -/ axiom State : Type -- cgit v1.2.3 From c8c9be9b7d9866f9761a21adbadd923d4a79bb09 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 26 Oct 2023 15:55:12 +0200 Subject: Update Primitives.fst --- backends/fstar/Primitives.fst | 366 ++++++++++++++++++--- tests/fstar/array/Primitives.fst | 384 +++++++++++++++++++--- tests/fstar/betree/Primitives.fst | 384 +++++++++++++++++++--- tests/fstar/betree_back_stateful/Primitives.fst | 384 +++++++++++++++++++--- tests/fstar/demo/Primitives.fst | 405 ++++++++++++++++++++++++ tests/fstar/hashmap/Primitives.fst | 384 +++++++++++++++++++--- tests/fstar/hashmap_on_disk/Primitives.fst | 384 +++++++++++++++++++--- tests/fstar/misc/Primitives.fst | 384 +++++++++++++++++++--- 8 files changed, 2757 insertions(+), 318 deletions(-) create mode 100644 tests/fstar/demo/Primitives.fst diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 7d0845ed..5e154122 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -101,8 +105,8 @@ type scalar_ty = | U128 let is_unsigned = function -| Isize | I8 | I16 | I32 | I64 | I128 -> false -| Usize | U8 | U16 | U32 | U64 | U128 -> true + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true let scalar_min (ty : scalar_ty) : int = @@ -307,12 +311,58 @@ let u32_xor = scalar_lxor #U32 let u64_xor = scalar_lxor #U64 let u128_xor = scalar_lxor #U128 -(*** Range *) -type range (a : Type0) = { +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -326,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -343,58 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = - admit() - -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -409,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index cd18cf29..5e154122 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -305,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -322,55 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -385,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index cd18cf29..5e154122 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -305,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -322,55 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -385,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index cd18cf29..5e154122 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -305,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -322,55 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -385,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} diff --git a/tests/fstar/demo/Primitives.fst b/tests/fstar/demo/Primitives.fst new file mode 100644 index 00000000..e9391834 --- /dev/null +++ b/tests/fstar/demo/Primitives.fst @@ -0,0 +1,405 @@ +/// This file lists primitive and assumed functions and types +module Primitives +open FStar.Mul +open FStar.List.Tot + +#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" + +(*** Utilities *) +val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : + ls':list a{ + length ls' = length ls /\ + index ls' i == x + } +#push-options "--fuel 1" +let rec list_update #a ls i x = + match ls with + | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x +#pop-options + +(*** Result *) +type error : Type0 = +| Failure +| OutOfFuel + +type result (a : Type0) : Type0 = +| Return : v:a -> result a +| Fail : e:error -> result a + +// Monadic return operator +unfold let return (#a : Type0) (x : a) : result a = Return x + +// Monadic bind operator. +// Allows to use the notation: +// ``` +// let* x = y in +// ... +// ``` +unfold let (let*) (#a #b : Type0) (m: result a) + (f: (x:a) -> Pure (result b) (requires (m == Return x)) (ensures fun _ -> True)) : + result b = + match m with + | Return x -> f x + | Fail e -> Fail e + +// Monadic assert(...) +let massert (b:bool) : result unit = if b then Return () else Fail Failure + +// Normalize and unwrap a successful result (used for globals). +let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x + +(*** Misc *) +type char = FStar.Char.char +type string = string + +let is_zero (n: nat) : bool = n = 0 +let decrease (n: nat{n > 0}) : nat = n - 1 + +let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x +let mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +(*** Scalars *) +/// Rem.: most of the following code was partially generated + +let isize_min : int = -9223372036854775808 // TODO: should be opaque +let isize_max : int = 9223372036854775807 // TODO: should be opaque +let i8_min : int = -128 +let i8_max : int = 127 +let i16_min : int = -32768 +let i16_max : int = 32767 +let i32_min : int = -2147483648 +let i32_max : int = 2147483647 +let i64_min : int = -9223372036854775808 +let i64_max : int = 9223372036854775807 +let i128_min : int = -170141183460469231731687303715884105728 +let i128_max : int = 170141183460469231731687303715884105727 +let usize_min : int = 0 +let usize_max : int = 4294967295 // TODO: should be opaque +let u8_min : int = 0 +let u8_max : int = 255 +let u16_min : int = 0 +let u16_max : int = 65535 +let u32_min : int = 0 +let u32_max : int = 4294967295 +let u64_min : int = 0 +let u64_max : int = 18446744073709551615 +let u128_min : int = 0 +let u128_max : int = 340282366920938463463374607431768211455 + +type scalar_ty = +| Isize +| I8 +| I16 +| I32 +| I64 +| I128 +| Usize +| U8 +| U16 +| U32 +| U64 +| U128 + +let scalar_min (ty : scalar_ty) : int = + match ty with + | Isize -> isize_min + | I8 -> i8_min + | I16 -> i16_min + | I32 -> i32_min + | I64 -> i64_min + | I128 -> i128_min + | Usize -> usize_min + | U8 -> u8_min + | U16 -> u16_min + | U32 -> u32_min + | U64 -> u64_min + | U128 -> u128_min + +let scalar_max (ty : scalar_ty) : int = + match ty with + | Isize -> isize_max + | I8 -> i8_max + | I16 -> i16_max + | I32 -> i32_max + | I64 -> i64_max + | I128 -> i128_max + | Usize -> usize_max + | U8 -> u8_max + | U16 -> u16_max + | U32 -> u32_max + | U64 -> u64_max + | U128 -> u128_max + +type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} + +let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = + if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail Failure + +let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) + +let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (x / y) else Fail Failure + +/// The remainder operation +let int_rem (x : int) (y : int{y <> 0}) : int = + if x >= 0 then (x % y) else -(x % y) + +(* Checking consistency with Rust *) +let _ = assert_norm(int_rem 1 2 = 1) +let _ = assert_norm(int_rem (-1) 2 = -1) +let _ = assert_norm(int_rem 1 (-2) = 1) +let _ = assert_norm(int_rem (-1) (-2) = -1) + +let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (int_rem x y) else Fail Failure + +let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x + y) + +let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x - y) + +let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x * y) + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +// TODO: check the semantics of casts in Rust +let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = + mk_scalar tgt_ty x + +/// The scalar types +type isize : eqtype = scalar Isize +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 +type usize : eqtype = scalar Usize +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max + +/// Negation +let isize_neg = scalar_neg #Isize +let i8_neg = scalar_neg #I8 +let i16_neg = scalar_neg #I16 +let i32_neg = scalar_neg #I32 +let i64_neg = scalar_neg #I64 +let i128_neg = scalar_neg #I128 + +/// Division +let isize_div = scalar_div #Isize +let i8_div = scalar_div #I8 +let i16_div = scalar_div #I16 +let i32_div = scalar_div #I32 +let i64_div = scalar_div #I64 +let i128_div = scalar_div #I128 +let usize_div = scalar_div #Usize +let u8_div = scalar_div #U8 +let u16_div = scalar_div #U16 +let u32_div = scalar_div #U32 +let u64_div = scalar_div #U64 +let u128_div = scalar_div #U128 + +/// Remainder +let isize_rem = scalar_rem #Isize +let i8_rem = scalar_rem #I8 +let i16_rem = scalar_rem #I16 +let i32_rem = scalar_rem #I32 +let i64_rem = scalar_rem #I64 +let i128_rem = scalar_rem #I128 +let usize_rem = scalar_rem #Usize +let u8_rem = scalar_rem #U8 +let u16_rem = scalar_rem #U16 +let u32_rem = scalar_rem #U32 +let u64_rem = scalar_rem #U64 +let u128_rem = scalar_rem #U128 + +/// Addition +let isize_add = scalar_add #Isize +let i8_add = scalar_add #I8 +let i16_add = scalar_add #I16 +let i32_add = scalar_add #I32 +let i64_add = scalar_add #I64 +let i128_add = scalar_add #I128 +let usize_add = scalar_add #Usize +let u8_add = scalar_add #U8 +let u16_add = scalar_add #U16 +let u32_add = scalar_add #U32 +let u64_add = scalar_add #U64 +let u128_add = scalar_add #U128 + +/// Substraction +let isize_sub = scalar_sub #Isize +let i8_sub = scalar_sub #I8 +let i16_sub = scalar_sub #I16 +let i32_sub = scalar_sub #I32 +let i64_sub = scalar_sub #I64 +let i128_sub = scalar_sub #I128 +let usize_sub = scalar_sub #Usize +let u8_sub = scalar_sub #U8 +let u16_sub = scalar_sub #U16 +let u32_sub = scalar_sub #U32 +let u64_sub = scalar_sub #U64 +let u128_sub = scalar_sub #U128 + +/// Multiplication +let isize_mul = scalar_mul #Isize +let i8_mul = scalar_mul #I8 +let i16_mul = scalar_mul #I16 +let i32_mul = scalar_mul #I32 +let i64_mul = scalar_mul #I64 +let i128_mul = scalar_mul #I128 +let usize_mul = scalar_mul #Usize +let u8_mul = scalar_mul #U8 +let u16_mul = scalar_mul #U16 +let u32_mul = scalar_mul #U32 +let u64_mul = scalar_mul #U64 +let u128_mul = scalar_mul #U128 + +(*** Range *) +type range (a : Type0) = { + start : a; + end_ : a; +} + +(*** Array *) +type array (a : Type0) (n : usize) = s:list a{length s = n} + +// We tried putting the normalize_term condition as a refinement on the list +// but it didn't work. It works with the requires clause. +let mk_array (a : Type0) (n : usize) + (l : list a) : + Pure (array a n) + (requires (normalize_term(FStar.List.Tot.length l) = n)) + (ensures (fun _ -> True)) = + normalize_term_spec (FStar.List.Tot.length l); + l + +let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = + if i < length x then Return (list_update x i nx) + else Fail Failure + +(*** Slice *) +type slice (a : Type0) = s:list a{length s <= usize_max} + +let slice_len (a : Type0) (s : slice a) : usize = length s + +let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = + if i < length x then Return (list_update x i nx) + else Fail Failure + +(*** Subslices *) + +let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = + if length s = n then Return s + else Fail Failure + +// TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) +let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = + admit() + +let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = + admit() + +let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = + admit() + +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = + admit() + +let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = + admit() + +let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = + admit() + +let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = + admit() + +(*** Vector *) +type vec (a : Type0) = v:list a{length v <= usize_max} + +let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] +let vec_len (a : Type0) (v : vec a) : usize = length v + +// The **forward** function shouldn't be used +let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () +let vec_push_back (a : Type0) (v : vec a) (x : a) : + Pure (result (vec a)) + (requires True) + (ensures (fun res -> + match res with + | Fail e -> e == Failure + | Return v' -> length v' = length v + 1)) = + if length v < usize_max then begin + (**) assert_norm(length [x] == 1); + (**) append_length v [x]; + (**) assert(length (append v [x]) = length v + 1); + Return (append v [x]) + end + else Fail Failure + +// The **forward** function shouldn't be used +let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail Failure +let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + +// The **backward** function shouldn't be used +let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail Failure + +let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = + if i < length v then Return (index v i) else Fail Failure +let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = + if i < length v then Return (list_update v i nx) else Fail Failure diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index cd18cf29..5e154122 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -305,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -322,55 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -385,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index cd18cf29..5e154122 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -305,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -322,55 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -385,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index cd18cf29..5e154122 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -55,8 +55,12 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let std_mem_replace (a : Type0) (x : a) (y : a) : a = x +let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated @@ -100,6 +104,11 @@ type scalar_ty = | U64 | U128 +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -162,6 +171,15 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = @@ -258,7 +276,7 @@ let u32_add = scalar_add #U32 let u64_add = scalar_add #U64 let u128_add = scalar_add #U128 -/// Substraction +/// Subtraction let isize_sub = scalar_sub #Isize let i8_sub = scalar_sub #I8 let i16_sub = scalar_sub #I16 @@ -286,12 +304,65 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -(*** Range *) -type range (a : Type0) = { +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { start : a; end_ : a; } +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + (*** Array *) type array (a : Type0) (n : usize) = s:list a{length s = n} @@ -305,15 +376,11 @@ let mk_array (a : Type0) (n : usize) normalize_term_spec (FStar.List.Tot.length l); l -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = if i < length x then Return (list_update x i nx) else Fail Failure @@ -322,55 +389,47 @@ type slice (a : Type0) = s:list a{length s <= usize_max} let slice_len (a : Type0) (s : slice a) : usize = length s -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = if i < length x then Return (index x i) else Fail Failure -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = if i < length x then Return (list_update x i nx) else Fail Failure (*** Subslices *) -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = if length s = n then Return s else Fail Failure // TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = admit() -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = admit() -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = admit() -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = admit() -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = admit() (*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) (requires True) (ensures (fun res -> match res with @@ -385,18 +444,253 @@ let vec_push_back (a : Type0) (v : vec a) (x : a) : else Fail Failure // The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = if i < length v then Return (list_update v i x) else Fail Failure -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} -- 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 +- tests/fstar/array/Array.Clauses.Template.fst | 5 +- tests/fstar/array/Array.Funs.fst | 348 ++++++++++++++------------- tests/fstar/array/Array.Types.fst | 4 +- 6 files changed, 200 insertions(+), 188 deletions(-) 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 diff --git a/tests/fstar/array/Array.Clauses.Template.fst b/tests/fstar/array/Array.Clauses.Template.fst index 8a15e230..06056d61 100644 --- a/tests/fstar/array/Array.Clauses.Template.fst +++ b/tests/fstar/array/Array.Clauses.Template.fst @@ -8,11 +8,12 @@ open Array.Types (** [array::sum]: decreases clause *) unfold -let sum_loop_decreases (s : slice u32) (sum : u32) (i : usize) : nat = admit () +let sum_loop_decreases (s : slice u32) (sum0 : u32) (i : usize) : nat = + admit () (** [array::sum2]: decreases clause *) unfold -let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum : u32) +let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : nat = admit () diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index 83256398..a6808c98 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -7,361 +7,369 @@ include Array.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" +(** [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let incr (x : u32) : result u32 = + u32_add x 1 + (** [array::array_to_shared_slice_]: forward function *) -let array_to_shared_slice__fwd - (t : Type0) (s : array t 32) : result (slice t) = - array_to_slice_shared t 32 s +let array_to_shared_slice_ (t : Type0) (s : array t 32) : result (slice t) = + array_to_slice t 32 s (** [array::array_to_mut_slice_]: forward function *) -let array_to_mut_slice__fwd (t : Type0) (s : array t 32) : result (slice t) = - array_to_slice_mut_fwd t 32 s +let array_to_mut_slice_ (t : Type0) (s : array t 32) : result (slice t) = + array_to_slice t 32 s (** [array::array_to_mut_slice_]: backward function 0 *) let array_to_mut_slice__back (t : Type0) (s : array t 32) (ret : slice t) : result (array t 32) = - array_to_slice_mut_back t 32 s ret + array_from_slice t 32 s ret (** [array::array_len]: forward function *) -let array_len_fwd (t : Type0) (s : array t 32) : result usize = - let* s0 = array_to_slice_shared t 32 s in let i = slice_len t s0 in Return i +let array_len (t : Type0) (s : array t 32) : result usize = + let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i (** [array::shared_array_len]: forward function *) -let shared_array_len_fwd (t : Type0) (s : array t 32) : result usize = - let* s0 = array_to_slice_shared t 32 s in let i = slice_len t s0 in Return i +let shared_array_len (t : Type0) (s : array t 32) : result usize = + let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i (** [array::shared_slice_len]: forward function *) -let shared_slice_len_fwd (t : Type0) (s : slice t) : result usize = +let shared_slice_len (t : Type0) (s : slice t) : result usize = let i = slice_len t s in Return i (** [array::index_array_shared]: forward function *) -let index_array_shared_fwd - (t : Type0) (s : array t 32) (i : usize) : result t = - array_index_shared t 32 s i +let index_array_shared (t : Type0) (s : array t 32) (i : usize) : result t = + array_index_usize t 32 s i (** [array::index_array_u32]: forward function *) -let index_array_u32_fwd (s : array u32 32) (i : usize) : result u32 = - array_index_shared u32 32 s i - -(** [array::index_array_generic]: forward function *) -let index_array_generic_fwd - (n : usize) (s : array u32 n) (i : usize) : result u32 = - array_index_shared u32 n s i - -(** [array::index_array_generic_call]: forward function *) -let index_array_generic_call_fwd - (n : usize) (s : array u32 n) (i : usize) : result u32 = - index_array_generic_fwd n s i +let index_array_u32 (s : array u32 32) (i : usize) : result u32 = + array_index_usize u32 32 s i (** [array::index_array_copy]: forward function *) -let index_array_copy_fwd (x : array u32 32) : result u32 = - array_index_shared u32 32 x 0 +let index_array_copy (x : array u32 32) : result u32 = + array_index_usize u32 32 x 0 (** [array::index_mut_array]: forward function *) -let index_mut_array_fwd (t : Type0) (s : array t 32) (i : usize) : result t = - array_index_mut_fwd t 32 s i +let index_mut_array (t : Type0) (s : array t 32) (i : usize) : result t = + array_index_usize t 32 s i (** [array::index_mut_array]: backward function 0 *) let index_mut_array_back (t : Type0) (s : array t 32) (i : usize) (ret : t) : result (array t 32) = - array_index_mut_back t 32 s i ret + array_update_usize t 32 s i ret (** [array::index_slice]: forward function *) -let index_slice_fwd (t : Type0) (s : slice t) (i : usize) : result t = - slice_index_shared t s i +let index_slice (t : Type0) (s : slice t) (i : usize) : result t = + slice_index_usize t s i (** [array::index_mut_slice]: forward function *) -let index_mut_slice_fwd (t : Type0) (s : slice t) (i : usize) : result t = - slice_index_mut_fwd t s i +let index_mut_slice (t : Type0) (s : slice t) (i : usize) : result t = + slice_index_usize t s i (** [array::index_mut_slice]: backward function 0 *) let index_mut_slice_back (t : Type0) (s : slice t) (i : usize) (ret : t) : result (slice t) = - slice_index_mut_back t s i ret + slice_update_usize t s i ret (** [array::slice_subslice_shared_]: forward function *) -let slice_subslice_shared__fwd +let slice_subslice_shared_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = - slice_subslice_shared u32 x (Mkrange y z) + core_slice_index_Slice_index u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } (** [array::slice_subslice_mut_]: forward function *) -let slice_subslice_mut__fwd +let slice_subslice_mut_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = - slice_subslice_mut_fwd u32 x (Mkrange y z) + core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } (** [array::slice_subslice_mut_]: backward function 0 *) let slice_subslice_mut__back (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : result (slice u32) = - slice_subslice_mut_back u32 x (Mkrange y z) ret + core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } ret (** [array::array_to_slice_shared_]: forward function *) -let array_to_slice_shared__fwd (x : array u32 32) : result (slice u32) = - array_to_slice_shared u32 32 x +let array_to_slice_shared_ (x : array u32 32) : result (slice u32) = + array_to_slice u32 32 x (** [array::array_to_slice_mut_]: forward function *) -let array_to_slice_mut__fwd (x : array u32 32) : result (slice u32) = - array_to_slice_mut_fwd u32 32 x +let array_to_slice_mut_ (x : array u32 32) : result (slice u32) = + array_to_slice u32 32 x (** [array::array_to_slice_mut_]: backward function 0 *) let array_to_slice_mut__back (x : array u32 32) (ret : slice u32) : result (array u32 32) = - array_to_slice_mut_back u32 32 x ret + array_from_slice u32 32 x ret (** [array::array_subslice_shared_]: forward function *) -let array_subslice_shared__fwd +let array_subslice_shared_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - array_subslice_shared u32 32 x (Mkrange y z) + core_array_Array_index u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } (** [array::array_subslice_mut_]: forward function *) -let array_subslice_mut__fwd +let array_subslice_mut_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - array_subslice_mut_fwd u32 32 x (Mkrange y z) + core_array_Array_index_mut u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } (** [array::array_subslice_mut_]: backward function 0 *) let array_subslice_mut__back (x : array u32 32) (y : usize) (z : usize) (ret : slice u32) : result (array u32 32) = - array_subslice_mut_back u32 32 x (Mkrange y z) ret + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } ret (** [array::index_slice_0]: forward function *) -let index_slice_0_fwd (t : Type0) (s : slice t) : result t = - slice_index_shared t s 0 +let index_slice_0 (t : Type0) (s : slice t) : result t = + slice_index_usize t s 0 (** [array::index_array_0]: forward function *) -let index_array_0_fwd (t : Type0) (s : array t 32) : result t = - array_index_shared t 32 s 0 +let index_array_0 (t : Type0) (s : array t 32) : result t = + array_index_usize t 32 s 0 (** [array::index_index_array]: forward function *) -let index_index_array_fwd +let index_index_array (s : array (array u32 32) 32) (i : usize) (j : usize) : result u32 = - let* a = array_index_shared (array u32 32) 32 s i in - array_index_shared u32 32 a j - -(** [array::const_gen_ret]: forward function *) -let const_gen_ret_fwd (n : usize) : result usize = - Return n + let* a = array_index_usize (array u32 32) 32 s i in + array_index_usize u32 32 a j (** [array::update_update_array]: forward function *) -let update_update_array_fwd +let update_update_array (s : array (array u32 32) 32) (i : usize) (j : usize) : result unit = - let* a = array_index_mut_fwd (array u32 32) 32 s i in - let* a0 = array_index_mut_back u32 32 a j 0 in - let* _ = array_index_mut_back (array u32 32) 32 s i a0 in + let* a = array_index_usize (array u32 32) 32 s i in + let* a0 = array_update_usize u32 32 a j 0 in + let* _ = array_update_usize (array u32 32) 32 s i a0 in Return () (** [array::array_local_deep_copy]: forward function *) -let array_local_deep_copy_fwd (x : array u32 32) : result unit = +let array_local_deep_copy (x : array u32 32) : result unit = Return () (** [array::take_array]: forward function *) -let take_array_fwd (a : array u32 2) : result unit = +let take_array (a : array u32 2) : result unit = Return () (** [array::take_array_borrow]: forward function *) -let take_array_borrow_fwd (a : array u32 2) : result unit = +let take_array_borrow (a : array u32 2) : result unit = Return () (** [array::take_slice]: forward function *) -let take_slice_fwd (s : slice u32) : result unit = +let take_slice (s : slice u32) : result unit = Return () (** [array::take_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let take_mut_slice_fwd_back (s : slice u32) : result (slice u32) = +let take_mut_slice (s : slice u32) : result (slice u32) = Return s (** [array::take_all]: forward function *) -let take_all_fwd : result unit = - let* _ = take_array_fwd (mk_array u32 2 [ 0; 0 ]) in - let* _ = take_array_borrow_fwd (mk_array u32 2 [ 0; 0 ]) in - let* s = array_to_slice_shared u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* _ = take_slice_fwd s in - let* s0 = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s1 = take_mut_slice_fwd_back s0 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in +let take_all : result unit = + let* _ = take_array (mk_array u32 2 [ 0; 0 ]) in + let* _ = take_array_borrow (mk_array u32 2 [ 0; 0 ]) in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* _ = take_slice s in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s1 = take_mut_slice s0 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in Return () (** [array::index_array]: forward function *) -let index_array_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let index_array (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::index_array_borrow]: forward function *) -let index_array_borrow_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let index_array_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::index_slice_u32_0]: forward function *) -let index_slice_u32_0_fwd (x : slice u32) : result u32 = - slice_index_shared u32 x 0 +let index_slice_u32_0 (x : slice u32) : result u32 = + slice_index_usize u32 x 0 (** [array::index_mut_slice_u32_0]: forward function *) -let index_mut_slice_u32_0_fwd (x : slice u32) : result u32 = - slice_index_shared u32 x 0 +let index_mut_slice_u32_0 (x : slice u32) : result u32 = + slice_index_usize u32 x 0 (** [array::index_mut_slice_u32_0]: backward function 0 *) let index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) = - let* _ = slice_index_shared u32 x 0 in Return x + let* _ = slice_index_usize u32 x 0 in Return x (** [array::index_all]: forward function *) -let index_all_fwd : result u32 = - let* i = index_array_fwd (mk_array u32 2 [ 0; 0 ]) in - let* i0 = index_array_fwd (mk_array u32 2 [ 0; 0 ]) in +let index_all : result u32 = + let* i = index_array (mk_array u32 2 [ 0; 0 ]) in + let* i0 = index_array (mk_array u32 2 [ 0; 0 ]) in let* i1 = u32_add i i0 in - let* i2 = index_array_borrow_fwd (mk_array u32 2 [ 0; 0 ]) in + let* i2 = index_array_borrow (mk_array u32 2 [ 0; 0 ]) in let* i3 = u32_add i1 i2 in - let* s = array_to_slice_shared u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* i4 = index_slice_u32_0_fwd s in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* i4 = index_slice_u32_0 s in let* i5 = u32_add i3 i4 in - let* s0 = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* i6 = index_mut_slice_u32_0_fwd s0 in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* i6 = index_mut_slice_u32_0 s0 in let* i7 = u32_add i5 i6 in let* s1 = index_mut_slice_u32_0_back s0 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in Return i7 (** [array::update_array]: forward function *) -let update_array_fwd (x : array u32 2) : result unit = - let* _ = array_index_mut_back u32 2 x 0 1 in Return () +let update_array (x : array u32 2) : result unit = + let* _ = array_update_usize u32 2 x 0 1 in Return () (** [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let update_array_mut_borrow_fwd_back (x : array u32 2) : result (array u32 2) = - array_index_mut_back u32 2 x 0 1 +let update_array_mut_borrow (x : array u32 2) : result (array u32 2) = + array_update_usize u32 2 x 0 1 (** [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let update_mut_slice_fwd_back (x : slice u32) : result (slice u32) = - slice_index_mut_back u32 x 0 1 +let update_mut_slice (x : slice u32) : result (slice u32) = + slice_update_usize u32 x 0 1 (** [array::update_all]: forward function *) -let update_all_fwd : result unit = - let* _ = update_array_fwd (mk_array u32 2 [ 0; 0 ]) in - let* x = update_array_mut_borrow_fwd_back (mk_array u32 2 [ 0; 0 ]) in - let* s = array_to_slice_mut_fwd u32 2 x in - let* s0 = update_mut_slice_fwd_back s in - let* _ = array_to_slice_mut_back u32 2 x s0 in +let update_all : result unit = + let* _ = update_array (mk_array u32 2 [ 0; 0 ]) in + let* x = update_array_mut_borrow (mk_array u32 2 [ 0; 0 ]) in + let* s = array_to_slice u32 2 x in + let* s0 = update_mut_slice s in + let* _ = array_from_slice u32 2 x s0 in Return () (** [array::range_all]: forward function *) -let range_all_fwd : result unit = +let range_all : result unit = let* s = - array_subslice_mut_fwd u32 4 (mk_array u32 4 [ 0; 0; 0; 0 ]) (Mkrange 1 3) - in - let* s0 = update_mut_slice_fwd_back s in + core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } in + let* s0 = update_mut_slice s in let* _ = - array_subslice_mut_back u32 4 (mk_array u32 4 [ 0; 0; 0; 0 ]) (Mkrange 1 3) - s0 in + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } s0 in Return () (** [array::deref_array_borrow]: forward function *) -let deref_array_borrow_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let deref_array_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::deref_array_mut_borrow]: forward function *) -let deref_array_mut_borrow_fwd (x : array u32 2) : result u32 = - array_index_shared u32 2 x 0 +let deref_array_mut_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 (** [array::deref_array_mut_borrow]: backward function 0 *) let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = - let* _ = array_index_shared u32 2 x 0 in Return x + let* _ = array_index_usize u32 2 x 0 in Return x (** [array::take_array_t]: forward function *) -let take_array_t_fwd (a : array t_t 2) : result unit = +let take_array_t (a : array ab_t 2) : result unit = Return () (** [array::non_copyable_array]: forward function *) -let non_copyable_array_fwd : result unit = - let* _ = take_array_t_fwd (mk_array t_t 2 [ TA; TB ]) in Return () +let non_copyable_array : result unit = + let* _ = take_array_t (mk_array ab_t 2 [ ABA; ABB ]) in Return () (** [array::sum]: loop 0: forward function *) -let rec sum_loop_fwd - (s : slice u32) (sum : u32) (i : usize) : - Tot (result u32) (decreases (sum_loop_decreases s sum i)) +let rec sum_loop + (s : slice u32) (sum0 : u32) (i : usize) : + Tot (result u32) (decreases (sum_loop_decreases s sum0 i)) = let i0 = slice_len u32 s in if i < i0 then - let* i1 = slice_index_shared u32 s i in - let* sum0 = u32_add sum i1 in + let* i1 = slice_index_usize u32 s i in + let* sum1 = u32_add sum0 i1 in let* i2 = usize_add i 1 in - sum_loop_fwd s sum0 i2 - else Return sum + sum_loop s sum1 i2 + else Return sum0 (** [array::sum]: forward function *) -let sum_fwd (s : slice u32) : result u32 = - sum_loop_fwd s 0 0 +let sum (s : slice u32) : result u32 = + sum_loop s 0 0 (** [array::sum2]: loop 0: forward function *) -let rec sum2_loop_fwd - (s : slice u32) (s2 : slice u32) (sum : u32) (i : usize) : - Tot (result u32) (decreases (sum2_loop_decreases s s2 sum i)) +let rec sum2_loop + (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : + Tot (result u32) (decreases (sum2_loop_decreases s s2 sum0 i)) = let i0 = slice_len u32 s in if i < i0 then - let* i1 = slice_index_shared u32 s i in - let* i2 = slice_index_shared u32 s2 i in + let* i1 = slice_index_usize u32 s i in + let* i2 = slice_index_usize u32 s2 i in let* i3 = u32_add i1 i2 in - let* sum0 = u32_add sum i3 in + let* sum1 = u32_add sum0 i3 in let* i4 = usize_add i 1 in - sum2_loop_fwd s s2 sum0 i4 - else Return sum + sum2_loop s s2 sum1 i4 + else Return sum0 (** [array::sum2]: forward function *) -let sum2_fwd (s : slice u32) (s2 : slice u32) : result u32 = +let sum2 (s : slice u32) (s2 : slice u32) : result u32 = let i = slice_len u32 s in let i0 = slice_len u32 s2 in - if not (i = i0) then Fail Failure else sum2_loop_fwd s s2 0 0 + if not (i = i0) then Fail Failure else sum2_loop s s2 0 0 (** [array::f0]: forward function *) -let f0_fwd : result unit = - let* s = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 1; 2 ]) in - let* s0 = slice_index_mut_back u32 s 0 1 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in +let f0 : result unit = + let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in + let* s0 = slice_update_usize u32 s 0 1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in Return () (** [array::f1]: forward function *) -let f1_fwd : result unit = - let* _ = array_index_mut_back u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in - Return () +let f1 : result unit = + let* _ = array_update_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in Return () (** [array::f2]: forward function *) -let f2_fwd (i : u32) : result unit = +let f2 (i : u32) : result unit = Return () (** [array::f4]: forward function *) -let f4_fwd (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - array_subslice_shared u32 32 x (Mkrange y z) +let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = + core_array_Array_index u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } (** [array::f3]: forward function *) -let f3_fwd : result u32 = - let* i = array_index_shared u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in - let* _ = f2_fwd i in - let* s = array_to_slice_shared u32 2 (mk_array u32 2 [ 1; 2 ]) in - let* s0 = - f4_fwd - (mk_array u32 32 [ - 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; - 0; 0; 0; 0; 0; 0; 0; 0 - ]) 16 18 in - sum2_fwd s s0 +let f3 : result u32 = + let* i = array_index_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in + let* _ = f2 i in + let b = array_repeat u32 32 0 in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in + let* s0 = f4 b 16 18 in + sum2 s s0 (** [array::SZ] *) let sz_body : result usize = Return 32 let sz_c : usize = eval_global sz_body (** [array::f5]: forward function *) -let f5_fwd (x : array u32 32) : result u32 = - array_index_shared u32 32 x 0 +let f5 (x : array u32 32) : result u32 = + array_index_usize u32 32 x 0 (** [array::ite]: forward function *) -let ite_fwd : result unit = - let* s = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s0 = array_to_slice_mut_fwd u32 2 (mk_array u32 2 [ 0; 0 ]) in +let ite : result unit = + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in let* s1 = index_mut_slice_u32_0_back s0 in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in let* s2 = index_mut_slice_u32_0_back s in - let* _ = array_to_slice_mut_back u32 2 (mk_array u32 2 [ 0; 0 ]) s2 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s2 in Return () diff --git a/tests/fstar/array/Array.Types.fst b/tests/fstar/array/Array.Types.fst index 5e8e81d8..0ec9c12f 100644 --- a/tests/fstar/array/Array.Types.fst +++ b/tests/fstar/array/Array.Types.fst @@ -5,6 +5,6 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [array::T] *) -type t_t = | TA : t_t | TB : t_t +(** [array::AB] *) +type ab_t = | ABA : ab_t | ABB : ab_t -- cgit v1.2.3 From 4f824528f5e0c0f898b20917c6c06821efb934da Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 12:12:18 +0200 Subject: Regenerate some of the F* test files --- backends/fstar/Primitives.fst | 21 +- tests/fstar/array/Primitives.fst | 19 +- tests/fstar/betree/Primitives.fst | 19 +- tests/fstar/betree_back_stateful/Primitives.fst | 19 +- tests/fstar/hashmap/Primitives.fst | 19 +- tests/fstar/hashmap_on_disk/Primitives.fst | 19 +- tests/fstar/misc/Constants.fst | 46 +-- tests/fstar/misc/External.Funs.fst | 38 +-- tests/fstar/misc/External.Opaque.fsti | 8 +- tests/fstar/misc/External.Types.fsti | 2 +- tests/fstar/misc/Loops.Clauses.Template.fst | 3 +- tests/fstar/misc/Loops.Clauses.fst | 2 +- tests/fstar/misc/Loops.Funs.fst | 392 ++++++++++++------------ tests/fstar/misc/Loops.Types.fst | 4 +- tests/fstar/misc/NoNestedBorrows.fst | 266 ++++++++-------- tests/fstar/misc/Paper.fst | 65 ++-- tests/fstar/misc/PoloniusList.fst | 18 +- tests/fstar/misc/Primitives.fst | 21 +- tests/lean/Constants.lean | 8 +- 19 files changed, 549 insertions(+), 440 deletions(-) diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 5e154122..71d75c11 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,13 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 5e154122..3110b247 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,11 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) = + admit() diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 5e154122..3110b247 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,11 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) = + admit() diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 5e154122..3110b247 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,11 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) = + admit() diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 5e154122..3110b247 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,11 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) = + admit() diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 5e154122..3110b247 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,11 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) = + admit() diff --git a/tests/fstar/misc/Constants.fst b/tests/fstar/misc/Constants.fst index 7dfb6f36..c21d6a5f 100644 --- a/tests/fstar/misc/Constants.fst +++ b/tests/fstar/misc/Constants.fst @@ -18,30 +18,30 @@ let x2_body : result u32 = Return 3 let x2_c : u32 = eval_global x2_body (** [constants::incr]: forward function *) -let incr_fwd (n : u32) : result u32 = +let incr (n : u32) : result u32 = u32_add n 1 (** [constants::X3] *) -let x3_body : result u32 = incr_fwd 32 +let x3_body : result u32 = incr 32 let x3_c : u32 = eval_global x3_body (** [constants::mk_pair0]: forward function *) -let mk_pair0_fwd (x : u32) (y : u32) : result (u32 & u32) = +let mk_pair0 (x : u32) (y : u32) : result (u32 & u32) = Return (x, y) (** [constants::Pair] *) -type pair_t (t1 t2 : Type0) = { pair_x : t1; pair_y : t2; } +type pair_t (t1 t2 : Type0) = { x : t1; y : t2; } (** [constants::mk_pair1]: forward function *) -let mk_pair1_fwd (x : u32) (y : u32) : result (pair_t u32 u32) = - Return { pair_x = x; pair_y = y } +let mk_pair1 (x : u32) (y : u32) : result (pair_t u32 u32) = + Return { x = x; y = y } (** [constants::P0] *) -let p0_body : result (u32 & u32) = mk_pair0_fwd 0 1 +let p0_body : result (u32 & u32) = mk_pair0 0 1 let p0_c : (u32 & u32) = eval_global p0_body (** [constants::P1] *) -let p1_body : result (pair_t u32 u32) = mk_pair1_fwd 0 1 +let p1_body : result (pair_t u32 u32) = mk_pair1 0 1 let p1_c : pair_t u32 u32 = eval_global p1_body (** [constants::P2] *) @@ -49,26 +49,26 @@ let p2_body : result (u32 & u32) = Return (0, 1) let p2_c : (u32 & u32) = eval_global p2_body (** [constants::P3] *) -let p3_body : result (pair_t u32 u32) = Return { pair_x = 0; pair_y = 1 } +let p3_body : result (pair_t u32 u32) = Return { x = 0; y = 1 } let p3_c : pair_t u32 u32 = eval_global p3_body (** [constants::Wrap] *) -type wrap_t (t : Type0) = { wrap_val : t; } +type wrap_t (t : Type0) = { value : t; } (** [constants::Wrap::{0}::new]: forward function *) -let wrap_new_fwd (t : Type0) (val0 : t) : result (wrap_t t) = - Return { wrap_val = val0 } +let wrap_new (t : Type0) (value : t) : result (wrap_t t) = + Return { value = value } (** [constants::Y] *) -let y_body : result (wrap_t i32) = wrap_new_fwd i32 2 +let y_body : result (wrap_t i32) = wrap_new i32 2 let y_c : wrap_t i32 = eval_global y_body (** [constants::unwrap_y]: forward function *) -let unwrap_y_fwd : result i32 = - Return y_c.wrap_val +let unwrap_y : result i32 = + Return y_c.value (** [constants::YVAL] *) -let yval_body : result i32 = unwrap_y_fwd +let yval_body : result i32 = unwrap_y let yval_c : i32 = eval_global yval_body (** [constants::get_z1::Z1] *) @@ -76,11 +76,11 @@ let get_z1_z1_body : result i32 = Return 3 let get_z1_z1_c : i32 = eval_global get_z1_z1_body (** [constants::get_z1]: forward function *) -let get_z1_fwd : result i32 = +let get_z1 : result i32 = Return get_z1_z1_c (** [constants::add]: forward function *) -let add_fwd (a : i32) (b : i32) : result i32 = +let add (a : i32) (b : i32) : result i32 = i32_add a b (** [constants::Q1] *) @@ -92,19 +92,19 @@ let q2_body : result i32 = Return q1_c let q2_c : i32 = eval_global q2_body (** [constants::Q3] *) -let q3_body : result i32 = add_fwd q2_c 3 +let q3_body : result i32 = add q2_c 3 let q3_c : i32 = eval_global q3_body (** [constants::get_z2]: forward function *) -let get_z2_fwd : result i32 = - let* i = get_z1_fwd in let* i0 = add_fwd i q3_c in add_fwd q1_c i0 +let get_z2 : result i32 = + let* i = get_z1 in let* i0 = add i q3_c in add q1_c i0 (** [constants::S1] *) let s1_body : result u32 = Return 6 let s1_c : u32 = eval_global s1_body (** [constants::S2] *) -let s2_body : result u32 = incr_fwd s1_c +let s2_body : result u32 = incr s1_c let s2_c : u32 = eval_global s2_body (** [constants::S3] *) @@ -112,6 +112,6 @@ let s3_body : result (pair_t u32 u32) = Return p3_c let s3_c : pair_t u32 u32 = eval_global s3_body (** [constants::S4] *) -let s4_body : result (pair_t u32 u32) = mk_pair1_fwd 7 8 +let s4_body : result (pair_t u32 u32) = mk_pair1 7 8 let s4_c : pair_t u32 u32 = eval_global s4_body diff --git a/tests/fstar/misc/External.Funs.fst b/tests/fstar/misc/External.Funs.fst index f118a2cf..e26014ac 100644 --- a/tests/fstar/misc/External.Funs.fst +++ b/tests/fstar/misc/External.Funs.fst @@ -8,8 +8,8 @@ include External.Opaque #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [external::swap]: forward function *) -let swap_fwd (t : Type0) (x : t) (y : t) (st : state) : result (state & unit) = - let* (st0, _) = core_mem_swap_fwd t x y st in +let swap (t : Type0) (x : t) (y : t) (st : state) : result (state & unit) = + let* (st0, _) = core_mem_swap t x y st in let* (st1, _) = core_mem_swap_back0 t x y st st0 in let* (st2, _) = core_mem_swap_back1 t x y st st1 in Return (st2, ()) @@ -19,28 +19,29 @@ let swap_back (t : Type0) (x : t) (y : t) (st : state) (st0 : state) : result (state & (t & t)) = - let* (st1, _) = core_mem_swap_fwd t x y st in + let* (st1, _) = core_mem_swap t x y st in let* (st2, x0) = core_mem_swap_back0 t x y st st1 in let* (_, y0) = core_mem_swap_back1 t x y st st2 in Return (st0, (x0, y0)) (** [external::test_new_non_zero_u32]: forward function *) -let test_new_non_zero_u32_fwd - (x : u32) (st : state) : result (state & core_num_nonzero_non_zero_u32_t) = - let* (st0, opt) = core_num_nonzero_non_zero_u32_new_fwd x st in - core_option_option_unwrap_fwd core_num_nonzero_non_zero_u32_t opt st0 +let test_new_non_zero_u32 + (x : u32) (st : state) : result (state & core_num_nonzero_NonZeroU32_t) = + let* (st0, o) = core_num_nonzero_NonZeroU32_new x st in + core_option_Option_unwrap core_num_nonzero_NonZeroU32_t o st0 (** [external::test_vec]: forward function *) -let test_vec_fwd : result unit = - let v = vec_new u32 in let* _ = vec_push_back u32 v 0 in Return () +let test_vec : result unit = + let v = alloc_vec_Vec_new u32 in + let* _ = alloc_vec_Vec_push u32 v 0 in + Return () (** Unit test for [external::test_vec] *) -let _ = assert_norm (test_vec_fwd = Return ()) +let _ = assert_norm (test_vec = Return ()) (** [external::custom_swap]: forward function *) -let custom_swap_fwd - (t : Type0) (x : t) (y : t) (st : state) : result (state & t) = - let* (st0, _) = core_mem_swap_fwd t x y st in +let custom_swap (t : Type0) (x : t) (y : t) (st : state) : result (state & t) = + let* (st0, _) = core_mem_swap t x y st in let* (st1, x0) = core_mem_swap_back0 t x y st st0 in let* (st2, _) = core_mem_swap_back1 t x y st st1 in Return (st2, x0) @@ -50,15 +51,14 @@ let custom_swap_back (t : Type0) (x : t) (y : t) (st : state) (ret : t) (st0 : state) : result (state & (t & t)) = - let* (st1, _) = core_mem_swap_fwd t x y st in + let* (st1, _) = core_mem_swap t x y st in let* (st2, _) = core_mem_swap_back0 t x y st st1 in let* (_, y0) = core_mem_swap_back1 t x y st st2 in Return (st0, (ret, y0)) (** [external::test_custom_swap]: forward function *) -let test_custom_swap_fwd - (x : u32) (y : u32) (st : state) : result (state & unit) = - let* (st0, _) = custom_swap_fwd u32 x y st in Return (st0, ()) +let test_custom_swap (x : u32) (y : u32) (st : state) : result (state & unit) = + let* (st0, _) = custom_swap u32 x y st in Return (st0, ()) (** [external::test_custom_swap]: backward function 0 *) let test_custom_swap_back @@ -68,8 +68,8 @@ let test_custom_swap_back custom_swap_back u32 x y st 1 st0 (** [external::test_swap_non_zero]: forward function *) -let test_swap_non_zero_fwd (x : u32) (st : state) : result (state & u32) = - let* (st0, _) = swap_fwd u32 x 0 st in +let test_swap_non_zero (x : u32) (st : state) : result (state & u32) = + let* (st0, _) = swap u32 x 0 st in let* (st1, (x0, _)) = swap_back u32 x 0 st st0 in if x0 = 0 then Fail Failure else Return (st1, x0) diff --git a/tests/fstar/misc/External.Opaque.fsti b/tests/fstar/misc/External.Opaque.fsti index 2e19f767..85cf285c 100644 --- a/tests/fstar/misc/External.Opaque.fsti +++ b/tests/fstar/misc/External.Opaque.fsti @@ -7,7 +7,7 @@ include External.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [core::mem::swap]: forward function *) -val core_mem_swap_fwd (t : Type0) : t -> t -> state -> result (state & unit) +val core_mem_swap (t : Type0) : t -> t -> state -> result (state & unit) (** [core::mem::swap]: backward function 0 *) val core_mem_swap_back0 @@ -18,10 +18,10 @@ val core_mem_swap_back1 (t : Type0) : t -> t -> state -> state -> result (state & t) (** [core::num::nonzero::NonZeroU32::{14}::new]: forward function *) -val core_num_nonzero_non_zero_u32_new_fwd - : u32 -> state -> result (state & (option core_num_nonzero_non_zero_u32_t)) +val core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state & (option core_num_nonzero_NonZeroU32_t)) (** [core::option::Option::{0}::unwrap]: forward function *) -val core_option_option_unwrap_fwd +val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/misc/External.Types.fsti b/tests/fstar/misc/External.Types.fsti index 4a13a744..78b5228d 100644 --- a/tests/fstar/misc/External.Types.fsti +++ b/tests/fstar/misc/External.Types.fsti @@ -6,7 +6,7 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [core::num::nonzero::NonZeroU32] *) -val core_num_nonzero_non_zero_u32_t : Type0 +val core_num_nonzero_NonZeroU32_t : Type0 (** The state type used in the state-error monad *) val state : Type0 diff --git a/tests/fstar/misc/Loops.Clauses.Template.fst b/tests/fstar/misc/Loops.Clauses.Template.fst index 053b7663..9920bdc1 100644 --- a/tests/fstar/misc/Loops.Clauses.Template.fst +++ b/tests/fstar/misc/Loops.Clauses.Template.fst @@ -22,7 +22,8 @@ let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : admit () (** [loops::clear]: decreases clause *) -unfold let clear_loop_decreases (v : vec u32) (i : usize) : nat = admit () +unfold +let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () (** [loops::list_mem]: decreases clause *) unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () diff --git a/tests/fstar/misc/Loops.Clauses.fst b/tests/fstar/misc/Loops.Clauses.fst index 82f34de1..75194437 100644 --- a/tests/fstar/misc/Loops.Clauses.fst +++ b/tests/fstar/misc/Loops.Clauses.fst @@ -20,7 +20,7 @@ let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : nat if max >= i then max - i else 0 (** [loops::clear]: decreases clause *) -unfold let clear_loop_decreases (v : vec u32) (i : usize) : nat = +unfold let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = if i <= List.Tot.length v then List.Tot.length v - i else 0 (** [loops::list_mem]: decreases clause *) diff --git a/tests/fstar/misc/Loops.Funs.fst b/tests/fstar/misc/Loops.Funs.fst index 9a80f415..0f755351 100644 --- a/tests/fstar/misc/Loops.Funs.fst +++ b/tests/fstar/misc/Loops.Funs.fst @@ -8,20 +8,20 @@ include Loops.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [loops::sum]: loop 0: forward function *) -let rec sum_loop_fwd +let rec sum_loop (max : u32) (i : u32) (s : u32) : Tot (result u32) (decreases (sum_loop_decreases max i s)) = if i < max - then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop_fwd max i0 s0 + then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop max i0 s0 else u32_mul s 2 (** [loops::sum]: forward function *) -let sum_fwd (max : u32) : result u32 = - sum_loop_fwd max 0 0 +let sum (max : u32) : result u32 = + sum_loop max 0 0 (** [loops::sum_with_mut_borrows]: loop 0: forward function *) -let rec sum_with_mut_borrows_loop_fwd +let rec sum_with_mut_borrows_loop (max : u32) (mi : u32) (ms : u32) : Tot (result u32) (decreases (sum_with_mut_borrows_loop_decreases max mi ms)) = @@ -29,15 +29,15 @@ let rec sum_with_mut_borrows_loop_fwd then let* ms0 = u32_add ms mi in let* mi0 = u32_add mi 1 in - sum_with_mut_borrows_loop_fwd max mi0 ms0 + sum_with_mut_borrows_loop max mi0 ms0 else u32_mul ms 2 (** [loops::sum_with_mut_borrows]: forward function *) -let sum_with_mut_borrows_fwd (max : u32) : result u32 = - sum_with_mut_borrows_loop_fwd max 0 0 +let sum_with_mut_borrows (max : u32) : result u32 = + sum_with_mut_borrows_loop max 0 0 (** [loops::sum_with_shared_borrows]: loop 0: forward function *) -let rec sum_with_shared_borrows_loop_fwd +let rec sum_with_shared_borrows_loop (max : u32) (i : u32) (s : u32) : Tot (result u32) (decreases (sum_with_shared_borrows_loop_decreases max i s)) = @@ -45,62 +45,64 @@ let rec sum_with_shared_borrows_loop_fwd then let* i0 = u32_add i 1 in let* s0 = u32_add s i0 in - sum_with_shared_borrows_loop_fwd max i0 s0 + sum_with_shared_borrows_loop max i0 s0 else u32_mul s 2 (** [loops::sum_with_shared_borrows]: forward function *) -let sum_with_shared_borrows_fwd (max : u32) : result u32 = - sum_with_shared_borrows_loop_fwd max 0 0 +let sum_with_shared_borrows (max : u32) : result u32 = + sum_with_shared_borrows_loop max 0 0 (** [loops::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec clear_loop_fwd_back - (v : vec u32) (i : usize) : - Tot (result (vec u32)) (decreases (clear_loop_decreases v i)) +let rec clear_loop + (v : alloc_vec_Vec u32) (i : usize) : + Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) = - let i0 = vec_len u32 v in + let i0 = alloc_vec_Vec_len u32 v in if i < i0 then let* i1 = usize_add i 1 in - let* v0 = vec_index_mut_back u32 v i 0 in - clear_loop_fwd_back v0 i1 + let* v0 = + alloc_vec_Vec_index_mut_back u32 usize + (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0 in + clear_loop v0 i1 else Return v (** [loops::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let clear_fwd_back (v : vec u32) : result (vec u32) = - clear_loop_fwd_back v 0 +let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = + clear_loop v 0 (** [loops::list_mem]: loop 0: forward function *) -let rec list_mem_loop_fwd +let rec list_mem_loop (x : u32) (ls : list_t u32) : Tot (result bool) (decreases (list_mem_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> if y = x then Return true else list_mem_loop_fwd x tl - | ListNil -> Return false + | List_Cons y tl -> if y = x then Return true else list_mem_loop x tl + | List_Nil -> Return false end (** [loops::list_mem]: forward function *) -let list_mem_fwd (x : u32) (ls : list_t u32) : result bool = - list_mem_loop_fwd x ls +let list_mem (x : u32) (ls : list_t u32) : result bool = + list_mem_loop x ls (** [loops::list_nth_mut_loop]: loop 0: forward function *) -let rec list_nth_mut_loop_loop_fwd +let rec list_nth_mut_loop_loop (t : Type0) (ls : list_t t) (i : u32) : Tot (result t) (decreases (list_nth_mut_loop_loop_decreases t ls i)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_loop_loop_fwd t tl i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_mut_loop_loop t tl i0 + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop]: forward function *) -let list_nth_mut_loop_fwd (t : Type0) (ls : list_t t) (i : u32) : result t = - list_nth_mut_loop_loop_fwd t ls i +let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result t = + list_nth_mut_loop_loop t ls i (** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) let rec list_nth_mut_loop_loop_back @@ -108,14 +110,14 @@ let rec list_nth_mut_loop_loop_back Tot (result (list_t t)) (decreases (list_nth_mut_loop_loop_decreases t ls i)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_loop_loop_back t tl i0 ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop]: backward function 0 *) @@ -124,36 +126,40 @@ let list_nth_mut_loop_back list_nth_mut_loop_loop_back t ls i ret (** [loops::list_nth_shared_loop]: loop 0: forward function *) -let rec list_nth_shared_loop_loop_fwd +let rec list_nth_shared_loop_loop (t : Type0) (ls : list_t t) (i : u32) : Tot (result t) (decreases (list_nth_shared_loop_loop_decreases t ls i)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_loop_loop_fwd t tl i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared_loop_loop t tl i0 + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop]: forward function *) -let list_nth_shared_loop_fwd (t : Type0) (ls : list_t t) (i : u32) : result t = - list_nth_shared_loop_loop_fwd t ls i +let list_nth_shared_loop (t : Type0) (ls : list_t t) (i : u32) : result t = + list_nth_shared_loop_loop t ls i (** [loops::get_elem_mut]: loop 0: forward function *) -let rec get_elem_mut_loop_fwd +let rec get_elem_mut_loop (x : usize) (ls : list_t usize) : Tot (result usize) (decreases (get_elem_mut_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> if y = x then Return y else get_elem_mut_loop_fwd x tl - | ListNil -> Fail Failure + | List_Cons y tl -> if y = x then Return y else get_elem_mut_loop x tl + | List_Nil -> Fail Failure end (** [loops::get_elem_mut]: forward function *) -let get_elem_mut_fwd (slots : vec (list_t usize)) (x : usize) : result usize = - let* l = vec_index_mut_fwd (list_t usize) slots 0 in - get_elem_mut_loop_fwd x l +let get_elem_mut + (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = + let* l = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + get_elem_mut_loop x l (** [loops::get_elem_mut]: loop 0: backward function 0 *) let rec get_elem_mut_loop_back @@ -161,39 +167,48 @@ let rec get_elem_mut_loop_back Tot (result (list_t usize)) (decreases (get_elem_mut_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> + | List_Cons y tl -> if y = x - then Return (ListCons ret tl) - else let* tl0 = get_elem_mut_loop_back x tl ret in Return (ListCons y tl0) - | ListNil -> Fail Failure + then Return (List_Cons ret tl) + else let* tl0 = get_elem_mut_loop_back x tl ret in Return (List_Cons y tl0) + | List_Nil -> Fail Failure end (** [loops::get_elem_mut]: backward function 0 *) let get_elem_mut_back - (slots : vec (list_t usize)) (x : usize) (ret : usize) : - result (vec (list_t usize)) + (slots : alloc_vec_Vec (list_t usize)) (x : usize) (ret : usize) : + result (alloc_vec_Vec (list_t usize)) = - let* l = vec_index_mut_fwd (list_t usize) slots 0 in + let* l = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in let* l0 = get_elem_mut_loop_back x l ret in - vec_index_mut_back (list_t usize) slots 0 l0 + alloc_vec_Vec_index_mut_back (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) slots + 0 l0 (** [loops::get_elem_shared]: loop 0: forward function *) -let rec get_elem_shared_loop_fwd +let rec get_elem_shared_loop (x : usize) (ls : list_t usize) : Tot (result usize) (decreases (get_elem_shared_loop_decreases x ls)) = begin match ls with - | ListCons y tl -> if y = x then Return y else get_elem_shared_loop_fwd x tl - | ListNil -> Fail Failure + | List_Cons y tl -> if y = x then Return y else get_elem_shared_loop x tl + | List_Nil -> Fail Failure end (** [loops::get_elem_shared]: forward function *) -let get_elem_shared_fwd - (slots : vec (list_t usize)) (x : usize) : result usize = - let* l = vec_index_fwd (list_t usize) slots 0 in get_elem_shared_loop_fwd x l +let get_elem_shared + (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = + let* l = + alloc_vec_Vec_index (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + get_elem_shared_loop x l (** [loops::id_mut]: forward function *) -let id_mut_fwd (t : Type0) (ls : list_t t) : result (list_t t) = +let id_mut (t : Type0) (ls : list_t t) : result (list_t t) = Return ls (** [loops::id_mut]: backward function 0 *) @@ -202,26 +217,26 @@ let id_mut_back Return ret (** [loops::id_shared]: forward function *) -let id_shared_fwd (t : Type0) (ls : list_t t) : result (list_t t) = +let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = Return ls (** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) -let rec list_nth_mut_loop_with_id_loop_fwd +let rec list_nth_mut_loop_with_id_loop (t : Type0) (i : u32) (ls : list_t t) : Tot (result t) (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_loop_with_id_loop_fwd t i0 tl - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_mut_loop_with_id_loop t i0 tl + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_with_id]: forward function *) -let list_nth_mut_loop_with_id_fwd +let list_nth_mut_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls0 = id_mut_fwd t ls in list_nth_mut_loop_with_id_loop_fwd t i ls0 + let* ls0 = id_mut t ls in list_nth_mut_loop_with_id_loop t i ls0 (** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) let rec list_nth_mut_loop_with_id_loop_back @@ -230,66 +245,64 @@ let rec list_nth_mut_loop_with_id_loop_back (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_loop_with_id_loop_back t i0 tl ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_with_id]: backward function 0 *) let list_nth_mut_loop_with_id_back (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = - let* ls0 = id_mut_fwd t ls in + let* ls0 = id_mut t ls in let* l = list_nth_mut_loop_with_id_loop_back t i ls0 ret in id_mut_back t ls l (** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) -let rec list_nth_shared_loop_with_id_loop_fwd +let rec list_nth_shared_loop_with_id_loop (t : Type0) (i : u32) (ls : list_t t) : Tot (result t) (decreases (list_nth_shared_loop_with_id_loop_decreases t i ls)) = begin match ls with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_loop_with_id_loop_fwd t i0 tl - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared_loop_with_id_loop t i0 tl + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop_with_id]: forward function *) -let list_nth_shared_loop_with_id_fwd +let list_nth_shared_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls0 = id_shared_fwd t ls in - list_nth_shared_loop_with_id_loop_fwd t i ls0 + let* ls0 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls0 (** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) -let rec list_nth_mut_loop_pair_loop_fwd +let rec list_nth_mut_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) - else - let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair]: forward function *) -let list_nth_mut_loop_pair_fwd +let list_nth_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_loop_pair_loop_fwd t ls0 ls1 i + list_nth_mut_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) let rec list_nth_mut_loop_pair_loop_back'a @@ -298,18 +311,18 @@ let rec list_nth_mut_loop_pair_loop_back'a (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else let* i0 = u32_sub i 1 in let* tl00 = list_nth_mut_loop_pair_loop_back'a t tl0 tl1 i0 ret in - Return (ListCons x0 tl00) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair]: backward function 0 *) @@ -326,18 +339,18 @@ let rec list_nth_mut_loop_pair_loop_back'b (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else let* i0 = u32_sub i 1 in let* tl10 = list_nth_mut_loop_pair_loop_back'b t tl0 tl1 i0 ret in - Return (ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair]: backward function 1 *) @@ -348,54 +361,51 @@ let list_nth_mut_loop_pair_back'b list_nth_mut_loop_pair_loop_back'b t ls0 ls1 i ret (** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) -let rec list_nth_shared_loop_pair_loop_fwd +let rec list_nth_shared_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_shared_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop_pair]: forward function *) -let list_nth_shared_loop_pair_fwd +let list_nth_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_loop_pair_loop_fwd t ls0 ls1 i + list_nth_shared_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_mut_loop_pair_merge_loop_fwd +let rec list_nth_mut_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else - let* i0 = u32_sub i 1 in - list_nth_mut_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair_merge]: forward function *) -let list_nth_mut_loop_pair_merge_fwd +let list_nth_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_mut_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) let rec list_nth_mut_loop_pair_merge_loop_back @@ -404,19 +414,19 @@ let rec list_nth_mut_loop_pair_merge_loop_back (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then let (x, x2) = ret in Return (ListCons x tl0, ListCons x2 tl1) + then let (x, x2) = ret in Return (List_Cons x tl0, List_Cons x2 tl1) else let* i0 = u32_sub i 1 in let* (tl00, tl10) = list_nth_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (ListCons x0 tl00, ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00, List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_loop_pair_merge]: backward function 0 *) @@ -427,54 +437,54 @@ let list_nth_mut_loop_pair_merge_back list_nth_mut_loop_pair_merge_loop_back t ls0 ls1 i ret (** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_shared_loop_pair_merge_loop_fwd +let rec list_nth_shared_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_shared_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_shared_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_loop_pair_merge]: forward function *) -let list_nth_shared_loop_pair_merge_fwd +let list_nth_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_shared_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) -let rec list_nth_mut_shared_loop_pair_loop_fwd +let rec list_nth_mut_shared_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_mut_shared_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_mut_shared_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair]: forward function *) -let list_nth_mut_shared_loop_pair_fwd +let list_nth_mut_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_shared_loop_pair_loop_fwd t ls0 ls1 i + list_nth_mut_shared_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) let rec list_nth_mut_shared_loop_pair_loop_back @@ -483,18 +493,18 @@ let rec list_nth_mut_shared_loop_pair_loop_back (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else let* i0 = u32_sub i 1 in let* tl00 = list_nth_mut_shared_loop_pair_loop_back t tl0 tl1 i0 ret in - Return (ListCons x0 tl00) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair]: backward function 0 *) @@ -505,29 +515,29 @@ let list_nth_mut_shared_loop_pair_back list_nth_mut_shared_loop_pair_loop_back t ls0 ls1 i ret (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_mut_shared_loop_pair_merge_loop_fwd +let rec list_nth_mut_shared_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_mut_shared_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_mut_shared_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) -let list_nth_mut_shared_loop_pair_merge_fwd +let list_nth_mut_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_shared_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) let rec list_nth_mut_shared_loop_pair_merge_loop_back @@ -536,19 +546,19 @@ let rec list_nth_mut_shared_loop_pair_merge_loop_back (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else let* i0 = u32_sub i 1 in let* tl00 = list_nth_mut_shared_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (ListCons x0 tl00) - | ListNil -> Fail Failure + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 *) @@ -559,29 +569,29 @@ let list_nth_mut_shared_loop_pair_merge_back list_nth_mut_shared_loop_pair_merge_loop_back t ls0 ls1 i ret (** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) -let rec list_nth_shared_mut_loop_pair_loop_fwd +let rec list_nth_shared_mut_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_shared_mut_loop_pair_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_shared_mut_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair]: forward function *) -let list_nth_shared_mut_loop_pair_fwd +let list_nth_shared_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_mut_loop_pair_loop_fwd t ls0 ls1 i + list_nth_shared_mut_loop_pair_loop t ls0 ls1 i (** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) let rec list_nth_shared_mut_loop_pair_loop_back @@ -590,18 +600,18 @@ let rec list_nth_shared_mut_loop_pair_loop_back (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else let* i0 = u32_sub i 1 in let* tl10 = list_nth_shared_mut_loop_pair_loop_back t tl0 tl1 i0 ret in - Return (ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair]: backward function 1 *) @@ -612,29 +622,29 @@ let list_nth_shared_mut_loop_pair_back list_nth_shared_mut_loop_pair_loop_back t ls0 ls1 i ret (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_shared_mut_loop_pair_merge_loop_fwd +let rec list_nth_shared_mut_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 then Return (x0, x1) else let* i0 = u32_sub i 1 in - list_nth_shared_mut_loop_pair_merge_loop_fwd t tl0 tl1 i0 - | ListNil -> Fail Failure + list_nth_shared_mut_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) -let list_nth_shared_mut_loop_pair_merge_fwd +let list_nth_shared_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_mut_loop_pair_merge_loop_fwd t ls0 ls1 i + list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) let rec list_nth_shared_mut_loop_pair_merge_loop_back @@ -643,19 +653,19 @@ let rec list_nth_shared_mut_loop_pair_merge_loop_back (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) = begin match ls0 with - | ListCons x0 tl0 -> + | List_Cons x0 tl0 -> begin match ls1 with - | ListCons x1 tl1 -> + | List_Cons x1 tl1 -> if i = 0 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else let* i0 = u32_sub i 1 in let* tl10 = list_nth_shared_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (ListCons x1 tl10) - | ListNil -> Fail Failure + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure end - | ListNil -> Fail Failure + | List_Nil -> Fail Failure end (** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 *) diff --git a/tests/fstar/misc/Loops.Types.fst b/tests/fstar/misc/Loops.Types.fst index 2e032fe7..c622c548 100644 --- a/tests/fstar/misc/Loops.Types.fst +++ b/tests/fstar/misc/Loops.Types.fst @@ -7,6 +7,6 @@ open Primitives (** [loops::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index 2cdd6e21..33142250 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -6,95 +6,95 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [no_nested_borrows::Pair] *) -type pair_t (t1 t2 : Type0) = { pair_x : t1; pair_y : t2; } +type pair_t (t1 t2 : Type0) = { x : t1; y : t2; } (** [no_nested_borrows::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t (** [no_nested_borrows::One] *) -type one_t (t1 : Type0) = | OneOne : t1 -> one_t t1 +type one_t (t1 : Type0) = | One_One : t1 -> one_t t1 (** [no_nested_borrows::EmptyEnum] *) -type empty_enum_t = | EmptyEnumEmpty : empty_enum_t +type emptyEnum_t = | EmptyEnum_Empty : emptyEnum_t (** [no_nested_borrows::Enum] *) -type enum_t = | EnumVariant1 : enum_t | EnumVariant2 : enum_t +type enum_t = | Enum_Variant1 : enum_t | Enum_Variant2 : enum_t (** [no_nested_borrows::EmptyStruct] *) -type empty_struct_t = unit +type emptyStruct_t = unit (** [no_nested_borrows::Sum] *) type sum_t (t1 t2 : Type0) = -| SumLeft : t1 -> sum_t t1 t2 -| SumRight : t2 -> sum_t t1 t2 +| Sum_Left : t1 -> sum_t t1 t2 +| Sum_Right : t2 -> sum_t t1 t2 (** [no_nested_borrows::neg_test]: forward function *) -let neg_test_fwd (x : i32) : result i32 = +let neg_test (x : i32) : result i32 = i32_neg x (** [no_nested_borrows::add_test]: forward function *) -let add_test_fwd (x : u32) (y : u32) : result u32 = +let add_test (x : u32) (y : u32) : result u32 = u32_add x y (** [no_nested_borrows::subs_test]: forward function *) -let subs_test_fwd (x : u32) (y : u32) : result u32 = +let subs_test (x : u32) (y : u32) : result u32 = u32_sub x y (** [no_nested_borrows::div_test]: forward function *) -let div_test_fwd (x : u32) (y : u32) : result u32 = +let div_test (x : u32) (y : u32) : result u32 = u32_div x y (** [no_nested_borrows::div_test1]: forward function *) -let div_test1_fwd (x : u32) : result u32 = +let div_test1 (x : u32) : result u32 = u32_div x 2 (** [no_nested_borrows::rem_test]: forward function *) -let rem_test_fwd (x : u32) (y : u32) : result u32 = +let rem_test (x : u32) (y : u32) : result u32 = u32_rem x y (** [no_nested_borrows::cast_test]: forward function *) -let cast_test_fwd (x : u32) : result i32 = +let cast_test (x : u32) : result i32 = scalar_cast U32 I32 x (** [no_nested_borrows::test2]: forward function *) -let test2_fwd : result unit = +let test2 : result unit = let* _ = u32_add 23 44 in Return () (** Unit test for [no_nested_borrows::test2] *) -let _ = assert_norm (test2_fwd = Return ()) +let _ = assert_norm (test2 = Return ()) (** [no_nested_borrows::get_max]: forward function *) -let get_max_fwd (x : u32) (y : u32) : result u32 = +let get_max (x : u32) (y : u32) : result u32 = if x >= y then Return x else Return y (** [no_nested_borrows::test3]: forward function *) -let test3_fwd : result unit = - let* x = get_max_fwd 4 3 in - let* y = get_max_fwd 10 11 in +let test3 : result unit = + let* x = get_max 4 3 in + let* y = get_max 10 11 in let* z = u32_add x y in if not (z = 15) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test3] *) -let _ = assert_norm (test3_fwd = Return ()) +let _ = assert_norm (test3 = Return ()) (** [no_nested_borrows::test_neg1]: forward function *) -let test_neg1_fwd : result unit = +let test_neg1 : result unit = let* y = i32_neg 3 in if not (y = -3) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_neg1] *) -let _ = assert_norm (test_neg1_fwd = Return ()) +let _ = assert_norm (test_neg1 = Return ()) (** [no_nested_borrows::refs_test1]: forward function *) -let refs_test1_fwd : result unit = +let refs_test1 : result unit = if not (1 = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::refs_test1] *) -let _ = assert_norm (refs_test1_fwd = Return ()) +let _ = assert_norm (refs_test1 = Return ()) (** [no_nested_borrows::refs_test2]: forward function *) -let refs_test2_fwd : result unit = +let refs_test2 : result unit = if not (2 = 2) then Fail Failure else @@ -106,76 +106,76 @@ let refs_test2_fwd : result unit = else if not (2 = 2) then Fail Failure else Return () (** Unit test for [no_nested_borrows::refs_test2] *) -let _ = assert_norm (refs_test2_fwd = Return ()) +let _ = assert_norm (refs_test2 = Return ()) (** [no_nested_borrows::test_list1]: forward function *) -let test_list1_fwd : result unit = +let test_list1 : result unit = Return () (** Unit test for [no_nested_borrows::test_list1] *) -let _ = assert_norm (test_list1_fwd = Return ()) +let _ = assert_norm (test_list1 = Return ()) (** [no_nested_borrows::test_box1]: forward function *) -let test_box1_fwd : result unit = +let test_box1 : result unit = let b = 1 in let x = b in if not (x = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_box1] *) -let _ = assert_norm (test_box1_fwd = Return ()) +let _ = assert_norm (test_box1 = Return ()) (** [no_nested_borrows::copy_int]: forward function *) -let copy_int_fwd (x : i32) : result i32 = +let copy_int (x : i32) : result i32 = Return x (** [no_nested_borrows::test_unreachable]: forward function *) -let test_unreachable_fwd (b : bool) : result unit = +let test_unreachable (b : bool) : result unit = if b then Fail Failure else Return () (** [no_nested_borrows::test_panic]: forward function *) -let test_panic_fwd (b : bool) : result unit = +let test_panic (b : bool) : result unit = if b then Fail Failure else Return () (** [no_nested_borrows::test_copy_int]: forward function *) -let test_copy_int_fwd : result unit = - let* y = copy_int_fwd 0 in if not (0 = y) then Fail Failure else Return () +let test_copy_int : result unit = + let* y = copy_int 0 in if not (0 = y) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_copy_int] *) -let _ = assert_norm (test_copy_int_fwd = Return ()) +let _ = assert_norm (test_copy_int = Return ()) (** [no_nested_borrows::is_cons]: forward function *) -let is_cons_fwd (t : Type0) (l : list_t t) : result bool = +let is_cons (t : Type0) (l : list_t t) : result bool = begin match l with - | ListCons x l0 -> Return true - | ListNil -> Return false + | List_Cons x l0 -> Return true + | List_Nil -> Return false end (** [no_nested_borrows::test_is_cons]: forward function *) -let test_is_cons_fwd : result unit = - let l = ListNil in - let* b = is_cons_fwd i32 (ListCons 0 l) in +let test_is_cons : result unit = + let l = List_Nil in + let* b = is_cons i32 (List_Cons 0 l) in if not b then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_is_cons] *) -let _ = assert_norm (test_is_cons_fwd = Return ()) +let _ = assert_norm (test_is_cons = Return ()) (** [no_nested_borrows::split_list]: forward function *) -let split_list_fwd (t : Type0) (l : list_t t) : result (t & (list_t t)) = +let split_list (t : Type0) (l : list_t t) : result (t & (list_t t)) = begin match l with - | ListCons hd tl -> Return (hd, tl) - | ListNil -> Fail Failure + | List_Cons hd tl -> Return (hd, tl) + | List_Nil -> Fail Failure end (** [no_nested_borrows::test_split_list]: forward function *) -let test_split_list_fwd : result unit = - let l = ListNil in - let* p = split_list_fwd i32 (ListCons 0 l) in +let test_split_list : result unit = + let l = List_Nil in + let* p = split_list i32 (List_Cons 0 l) in let (hd, _) = p in if not (hd = 0) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_split_list] *) -let _ = assert_norm (test_split_list_fwd = Return ()) +let _ = assert_norm (test_split_list = Return ()) (** [no_nested_borrows::choose]: forward function *) -let choose_fwd (t : Type0) (b : bool) (x : t) (y : t) : result t = +let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y (** [no_nested_borrows::choose]: backward function 0 *) @@ -184,8 +184,8 @@ let choose_back if b then Return (ret, y) else Return (x, ret) (** [no_nested_borrows::choose_test]: forward function *) -let choose_test_fwd : result unit = - let* z = choose_fwd i32 true 0 0 in +let choose_test : result unit = + let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in if not (z0 = 1) then Fail Failure @@ -196,115 +196,112 @@ let choose_test_fwd : result unit = else if not (y = 0) then Fail Failure else Return () (** Unit test for [no_nested_borrows::choose_test] *) -let _ = assert_norm (choose_test_fwd = Return ()) +let _ = assert_norm (choose_test = Return ()) (** [no_nested_borrows::test_char]: forward function *) -let test_char_fwd : result char = +let test_char : result char = Return 'a' (** [no_nested_borrows::Tree] *) type tree_t (t : Type0) = -| TreeLeaf : t -> tree_t t -| TreeNode : t -> node_elem_t t -> tree_t t -> tree_t t +| Tree_Leaf : t -> tree_t t +| Tree_Node : t -> nodeElem_t t -> tree_t t -> tree_t t (** [no_nested_borrows::NodeElem] *) -and node_elem_t (t : Type0) = -| NodeElemCons : tree_t t -> node_elem_t t -> node_elem_t t -| NodeElemNil : node_elem_t t +and nodeElem_t (t : Type0) = +| NodeElem_Cons : tree_t t -> nodeElem_t t -> nodeElem_t t +| NodeElem_Nil : nodeElem_t t (** [no_nested_borrows::list_length]: forward function *) -let rec list_length_fwd (t : Type0) (l : list_t t) : result u32 = +let rec list_length (t : Type0) (l : list_t t) : result u32 = begin match l with - | ListCons x l1 -> let* i = list_length_fwd t l1 in u32_add 1 i - | ListNil -> Return 0 + | List_Cons x l1 -> let* i = list_length t l1 in u32_add 1 i + | List_Nil -> Return 0 end (** [no_nested_borrows::list_nth_shared]: forward function *) -let rec list_nth_shared_fwd (t : Type0) (l : list_t t) (i : u32) : result t = +let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_fwd t tl i0 - | ListNil -> Fail Failure + else let* i0 = u32_sub i 1 in list_nth_shared t tl i0 + | List_Nil -> Fail Failure end (** [no_nested_borrows::list_nth_mut]: forward function *) -let rec list_nth_mut_fwd (t : Type0) (l : list_t t) (i : u32) : result t = +let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with - | ListCons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_fwd t tl i0 - | ListNil -> Fail Failure + | List_Cons x tl -> + if i = 0 then Return x else let* i0 = u32_sub i 1 in list_nth_mut t tl i0 + | List_Nil -> Fail Failure end (** [no_nested_borrows::list_nth_mut]: backward function 0 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_back t tl i0 ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [no_nested_borrows::list_rev_aux]: forward function *) -let rec list_rev_aux_fwd +let rec list_rev_aux (t : Type0) (li : list_t t) (lo : list_t t) : result (list_t t) = begin match li with - | ListCons hd tl -> list_rev_aux_fwd t tl (ListCons hd lo) - | ListNil -> Return lo + | List_Cons hd tl -> list_rev_aux t tl (List_Cons hd lo) + | List_Nil -> Return lo end (** [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let list_rev_fwd_back (t : Type0) (l : list_t t) : result (list_t t) = - let li = mem_replace_fwd (list_t t) l ListNil in - list_rev_aux_fwd t li ListNil +let list_rev (t : Type0) (l : list_t t) : result (list_t t) = + let li = core_mem_replace (list_t t) l List_Nil in list_rev_aux t li List_Nil (** [no_nested_borrows::test_list_functions]: forward function *) -let test_list_functions_fwd : result unit = - let l = ListNil in - let l0 = ListCons 2 l in - let l1 = ListCons 1 l0 in - let* i = list_length_fwd i32 (ListCons 0 l1) in +let test_list_functions : result unit = + let l = List_Nil in + let l0 = List_Cons 2 l in + let l1 = List_Cons 1 l0 in + let* i = list_length i32 (List_Cons 0 l1) in if not (i = 3) then Fail Failure else - let* i0 = list_nth_shared_fwd i32 (ListCons 0 l1) 0 in + let* i0 = list_nth_shared i32 (List_Cons 0 l1) 0 in if not (i0 = 0) then Fail Failure else - let* i1 = list_nth_shared_fwd i32 (ListCons 0 l1) 1 in + let* i1 = list_nth_shared i32 (List_Cons 0 l1) 1 in if not (i1 = 1) then Fail Failure else - let* i2 = list_nth_shared_fwd i32 (ListCons 0 l1) 2 in + let* i2 = list_nth_shared i32 (List_Cons 0 l1) 2 in if not (i2 = 2) then Fail Failure else - let* ls = list_nth_mut_back i32 (ListCons 0 l1) 1 3 in - let* i3 = list_nth_shared_fwd i32 ls 0 in + let* ls = list_nth_mut_back i32 (List_Cons 0 l1) 1 3 in + let* i3 = list_nth_shared i32 ls 0 in if not (i3 = 0) then Fail Failure else - let* i4 = list_nth_shared_fwd i32 ls 1 in + let* i4 = list_nth_shared i32 ls 1 in if not (i4 = 3) then Fail Failure else - let* i5 = list_nth_shared_fwd i32 ls 2 in + let* i5 = list_nth_shared i32 ls 2 in if not (i5 = 2) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_list_functions] *) -let _ = assert_norm (test_list_functions_fwd = Return ()) +let _ = assert_norm (test_list_functions = Return ()) (** [no_nested_borrows::id_mut_pair1]: forward function *) -let id_mut_pair1_fwd (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = +let id_mut_pair1 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) (** [no_nested_borrows::id_mut_pair1]: backward function 0 *) @@ -313,7 +310,7 @@ let id_mut_pair1_back let (x0, x1) = ret in Return (x0, x1) (** [no_nested_borrows::id_mut_pair2]: forward function *) -let id_mut_pair2_fwd (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = +let id_mut_pair2 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) (** [no_nested_borrows::id_mut_pair2]: backward function 0 *) @@ -322,7 +319,7 @@ let id_mut_pair2_back let (x, x0) = ret in Return (x, x0) (** [no_nested_borrows::id_mut_pair3]: forward function *) -let id_mut_pair3_fwd (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = +let id_mut_pair3 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) (** [no_nested_borrows::id_mut_pair3]: backward function 0 *) @@ -336,7 +333,7 @@ let id_mut_pair3_back'b Return ret (** [no_nested_borrows::id_mut_pair4]: forward function *) -let id_mut_pair4_fwd (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = +let id_mut_pair4 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) (** [no_nested_borrows::id_mut_pair4]: backward function 0 *) @@ -350,81 +347,76 @@ let id_mut_pair4_back'b Return ret (** [no_nested_borrows::StructWithTuple] *) -type struct_with_tuple_t (t1 t2 : Type0) = { struct_with_tuple_p : (t1 & t2); } +type structWithTuple_t (t1 t2 : Type0) = { p : (t1 & t2); } (** [no_nested_borrows::new_tuple1]: forward function *) -let new_tuple1_fwd : result (struct_with_tuple_t u32 u32) = - Return { struct_with_tuple_p = (1, 2) } +let new_tuple1 : result (structWithTuple_t u32 u32) = + Return { p = (1, 2) } (** [no_nested_borrows::new_tuple2]: forward function *) -let new_tuple2_fwd : result (struct_with_tuple_t i16 i16) = - Return { struct_with_tuple_p = (1, 2) } +let new_tuple2 : result (structWithTuple_t i16 i16) = + Return { p = (1, 2) } (** [no_nested_borrows::new_tuple3]: forward function *) -let new_tuple3_fwd : result (struct_with_tuple_t u64 i64) = - Return { struct_with_tuple_p = (1, 2) } +let new_tuple3 : result (structWithTuple_t u64 i64) = + Return { p = (1, 2) } (** [no_nested_borrows::StructWithPair] *) -type struct_with_pair_t (t1 t2 : Type0) = -{ - struct_with_pair_p : pair_t t1 t2; -} +type structWithPair_t (t1 t2 : Type0) = { p : pair_t t1 t2; } (** [no_nested_borrows::new_pair1]: forward function *) -let new_pair1_fwd : result (struct_with_pair_t u32 u32) = - Return { struct_with_pair_p = { pair_x = 1; pair_y = 2 } } +let new_pair1 : result (structWithPair_t u32 u32) = + Return { p = { x = 1; y = 2 } } (** [no_nested_borrows::test_constants]: forward function *) -let test_constants_fwd : result unit = - let* swt = new_tuple1_fwd in - let (i, _) = swt.struct_with_tuple_p in +let test_constants : result unit = + let* swt = new_tuple1 in + let (i, _) = swt.p in if not (i = 1) then Fail Failure else - let* swt0 = new_tuple2_fwd in - let (i0, _) = swt0.struct_with_tuple_p in + let* swt0 = new_tuple2 in + let (i0, _) = swt0.p in if not (i0 = 1) then Fail Failure else - let* swt1 = new_tuple3_fwd in - let (i1, _) = swt1.struct_with_tuple_p in + let* swt1 = new_tuple3 in + let (i1, _) = swt1.p in if not (i1 = 1) then Fail Failure else - let* swp = new_pair1_fwd in - if not (swp.struct_with_pair_p.pair_x = 1) - then Fail Failure - else Return () + let* swp = new_pair1 in + if not (swp.p.x = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_constants] *) -let _ = assert_norm (test_constants_fwd = Return ()) +let _ = assert_norm (test_constants = Return ()) (** [no_nested_borrows::test_weird_borrows1]: forward function *) -let test_weird_borrows1_fwd : result unit = +let test_weird_borrows1 : result unit = Return () (** Unit test for [no_nested_borrows::test_weird_borrows1] *) -let _ = assert_norm (test_weird_borrows1_fwd = Return ()) +let _ = assert_norm (test_weird_borrows1 = Return ()) (** [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let test_mem_replace_fwd_back (px : u32) : result u32 = - let y = mem_replace_fwd u32 px 1 in +let test_mem_replace (px : u32) : result u32 = + let y = core_mem_replace u32 px 1 in if not (y = 0) then Fail Failure else Return 2 (** [no_nested_borrows::test_shared_borrow_bool1]: forward function *) -let test_shared_borrow_bool1_fwd (b : bool) : result u32 = +let test_shared_borrow_bool1 (b : bool) : result u32 = if b then Return 0 else Return 1 (** [no_nested_borrows::test_shared_borrow_bool2]: forward function *) -let test_shared_borrow_bool2_fwd : result u32 = +let test_shared_borrow_bool2 : result u32 = Return 0 (** [no_nested_borrows::test_shared_borrow_enum1]: forward function *) -let test_shared_borrow_enum1_fwd (l : list_t u32) : result u32 = - begin match l with | ListCons i l0 -> Return 1 | ListNil -> Return 0 end +let test_shared_borrow_enum1 (l : list_t u32) : result u32 = + begin match l with | List_Cons i l0 -> Return 1 | List_Nil -> Return 0 end (** [no_nested_borrows::test_shared_borrow_enum2]: forward function *) -let test_shared_borrow_enum2_fwd : result u32 = +let test_shared_borrow_enum2 : result u32 = Return 0 diff --git a/tests/fstar/misc/Paper.fst b/tests/fstar/misc/Paper.fst index e2d692c2..bfb710dc 100644 --- a/tests/fstar/misc/Paper.fst +++ b/tests/fstar/misc/Paper.fst @@ -7,19 +7,18 @@ open Primitives (** [paper::ref_incr]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let ref_incr_fwd_back (x : i32) : result i32 = +let ref_incr (x : i32) : result i32 = i32_add x 1 (** [paper::test_incr]: forward function *) -let test_incr_fwd : result unit = - let* x = ref_incr_fwd_back 0 in - if not (x = 1) then Fail Failure else Return () +let test_incr : result unit = + let* x = ref_incr 0 in if not (x = 1) then Fail Failure else Return () (** Unit test for [paper::test_incr] *) -let _ = assert_norm (test_incr_fwd = Return ()) +let _ = assert_norm (test_incr = Return ()) (** [paper::choose]: forward function *) -let choose_fwd (t : Type0) (b : bool) (x : t) (y : t) : result t = +let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y (** [paper::choose]: backward function 0 *) @@ -28,8 +27,8 @@ let choose_back if b then Return (ret, y) else Return (x, ret) (** [paper::test_choose]: forward function *) -let test_choose_fwd : result unit = - let* z = choose_fwd i32 true 0 0 in +let test_choose : result unit = + let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in if not (z0 = 1) then Fail Failure @@ -40,62 +39,60 @@ let test_choose_fwd : result unit = else if not (y = 0) then Fail Failure else Return () (** Unit test for [paper::test_choose] *) -let _ = assert_norm (test_choose_fwd = Return ()) +let _ = assert_norm (test_choose = Return ()) (** [paper::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t (** [paper::list_nth_mut]: forward function *) -let rec list_nth_mut_fwd (t : Type0) (l : list_t t) (i : u32) : result t = +let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with - | ListCons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_fwd t tl i0 - | ListNil -> Fail Failure + | List_Cons x tl -> + if i = 0 then Return x else let* i0 = u32_sub i 1 in list_nth_mut t tl i0 + | List_Nil -> Fail Failure end (** [paper::list_nth_mut]: backward function 0 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with - | ListCons x tl -> + | List_Cons x tl -> if i = 0 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else let* i0 = u32_sub i 1 in let* tl0 = list_nth_mut_back t tl i0 ret in - Return (ListCons x tl0) - | ListNil -> Fail Failure + Return (List_Cons x tl0) + | List_Nil -> Fail Failure end (** [paper::sum]: forward function *) -let rec sum_fwd (l : list_t i32) : result i32 = +let rec sum (l : list_t i32) : result i32 = begin match l with - | ListCons x tl -> let* i = sum_fwd tl in i32_add x i - | ListNil -> Return 0 + | List_Cons x tl -> let* i = sum tl in i32_add x i + | List_Nil -> Return 0 end (** [paper::test_nth]: forward function *) -let test_nth_fwd : result unit = - let l = ListNil in - let l0 = ListCons 3 l in - let l1 = ListCons 2 l0 in - let* x = list_nth_mut_fwd i32 (ListCons 1 l1) 2 in +let test_nth : result unit = + let l = List_Nil in + let l0 = List_Cons 3 l in + let l1 = List_Cons 2 l0 in + let* x = list_nth_mut i32 (List_Cons 1 l1) 2 in let* x0 = i32_add x 1 in - let* l2 = list_nth_mut_back i32 (ListCons 1 l1) 2 x0 in - let* i = sum_fwd l2 in + let* l2 = list_nth_mut_back i32 (List_Cons 1 l1) 2 x0 in + let* i = sum l2 in if not (i = 7) then Fail Failure else Return () (** Unit test for [paper::test_nth] *) -let _ = assert_norm (test_nth_fwd = Return ()) +let _ = assert_norm (test_nth = Return ()) (** [paper::call_choose]: forward function *) -let call_choose_fwd (p : (u32 & u32)) : result u32 = +let call_choose (p : (u32 & u32)) : result u32 = let (px, py) = p in - let* pz = choose_fwd u32 true px py in + let* pz = choose u32 true px py in let* pz0 = u32_add pz 1 in let* (px0, _) = choose_back u32 true px py pz0 in Return px0 diff --git a/tests/fstar/misc/PoloniusList.fst b/tests/fstar/misc/PoloniusList.fst index 79c86606..428c4210 100644 --- a/tests/fstar/misc/PoloniusList.fst +++ b/tests/fstar/misc/PoloniusList.fst @@ -7,25 +7,25 @@ open Primitives (** [polonius_list::List] *) type list_t (t : Type0) = -| ListCons : t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t (** [polonius_list::get_list_at_x]: forward function *) -let rec get_list_at_x_fwd (ls : list_t u32) (x : u32) : result (list_t u32) = +let rec get_list_at_x (ls : list_t u32) (x : u32) : result (list_t u32) = begin match ls with - | ListCons hd tl -> - if hd = x then Return (ListCons hd tl) else get_list_at_x_fwd tl x - | ListNil -> Return ListNil + | List_Cons hd tl -> + if hd = x then Return (List_Cons hd tl) else get_list_at_x tl x + | List_Nil -> Return List_Nil end (** [polonius_list::get_list_at_x]: backward function 0 *) let rec get_list_at_x_back (ls : list_t u32) (x : u32) (ret : list_t u32) : result (list_t u32) = begin match ls with - | ListCons hd tl -> + | List_Cons hd tl -> if hd = x then Return ret - else let* tl0 = get_list_at_x_back tl x ret in Return (ListCons hd tl0) - | ListNil -> Return ret + else let* tl0 = get_list_at_x_back tl x ret in Return (List_Cons hd tl0) + | List_Nil -> Return ret end diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index 5e154122..71d75c11 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -55,8 +55,8 @@ type string = string let is_zero (n: nat) : bool = n = 0 let decrease (n: nat{n > 0}) : nat = n - 1 -let std_mem_replace (a : Type0) (x : a) (y : a) : a = x -let std_mem_replace_back (a : Type0) (x : a) (y : a) : a = y +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y // We don't really use raw pointers for now type mut_raw_ptr (t : Type0) = { v : t } @@ -426,6 +426,13 @@ type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + // The **forward** function shouldn't be used let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : @@ -694,3 +701,13 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) index_mut = alloc_vec_Vec_index_mut t idx inst; index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; } + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/lean/Constants.lean b/tests/lean/Constants.lean index 2603cbbf..bd3a07b7 100644 --- a/tests/lean/Constants.lean +++ b/tests/lean/Constants.lean @@ -56,11 +56,11 @@ def p3_c : Pair U32 U32 := eval_global p3_body (by simp) /- [constants::Wrap] -/ structure Wrap (T : Type) where - val : T + value : T /- [constants::Wrap::{0}::new]: forward function -/ -def Wrap.new (T : Type) (val : T) : Result (Wrap T) := - Result.ret { val := val } +def Wrap.new (T : Type) (value : T) : Result (Wrap T) := + Result.ret { value := value } /- [constants::Y] -/ def y_body : Result (Wrap I32) := Wrap.new I32 2#i32 @@ -68,7 +68,7 @@ def y_c : Wrap I32 := eval_global y_body (by simp) /- [constants::unwrap_y]: forward function -/ def unwrap_y : Result I32 := - Result.ret y_c.val + Result.ret y_c.value /- [constants::YVAL] -/ def yval_body : Result I32 := unwrap_y -- 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 +- tests/fstar/hashmap/Hashmap.Clauses.Template.fst | 26 +- tests/fstar/hashmap/Hashmap.Clauses.fst | 24 +- tests/fstar/hashmap/Hashmap.Funs.fst | 492 +++++++++--------- tests/fstar/hashmap/Hashmap.Types.fst | 14 +- .../HashmapMain.Clauses.Template.fst | 38 +- .../fstar/hashmap_on_disk/HashmapMain.Clauses.fst | 32 +- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 569 +++++++++++---------- .../fstar/hashmap_on_disk/HashmapMain.Opaque.fsti | 8 +- tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti | 16 +- 10 files changed, 646 insertions(+), 602 deletions(-) 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 diff --git a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst index 640ae783..a1f81666 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst @@ -8,55 +8,55 @@ open Hashmap.Types (** [hashmap::HashMap::{0}::allocate_slots]: decreases clause *) unfold -let hash_map_allocate_slots_loop_decreases (t : Type0) (slots : vec (list_t t)) - (n : usize) : nat = +let hashMap_allocate_slots_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (list_t t)) (n : usize) : nat = admit () (** [hashmap::HashMap::{0}::clear]: decreases clause *) unfold -let hash_map_clear_loop_decreases (t : Type0) (slots : vec (list_t t)) +let hashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () (** [hashmap::HashMap::{0}::insert_in_list]: decreases clause *) unfold -let hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) - (value : t) (ls : list_t t) : nat = +let hashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) + (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::move_elements_from_list]: decreases clause *) unfold -let hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hash_map_t t) (ls : list_t t) : nat = +let hashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashMap_t t) (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::move_elements]: decreases clause *) unfold -let hash_map_move_elements_loop_decreases (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) (i : usize) : nat = +let hashMap_move_elements_loop_decreases (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () (** [hashmap::HashMap::{0}::contains_key_in_list]: decreases clause *) unfold -let hash_map_contains_key_in_list_loop_decreases (t : Type0) (key : usize) +let hashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::get_in_list]: decreases clause *) unfold -let hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) +let hashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () (** [hashmap::HashMap::{0}::get_mut_in_list]: decreases clause *) unfold -let hash_map_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) +let hashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) (key : usize) : nat = admit () (** [hashmap::HashMap::{0}::remove_from_list]: decreases clause *) unfold -let hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) +let hashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () diff --git a/tests/fstar/hashmap/Hashmap.Clauses.fst b/tests/fstar/hashmap/Hashmap.Clauses.fst index d8bb8d20..6c699d05 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.fst @@ -8,54 +8,54 @@ open Hashmap.Types (** [hashmap::HashMap::allocate_slots]: decreases clause *) unfold -let hash_map_allocate_slots_loop_decreases (t : Type0) (slots : vec (list_t t)) - (n : usize) : nat = n +let hashMap_allocate_slots_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (list_t t)) (n : usize) : nat = n (** [hashmap::HashMap::clear]: decreases clause *) unfold -let hash_map_clear_loop_decreases (t : Type0) (slots : vec (list_t t)) +let hashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::insert_in_list]: decreases clause *) unfold -let hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) +let hashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::move_elements_from_list]: decreases clause *) unfold -let hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hash_map_t t) (ls : list_t t) : list_t t = +let hashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashMap_t t) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::move_elements]: decreases clause *) unfold -let hash_map_move_elements_loop_decreases (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) (i : usize) : nat = +let hashMap_move_elements_loop_decreases (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::contains_key_in_list]: decreases clause *) unfold -let hash_map_contains_key_in_list_loop_decreases (t : Type0) (key : usize) +let hashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::get_in_list]: decreases clause *) unfold -let hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : +let hashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : list_t t = ls (** [hashmap::HashMap::get_mut_in_list]: decreases clause *) unfold -let hash_map_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) +let hashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) (key : usize) : list_t t = ls (** [hashmap::HashMap::remove_from_list]: decreases clause *) unfold -let hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) +let hashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : list_t t = ls diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index 40cd0477..0e31e364 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -8,456 +8,486 @@ include Hashmap.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap::hash_key]: forward function *) -let hash_key_fwd (k : usize) : result usize = +let hash_key (k : usize) : result usize = Return k (** [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -let rec hash_map_allocate_slots_loop_fwd - (t : Type0) (slots : vec (list_t t)) (n : usize) : - Tot (result (vec (list_t t))) - (decreases (hash_map_allocate_slots_loop_decreases t slots n)) +let rec hashMap_allocate_slots_loop + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : + Tot (result (alloc_vec_Vec (list_t t))) + (decreases (hashMap_allocate_slots_loop_decreases t slots n)) = if n > 0 then - let* slots0 = vec_push_back (list_t t) slots ListNil in + let* slots0 = alloc_vec_Vec_push (list_t t) slots List_Nil in let* n0 = usize_sub n 1 in - hash_map_allocate_slots_loop_fwd t slots0 n0 + hashMap_allocate_slots_loop t slots0 n0 else Return slots (** [hashmap::HashMap::{0}::allocate_slots]: forward function *) -let hash_map_allocate_slots_fwd - (t : Type0) (slots : vec (list_t t)) (n : usize) : result (vec (list_t t)) = - hash_map_allocate_slots_loop_fwd t slots n +let hashMap_allocate_slots + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : + result (alloc_vec_Vec (list_t t)) + = + hashMap_allocate_slots_loop t slots n (** [hashmap::HashMap::{0}::new_with_capacity]: forward function *) -let hash_map_new_with_capacity_fwd +let hashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (hash_map_t t) + result (hashMap_t t) = - let v = vec_new (list_t t) in - let* slots = hash_map_allocate_slots_fwd t v capacity in + let v = alloc_vec_Vec_new (list_t t) in + let* slots = hashMap_allocate_slots t v capacity in let* i = usize_mul capacity max_load_dividend in let* i0 = usize_div i max_load_divisor in Return { - hash_map_num_entries = 0; - hash_map_max_load_factor = (max_load_dividend, max_load_divisor); - hash_map_max_load = i0; - hash_map_slots = slots + num_entries = 0; + max_load_factor = (max_load_dividend, max_load_divisor); + max_load = i0; + slots = slots } (** [hashmap::HashMap::{0}::new]: forward function *) -let hash_map_new_fwd (t : Type0) : result (hash_map_t t) = - hash_map_new_with_capacity_fwd t 32 4 5 +let hashMap_new (t : Type0) : result (hashMap_t t) = + hashMap_new_with_capacity t 32 4 5 (** [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hash_map_clear_loop_fwd_back - (t : Type0) (slots : vec (list_t t)) (i : usize) : - Tot (result (vec (list_t t))) - (decreases (hash_map_clear_loop_decreases t slots i)) +let rec hashMap_clear_loop + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : + Tot (result (alloc_vec_Vec (list_t t))) + (decreases (hashMap_clear_loop_decreases t slots i)) = - let i0 = vec_len (list_t t) slots in + let i0 = alloc_vec_Vec_len (list_t t) slots in if i < i0 then let* i1 = usize_add i 1 in - let* slots0 = vec_index_mut_back (list_t t) slots i ListNil in - hash_map_clear_loop_fwd_back t slots0 i1 + let* slots0 = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots + i List_Nil in + hashMap_clear_loop t slots0 i1 else Return slots (** [hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_clear_fwd_back - (t : Type0) (self : hash_map_t t) : result (hash_map_t t) = - let* v = hash_map_clear_loop_fwd_back t self.hash_map_slots 0 in - Return { self with hash_map_num_entries = 0; hash_map_slots = v } +let hashMap_clear (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = + let* v = hashMap_clear_loop t self.slots 0 in + Return { self with num_entries = 0; slots = v } (** [hashmap::HashMap::{0}::len]: forward function *) -let hash_map_len_fwd (t : Type0) (self : hash_map_t t) : result usize = - Return self.hash_map_num_entries +let hashMap_len (t : Type0) (self : hashMap_t t) : result usize = + Return self.num_entries (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -let rec hash_map_insert_in_list_loop_fwd +let rec hashMap_insert_in_list_loop (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result bool) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | ListCons ckey cvalue tl -> + | List_Cons ckey cvalue tl -> if ckey = key then Return false - else hash_map_insert_in_list_loop_fwd t key value tl - | ListNil -> Return true + else hashMap_insert_in_list_loop t key value tl + | List_Nil -> Return true end (** [hashmap::HashMap::{0}::insert_in_list]: forward function *) -let hash_map_insert_in_list_fwd +let hashMap_insert_in_list (t : Type0) (key : usize) (value : t) (ls : list_t t) : result bool = - hash_map_insert_in_list_loop_fwd t key value ls + hashMap_insert_in_list_loop t key value ls (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -let rec hash_map_insert_in_list_loop_back +let rec hashMap_insert_in_list_loop_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result (list_t t)) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | ListCons ckey cvalue tl -> + | List_Cons ckey cvalue tl -> if ckey = key - then Return (ListCons ckey value tl) + then Return (List_Cons ckey value tl) else - let* tl0 = hash_map_insert_in_list_loop_back t key value tl in - Return (ListCons ckey cvalue tl0) - | ListNil -> let l = ListNil in Return (ListCons key value l) + let* tl0 = hashMap_insert_in_list_loop_back t key value tl in + Return (List_Cons ckey cvalue tl0) + | List_Nil -> let l = List_Nil in Return (List_Cons key value l) end (** [hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -let hash_map_insert_in_list_back +let hashMap_insert_in_list_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : result (list_t t) = - hash_map_insert_in_list_loop_back t key value ls + hashMap_insert_in_list_loop_back t key value ls (** [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_insert_no_resize_fwd_back - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - result (hash_map_t t) +let hashMap_insert_no_resize + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + result (hashMap_t t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* inserted = hash_map_insert_in_list_fwd t key value l in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* inserted = hashMap_insert_in_list t key value l in if inserted then - let* i0 = usize_add self.hash_map_num_entries 1 in - let* l0 = hash_map_insert_in_list_back t key value l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_num_entries = i0; hash_map_slots = v } + let* i0 = usize_add self.num_entries 1 in + let* l0 = hashMap_insert_in_list_back t key value l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } else - let* l0 = hash_map_insert_in_list_back t key value l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_slots = v } + let* l0 = hashMap_insert_in_list_back t key value l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hash_map_move_elements_from_list_loop_fwd_back - (t : Type0) (ntable : hash_map_t t) (ls : list_t t) : - Tot (result (hash_map_t t)) - (decreases (hash_map_move_elements_from_list_loop_decreases t ntable ls)) +let rec hashMap_move_elements_from_list_loop + (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : + Tot (result (hashMap_t t)) + (decreases (hashMap_move_elements_from_list_loop_decreases t ntable ls)) = begin match ls with - | ListCons k v tl -> - let* ntable0 = hash_map_insert_no_resize_fwd_back t ntable k v in - hash_map_move_elements_from_list_loop_fwd_back t ntable0 tl - | ListNil -> Return ntable + | List_Cons k v tl -> + let* ntable0 = hashMap_insert_no_resize t ntable k v in + hashMap_move_elements_from_list_loop t ntable0 tl + | List_Nil -> Return ntable end (** [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_move_elements_from_list_fwd_back - (t : Type0) (ntable : hash_map_t t) (ls : list_t t) : result (hash_map_t t) = - hash_map_move_elements_from_list_loop_fwd_back t ntable ls +let hashMap_move_elements_from_list + (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : result (hashMap_t t) = + hashMap_move_elements_from_list_loop t ntable ls (** [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hash_map_move_elements_loop_fwd_back - (t : Type0) (ntable : hash_map_t t) (slots : vec (list_t t)) (i : usize) : - Tot (result ((hash_map_t t) & (vec (list_t t)))) - (decreases (hash_map_move_elements_loop_decreases t ntable slots i)) +let rec hashMap_move_elements_loop + (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) + (i : usize) : + Tot (result ((hashMap_t t) & (alloc_vec_Vec (list_t t)))) + (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) = - let i0 = vec_len (list_t t) slots in + let i0 = alloc_vec_Vec_len (list_t t) slots in if i < i0 then - let* l = vec_index_mut_fwd (list_t t) slots i in - let ls = mem_replace_fwd (list_t t) l ListNil in - let* ntable0 = hash_map_move_elements_from_list_fwd_back t ntable ls in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots + i in + let ls = core_mem_replace (list_t t) l List_Nil in + let* ntable0 = hashMap_move_elements_from_list t ntable ls in let* i1 = usize_add i 1 in - let l0 = mem_replace_back (list_t t) l ListNil in - let* slots0 = vec_index_mut_back (list_t t) slots i l0 in - hash_map_move_elements_loop_fwd_back t ntable0 slots0 i1 + let l0 = core_mem_replace_back (list_t t) l List_Nil in + let* slots0 = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots + i l0 in + hashMap_move_elements_loop t ntable0 slots0 i1 else Return (ntable, slots) (** [hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_move_elements_fwd_back - (t : Type0) (ntable : hash_map_t t) (slots : vec (list_t t)) (i : usize) : - result ((hash_map_t t) & (vec (list_t t))) +let hashMap_move_elements + (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) + (i : usize) : + result ((hashMap_t t) & (alloc_vec_Vec (list_t t))) = - hash_map_move_elements_loop_fwd_back t ntable slots i + hashMap_move_elements_loop t ntable slots i (** [hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_try_resize_fwd_back - (t : Type0) (self : hash_map_t t) : result (hash_map_t t) = +let hashMap_try_resize + (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = let* max_usize = scalar_cast U32 Usize core_u32_max in - let capacity = vec_len (list_t t) self.hash_map_slots in + let capacity = alloc_vec_Vec_len (list_t t) self.slots in let* n1 = usize_div max_usize 2 in - let (i, i0) = self.hash_map_max_load_factor in + let (i, i0) = self.max_load_factor in let* i1 = usize_div n1 i in if capacity <= i1 then let* i2 = usize_mul capacity 2 in - let* ntable = hash_map_new_with_capacity_fwd t i2 i i0 in - let* (ntable0, _) = - hash_map_move_elements_fwd_back t ntable self.hash_map_slots 0 in + let* ntable = hashMap_new_with_capacity t i2 i i0 in + let* (ntable0, _) = hashMap_move_elements t ntable self.slots 0 in Return - { - ntable0 - with - hash_map_num_entries = self.hash_map_num_entries; - hash_map_max_load_factor = (i, i0) + { ntable0 with num_entries = self.num_entries; max_load_factor = (i, i0) } - else Return { self with hash_map_max_load_factor = (i, i0) } + else Return { self with max_load_factor = (i, i0) } (** [hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hash_map_insert_fwd_back - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - result (hash_map_t t) +let hashMap_insert + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + result (hashMap_t t) = - let* self0 = hash_map_insert_no_resize_fwd_back t self key value in - let* i = hash_map_len_fwd t self0 in - if i > self0.hash_map_max_load - then hash_map_try_resize_fwd_back t self0 - else Return self0 + let* self0 = hashMap_insert_no_resize t self key value in + let* i = hashMap_len t self0 in + if i > self0.max_load then hashMap_try_resize t self0 else Return self0 (** [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -let rec hash_map_contains_key_in_list_loop_fwd +let rec hashMap_contains_key_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result bool) - (decreases (hash_map_contains_key_in_list_loop_decreases t key ls)) + (decreases (hashMap_contains_key_in_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> if ckey = key then Return true - else hash_map_contains_key_in_list_loop_fwd t key tl - | ListNil -> Return false + else hashMap_contains_key_in_list_loop t key tl + | List_Nil -> Return false end (** [hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -let hash_map_contains_key_in_list_fwd +let hashMap_contains_key_in_list (t : Type0) (key : usize) (ls : list_t t) : result bool = - hash_map_contains_key_in_list_loop_fwd t key ls + hashMap_contains_key_in_list_loop t key ls (** [hashmap::HashMap::{0}::contains_key]: forward function *) -let hash_map_contains_key_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result bool = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_contains_key + (t : Type0) (self : hashMap_t t) (key : usize) : result bool = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_fwd (list_t t) self.hash_map_slots hash_mod in - hash_map_contains_key_in_list_fwd t key l + let* l = + alloc_vec_Vec_index (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + hashMap_contains_key_in_list t key l (** [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -let rec hash_map_get_in_list_loop_fwd +let rec hashMap_get_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : - Tot (result t) (decreases (hash_map_get_in_list_loop_decreases t key ls)) + Tot (result t) (decreases (hashMap_get_in_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey cvalue tl -> - if ckey = key - then Return cvalue - else hash_map_get_in_list_loop_fwd t key tl - | ListNil -> Fail Failure + | List_Cons ckey cvalue tl -> + if ckey = key then Return cvalue else hashMap_get_in_list_loop t key tl + | List_Nil -> Fail Failure end (** [hashmap::HashMap::{0}::get_in_list]: forward function *) -let hash_map_get_in_list_fwd - (t : Type0) (key : usize) (ls : list_t t) : result t = - hash_map_get_in_list_loop_fwd t key ls +let hashMap_get_in_list (t : Type0) (key : usize) (ls : list_t t) : result t = + hashMap_get_in_list_loop t key ls (** [hashmap::HashMap::{0}::get]: forward function *) -let hash_map_get_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result t = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_get (t : Type0) (self : hashMap_t t) (key : usize) : result t = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_fwd (list_t t) self.hash_map_slots hash_mod in - hash_map_get_in_list_fwd t key l + let* l = + alloc_vec_Vec_index (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + hashMap_get_in_list t key l (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -let rec hash_map_get_mut_in_list_loop_fwd +let rec hashMap_get_mut_in_list_loop (t : Type0) (ls : list_t t) (key : usize) : - Tot (result t) (decreases (hash_map_get_mut_in_list_loop_decreases t ls key)) + Tot (result t) (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | ListCons ckey cvalue tl -> - if ckey = key - then Return cvalue - else hash_map_get_mut_in_list_loop_fwd t tl key - | ListNil -> Fail Failure + | List_Cons ckey cvalue tl -> + if ckey = key then Return cvalue else hashMap_get_mut_in_list_loop t tl key + | List_Nil -> Fail Failure end (** [hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -let hash_map_get_mut_in_list_fwd +let hashMap_get_mut_in_list (t : Type0) (ls : list_t t) (key : usize) : result t = - hash_map_get_mut_in_list_loop_fwd t ls key + hashMap_get_mut_in_list_loop t ls key (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -let rec hash_map_get_mut_in_list_loop_back +let rec hashMap_get_mut_in_list_loop_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : Tot (result (list_t t)) - (decreases (hash_map_get_mut_in_list_loop_decreases t ls key)) + (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | ListCons ckey cvalue tl -> + | List_Cons ckey cvalue tl -> if ckey = key - then Return (ListCons ckey ret tl) + then Return (List_Cons ckey ret tl) else - let* tl0 = hash_map_get_mut_in_list_loop_back t tl key ret in - Return (ListCons ckey cvalue tl0) - | ListNil -> Fail Failure + let* tl0 = hashMap_get_mut_in_list_loop_back t tl key ret in + Return (List_Cons ckey cvalue tl0) + | List_Nil -> Fail Failure end (** [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -let hash_map_get_mut_in_list_back +let hashMap_get_mut_in_list_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : result (list_t t) = - hash_map_get_mut_in_list_loop_back t ls key ret + hashMap_get_mut_in_list_loop_back t ls key ret (** [hashmap::HashMap::{0}::get_mut]: forward function *) -let hash_map_get_mut_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result t = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_get_mut (t : Type0) (self : hashMap_t t) (key : usize) : result t = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - hash_map_get_mut_in_list_fwd t l key + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + hashMap_get_mut_in_list t l key (** [hashmap::HashMap::{0}::get_mut]: backward function 0 *) -let hash_map_get_mut_back - (t : Type0) (self : hash_map_t t) (key : usize) (ret : t) : - result (hash_map_t t) +let hashMap_get_mut_back + (t : Type0) (self : hashMap_t t) (key : usize) (ret : t) : + result (hashMap_t t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* l0 = hash_map_get_mut_in_list_back t l key ret in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_slots = v } + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* l0 = hashMap_get_mut_in_list_back t l key ret in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -let rec hash_map_remove_from_list_loop_fwd +let rec hashMap_remove_from_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result (option t)) - (decreases (hash_map_remove_from_list_loop_decreases t key ls)) + (decreases (hashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> if ckey = key then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> Return (Some cvalue) - | ListNil -> Fail Failure + | List_Cons i cvalue tl0 -> Return (Some cvalue) + | List_Nil -> Fail Failure end - else hash_map_remove_from_list_loop_fwd t key tl - | ListNil -> Return None + else hashMap_remove_from_list_loop t key tl + | List_Nil -> Return None end (** [hashmap::HashMap::{0}::remove_from_list]: forward function *) -let hash_map_remove_from_list_fwd +let hashMap_remove_from_list (t : Type0) (key : usize) (ls : list_t t) : result (option t) = - hash_map_remove_from_list_loop_fwd t key ls + hashMap_remove_from_list_loop t key ls (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -let rec hash_map_remove_from_list_loop_back +let rec hashMap_remove_from_list_loop_back (t : Type0) (key : usize) (ls : list_t t) : Tot (result (list_t t)) - (decreases (hash_map_remove_from_list_loop_decreases t key ls)) + (decreases (hashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> if ckey = key then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> Return tl0 - | ListNil -> Fail Failure + | List_Cons i cvalue tl0 -> Return tl0 + | List_Nil -> Fail Failure end else - let* tl0 = hash_map_remove_from_list_loop_back t key tl in - Return (ListCons ckey x tl0) - | ListNil -> Return ListNil + let* tl0 = hashMap_remove_from_list_loop_back t key tl in + Return (List_Cons ckey x tl0) + | List_Nil -> Return List_Nil end (** [hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -let hash_map_remove_from_list_back +let hashMap_remove_from_list_back (t : Type0) (key : usize) (ls : list_t t) : result (list_t t) = - hash_map_remove_from_list_loop_back t key ls + hashMap_remove_from_list_loop_back t key ls (** [hashmap::HashMap::{0}::remove]: forward function *) -let hash_map_remove_fwd - (t : Type0) (self : hash_map_t t) (key : usize) : result (option t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_remove + (t : Type0) (self : hashMap_t t) (key : usize) : result (option t) = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* x = hash_map_remove_from_list_fwd t key l in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* x = hashMap_remove_from_list t key l in begin match x with | None -> Return None - | Some x0 -> - let* _ = usize_sub self.hash_map_num_entries 1 in Return (Some x0) + | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end (** [hashmap::HashMap::{0}::remove]: backward function 0 *) -let hash_map_remove_back - (t : Type0) (self : hash_map_t t) (key : usize) : result (hash_map_t t) = - let* hash = hash_key_fwd key in - let i = vec_len (list_t t) self.hash_map_slots in +let hashMap_remove_back + (t : Type0) (self : hashMap_t t) (key : usize) : result (hashMap_t t) = + let* hash = hash_key key in + let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in - let* l = vec_index_mut_fwd (list_t t) self.hash_map_slots hash_mod in - let* x = hash_map_remove_from_list_fwd t key l in + let* l = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod in + let* x = hashMap_remove_from_list t key l in begin match x with | None -> - let* l0 = hash_map_remove_from_list_back t key l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_slots = v } + let* l0 = hashMap_remove_from_list_back t key l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } | Some x0 -> - let* i0 = usize_sub self.hash_map_num_entries 1 in - let* l0 = hash_map_remove_from_list_back t key l in - let* v = vec_index_mut_back (list_t t) self.hash_map_slots hash_mod l0 in - Return { self with hash_map_num_entries = i0; hash_map_slots = v } + let* i0 = usize_sub self.num_entries 1 in + let* l0 = hashMap_remove_from_list_back t key l in + let* v = + alloc_vec_Vec_index_mut_back (list_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) + self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } end (** [hashmap::test1]: forward function *) -let test1_fwd : result unit = - let* hm = hash_map_new_fwd u64 in - let* hm0 = hash_map_insert_fwd_back u64 hm 0 42 in - let* hm1 = hash_map_insert_fwd_back u64 hm0 128 18 in - let* hm2 = hash_map_insert_fwd_back u64 hm1 1024 138 in - let* hm3 = hash_map_insert_fwd_back u64 hm2 1056 256 in - let* i = hash_map_get_fwd u64 hm3 128 in +let test1 : result unit = + let* hm = hashMap_new u64 in + let* hm0 = hashMap_insert u64 hm 0 42 in + let* hm1 = hashMap_insert u64 hm0 128 18 in + let* hm2 = hashMap_insert u64 hm1 1024 138 in + let* hm3 = hashMap_insert u64 hm2 1056 256 in + let* i = hashMap_get u64 hm3 128 in if not (i = 18) then Fail Failure else - let* hm4 = hash_map_get_mut_back u64 hm3 1024 56 in - let* i0 = hash_map_get_fwd u64 hm4 1024 in + let* hm4 = hashMap_get_mut_back u64 hm3 1024 56 in + let* i0 = hashMap_get u64 hm4 1024 in if not (i0 = 56) then Fail Failure else - let* x = hash_map_remove_fwd u64 hm4 1024 in + let* x = hashMap_remove u64 hm4 1024 in begin match x with | None -> Fail Failure | Some x0 -> if not (x0 = 56) then Fail Failure else - let* hm5 = hash_map_remove_back u64 hm4 1024 in - let* i1 = hash_map_get_fwd u64 hm5 0 in + let* hm5 = hashMap_remove_back u64 hm4 1024 in + let* i1 = hashMap_get u64 hm5 0 in if not (i1 = 42) then Fail Failure else - let* i2 = hash_map_get_fwd u64 hm5 128 in + let* i2 = hashMap_get u64 hm5 128 in if not (i2 = 18) then Fail Failure else - let* i3 = hash_map_get_fwd u64 hm5 1056 in + let* i3 = hashMap_get u64 hm5 1056 in if not (i3 = 256) then Fail Failure else Return () end -(** Unit test for [hashmap::test1] *) -let _ = assert_norm (test1_fwd = Return ()) - diff --git a/tests/fstar/hashmap/Hashmap.Types.fst b/tests/fstar/hashmap/Hashmap.Types.fst index 91ee26c6..753730fe 100644 --- a/tests/fstar/hashmap/Hashmap.Types.fst +++ b/tests/fstar/hashmap/Hashmap.Types.fst @@ -7,15 +7,15 @@ open Primitives (** [hashmap::List] *) type list_t (t : Type0) = -| ListCons : usize -> t -> list_t t -> list_t t -| ListNil : list_t t +| List_Cons : usize -> t -> list_t t -> list_t t +| List_Nil : list_t t (** [hashmap::HashMap] *) -type hash_map_t (t : Type0) = +type hashMap_t (t : Type0) = { - hash_map_num_entries : usize; - hash_map_max_load_factor : (usize & usize); - hash_map_max_load : usize; - hash_map_slots : vec (list_t t); + num_entries : usize; + max_load_factor : (usize & usize); + max_load : usize; + slots : alloc_vec_Vec (list_t t); } diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst index 615c670d..61885ac7 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst @@ -8,56 +8,56 @@ open HashmapMain.Types (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: decreases clause *) unfold -let hashmap_hash_map_allocate_slots_loop_decreases (t : Type0) - (slots : vec (hashmap_list_t t)) (n : usize) : nat = +let hashmap_HashMap_allocate_slots_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::clear]: decreases clause *) unfold -let hashmap_hash_map_clear_loop_decreases (t : Type0) - (slots : vec (hashmap_list_t t)) (i : usize) : nat = +let hashmap_HashMap_clear_loop_decreases (t : Type0) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: decreases clause *) unfold -let hashmap_hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) - (value : t) (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) + (value : t) (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: decreases clause *) unfold -let hashmap_hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: decreases clause *) unfold -let hashmap_hash_map_move_elements_loop_decreases (t : Type0) - (ntable : hashmap_hash_map_t t) (slots : vec (hashmap_list_t t)) (i : usize) - : nat = +let hashmap_HashMap_move_elements_loop_decreases (t : Type0) + (ntable : hashmap_HashMap_t t) (slots : alloc_vec_Vec (hashmap_List_t t)) + (i : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: decreases clause *) unfold -let hashmap_hash_map_contains_key_in_list_loop_decreases (t : Type0) - (key : usize) (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_contains_key_in_list_loop_decreases (t : Type0) + (key : usize) (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_get_in_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_mut_in_list_loop_decreases (t : Type0) - (ls : hashmap_list_t t) (key : usize) : nat = +let hashmap_HashMap_get_mut_in_list_loop_decreases (t : Type0) + (ls : hashmap_List_t t) (key : usize) : nat = admit () (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: decreases clause *) unfold -let hashmap_hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : nat = +let hashmap_HashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : nat = admit () diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst index 699ff3b2..be5a4ab1 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.fst @@ -8,54 +8,54 @@ open HashmapMain.Types (** [hashmap::HashMap::allocate_slots]: decreases clause *) unfold -let hashmap_hash_map_allocate_slots_loop_decreases (t : Type0) (slots : vec (hashmap_list_t t)) +let hashmap_HashMap_allocate_slots_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : nat = n (** [hashmap::HashMap::clear]: decreases clause *) unfold -let hashmap_hash_map_clear_loop_decreases (t : Type0) (slots : vec (hashmap_list_t t)) +let hashmap_HashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::insert_in_list]: decreases clause *) unfold -let hashmap_hash_map_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) - (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) + (ls : hashmap_List_t t) : hashmap_List_t t = ls (** [hashmap::HashMap::move_elements_from_list]: decreases clause *) unfold -let hashmap_hash_map_move_elements_from_list_loop_decreases (t : Type0) - (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_move_elements_from_list_loop_decreases (t : Type0) + (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : hashmap_List_t t = ls (** [hashmap::HashMap::move_elements]: decreases clause *) unfold -let hashmap_hash_map_move_elements_loop_decreases (t : Type0) (ntable : hashmap_hash_map_t t) - (slots : vec (hashmap_list_t t)) (i : usize) : nat = +let hashmap_HashMap_move_elements_loop_decreases (t : Type0) (ntable : hashmap_HashMap_t t) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = if i < length slots then length slots - i else 0 (** [hashmap::HashMap::contains_key_in_list]: decreases clause *) unfold -let hashmap_hash_map_contains_key_in_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : hashmap_List_t t = ls (** [hashmap::HashMap::get_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_list_t t) : - hashmap_list_t t = +let hashmap_HashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : + hashmap_List_t t = ls (** [hashmap::HashMap::get_mut_in_list]: decreases clause *) unfold -let hashmap_hash_map_get_mut_in_list_loop_decreases (t : Type0) - (ls : hashmap_list_t t) (key : usize) : hashmap_list_t t = +let hashmap_HashMap_get_mut_in_list_loop_decreases (t : Type0) + (ls : hashmap_List_t t) (key : usize) : hashmap_List_t t = ls (** [hashmap::HashMap::remove_from_list]: decreases clause *) unfold -let hashmap_hash_map_remove_from_list_loop_decreases (t : Type0) (key : usize) - (ls : hashmap_list_t t) : hashmap_list_t t = +let hashmap_HashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) + (ls : hashmap_List_t t) : hashmap_List_t t = ls diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 5af90bd8..5f227596 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -9,525 +9,528 @@ include HashmapMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap_main::hashmap::hash_key]: forward function *) -let hashmap_hash_key_fwd (k : usize) : result usize = +let hashmap_hash_key (k : usize) : result usize = Return k (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -let rec hashmap_hash_map_allocate_slots_loop_fwd - (t : Type0) (slots : vec (hashmap_list_t t)) (n : usize) : - Tot (result (vec (hashmap_list_t t))) - (decreases (hashmap_hash_map_allocate_slots_loop_decreases t slots n)) +let rec hashmap_HashMap_allocate_slots_loop + (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : + Tot (result (alloc_vec_Vec (hashmap_List_t t))) + (decreases (hashmap_HashMap_allocate_slots_loop_decreases t slots n)) = if n > 0 then - let* slots0 = vec_push_back (hashmap_list_t t) slots HashmapListNil in + let* slots0 = alloc_vec_Vec_push (hashmap_List_t t) slots Hashmap_List_Nil + in let* n0 = usize_sub n 1 in - hashmap_hash_map_allocate_slots_loop_fwd t slots0 n0 + hashmap_HashMap_allocate_slots_loop t slots0 n0 else Return slots (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function *) -let hashmap_hash_map_allocate_slots_fwd - (t : Type0) (slots : vec (hashmap_list_t t)) (n : usize) : - result (vec (hashmap_list_t t)) +let hashmap_HashMap_allocate_slots + (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : + result (alloc_vec_Vec (hashmap_List_t t)) = - hashmap_hash_map_allocate_slots_loop_fwd t slots n + hashmap_HashMap_allocate_slots_loop t slots n (** [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function *) -let hashmap_hash_map_new_with_capacity_fwd +let hashmap_HashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (hashmap_hash_map_t t) + result (hashmap_HashMap_t t) = - let v = vec_new (hashmap_list_t t) in - let* slots = hashmap_hash_map_allocate_slots_fwd t v capacity in + let v = alloc_vec_Vec_new (hashmap_List_t t) in + let* slots = hashmap_HashMap_allocate_slots t v capacity in let* i = usize_mul capacity max_load_dividend in let* i0 = usize_div i max_load_divisor in Return { - hashmap_hash_map_num_entries = 0; - hashmap_hash_map_max_load_factor = (max_load_dividend, max_load_divisor); - hashmap_hash_map_max_load = i0; - hashmap_hash_map_slots = slots + num_entries = 0; + max_load_factor = (max_load_dividend, max_load_divisor); + max_load = i0; + slots = slots } (** [hashmap_main::hashmap::HashMap::{0}::new]: forward function *) -let hashmap_hash_map_new_fwd (t : Type0) : result (hashmap_hash_map_t t) = - hashmap_hash_map_new_with_capacity_fwd t 32 4 5 +let hashmap_HashMap_new (t : Type0) : result (hashmap_HashMap_t t) = + hashmap_HashMap_new_with_capacity t 32 4 5 (** [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hashmap_hash_map_clear_loop_fwd_back - (t : Type0) (slots : vec (hashmap_list_t t)) (i : usize) : - Tot (result (vec (hashmap_list_t t))) - (decreases (hashmap_hash_map_clear_loop_decreases t slots i)) +let rec hashmap_HashMap_clear_loop + (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : + Tot (result (alloc_vec_Vec (hashmap_List_t t))) + (decreases (hashmap_HashMap_clear_loop_decreases t slots i)) = - let i0 = vec_len (hashmap_list_t t) slots in + let i0 = alloc_vec_Vec_len (hashmap_List_t t) slots in if i < i0 then let* i1 = usize_add i 1 in - let* slots0 = vec_index_mut_back (hashmap_list_t t) slots i HashmapListNil - in - hashmap_hash_map_clear_loop_fwd_back t slots0 i1 + let* slots0 = + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) slots i Hashmap_List_Nil in + hashmap_HashMap_clear_loop t slots0 i1 else Return slots (** [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_clear_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) : result (hashmap_hash_map_t t) = - let* v = hashmap_hash_map_clear_loop_fwd_back t self.hashmap_hash_map_slots 0 - in - Return - { self with hashmap_hash_map_num_entries = 0; hashmap_hash_map_slots = v } +let hashmap_HashMap_clear + (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = + let* v = hashmap_HashMap_clear_loop t self.slots 0 in + Return { self with num_entries = 0; slots = v } (** [hashmap_main::hashmap::HashMap::{0}::len]: forward function *) -let hashmap_hash_map_len_fwd - (t : Type0) (self : hashmap_hash_map_t t) : result usize = - Return self.hashmap_hash_map_num_entries +let hashmap_HashMap_len + (t : Type0) (self : hashmap_HashMap_t t) : result usize = + Return self.num_entries (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_insert_in_list_loop_fwd - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_insert_in_list_loop + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : Tot (result bool) - (decreases (hashmap_hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashmap_HashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key then Return false - else hashmap_hash_map_insert_in_list_loop_fwd t key value tl - | HashmapListNil -> Return true + else hashmap_HashMap_insert_in_list_loop t key value tl + | Hashmap_List_Nil -> Return true end (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function *) -let hashmap_hash_map_insert_in_list_fwd - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : result bool = - hashmap_hash_map_insert_in_list_loop_fwd t key value ls +let hashmap_HashMap_insert_in_list + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : result bool = + hashmap_HashMap_insert_in_list_loop t key value ls (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -let rec hashmap_hash_map_insert_in_list_loop_back - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : - Tot (result (hashmap_list_t t)) - (decreases (hashmap_hash_map_insert_in_list_loop_decreases t key value ls)) +let rec hashmap_HashMap_insert_in_list_loop_back + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : + Tot (result (hashmap_List_t t)) + (decreases (hashmap_HashMap_insert_in_list_loop_decreases t key value ls)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key - then Return (HashmapListCons ckey value tl) + then Return (Hashmap_List_Cons ckey value tl) else - let* tl0 = hashmap_hash_map_insert_in_list_loop_back t key value tl in - Return (HashmapListCons ckey cvalue tl0) - | HashmapListNil -> - let l = HashmapListNil in Return (HashmapListCons key value l) + let* tl0 = hashmap_HashMap_insert_in_list_loop_back t key value tl in + Return (Hashmap_List_Cons ckey cvalue tl0) + | Hashmap_List_Nil -> + let l = Hashmap_List_Nil in Return (Hashmap_List_Cons key value l) end (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -let hashmap_hash_map_insert_in_list_back - (t : Type0) (key : usize) (value : t) (ls : hashmap_list_t t) : - result (hashmap_list_t t) +let hashmap_HashMap_insert_in_list_back + (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : + result (hashmap_List_t t) = - hashmap_hash_map_insert_in_list_loop_back t key value ls + hashmap_HashMap_insert_in_list_loop_back t key value ls (** [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_insert_no_resize_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) (value : t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_insert_no_resize + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : + result (hashmap_HashMap_t t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* inserted = hashmap_hash_map_insert_in_list_fwd t key value l in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* inserted = hashmap_HashMap_insert_in_list t key value l in if inserted then - let* i0 = usize_add self.hashmap_hash_map_num_entries 1 in - let* l0 = hashmap_hash_map_insert_in_list_back t key value l in + let* i0 = usize_add self.num_entries 1 in + let* l0 = hashmap_HashMap_insert_in_list_back t key value l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return - { self with hashmap_hash_map_num_entries = i0; hashmap_hash_map_slots = v - } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } else - let* l0 = hashmap_hash_map_insert_in_list_back t key value l in + let* l0 = hashmap_HashMap_insert_in_list_back t key value l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return { self with hashmap_hash_map_slots = v } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hashmap_hash_map_move_elements_from_list_loop_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : - Tot (result (hashmap_hash_map_t t)) +let rec hashmap_HashMap_move_elements_from_list_loop + (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : + Tot (result (hashmap_HashMap_t t)) (decreases ( - hashmap_hash_map_move_elements_from_list_loop_decreases t ntable ls)) + hashmap_HashMap_move_elements_from_list_loop_decreases t ntable ls)) = begin match ls with - | HashmapListCons k v tl -> - let* ntable0 = hashmap_hash_map_insert_no_resize_fwd_back t ntable k v in - hashmap_hash_map_move_elements_from_list_loop_fwd_back t ntable0 tl - | HashmapListNil -> Return ntable + | Hashmap_List_Cons k v tl -> + let* ntable0 = hashmap_HashMap_insert_no_resize t ntable k v in + hashmap_HashMap_move_elements_from_list_loop t ntable0 tl + | Hashmap_List_Nil -> Return ntable end (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_move_elements_from_list_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (ls : hashmap_list_t t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_move_elements_from_list + (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : + result (hashmap_HashMap_t t) = - hashmap_hash_map_move_elements_from_list_loop_fwd_back t ntable ls + hashmap_HashMap_move_elements_from_list_loop t ntable ls (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec hashmap_hash_map_move_elements_loop_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (slots : vec (hashmap_list_t t)) - (i : usize) : - Tot (result ((hashmap_hash_map_t t) & (vec (hashmap_list_t t)))) - (decreases (hashmap_hash_map_move_elements_loop_decreases t ntable slots i)) +let rec hashmap_HashMap_move_elements_loop + (t : Type0) (ntable : hashmap_HashMap_t t) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : + Tot (result ((hashmap_HashMap_t t) & (alloc_vec_Vec (hashmap_List_t t)))) + (decreases (hashmap_HashMap_move_elements_loop_decreases t ntable slots i)) = - let i0 = vec_len (hashmap_list_t t) slots in + let i0 = alloc_vec_Vec_len (hashmap_List_t t) slots in if i < i0 then - let* l = vec_index_mut_fwd (hashmap_list_t t) slots i in - let ls = mem_replace_fwd (hashmap_list_t t) l HashmapListNil in - let* ntable0 = - hashmap_hash_map_move_elements_from_list_fwd_back t ntable ls in + let* l = + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) slots i in + let ls = core_mem_replace (hashmap_List_t t) l Hashmap_List_Nil in + let* ntable0 = hashmap_HashMap_move_elements_from_list t ntable ls in let* i1 = usize_add i 1 in - let l0 = mem_replace_back (hashmap_list_t t) l HashmapListNil in - let* slots0 = vec_index_mut_back (hashmap_list_t t) slots i l0 in - hashmap_hash_map_move_elements_loop_fwd_back t ntable0 slots0 i1 + let l0 = core_mem_replace_back (hashmap_List_t t) l Hashmap_List_Nil in + let* slots0 = + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) slots i l0 in + hashmap_HashMap_move_elements_loop t ntable0 slots0 i1 else Return (ntable, slots) (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_move_elements_fwd_back - (t : Type0) (ntable : hashmap_hash_map_t t) (slots : vec (hashmap_list_t t)) - (i : usize) : - result ((hashmap_hash_map_t t) & (vec (hashmap_list_t t))) +let hashmap_HashMap_move_elements + (t : Type0) (ntable : hashmap_HashMap_t t) + (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : + result ((hashmap_HashMap_t t) & (alloc_vec_Vec (hashmap_List_t t))) = - hashmap_hash_map_move_elements_loop_fwd_back t ntable slots i + hashmap_HashMap_move_elements_loop t ntable slots i (** [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_try_resize_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) : result (hashmap_hash_map_t t) = +let hashmap_HashMap_try_resize + (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = let* max_usize = scalar_cast U32 Usize core_u32_max in - let capacity = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let capacity = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* n1 = usize_div max_usize 2 in - let (i, i0) = self.hashmap_hash_map_max_load_factor in + let (i, i0) = self.max_load_factor in let* i1 = usize_div n1 i in if capacity <= i1 then let* i2 = usize_mul capacity 2 in - let* ntable = hashmap_hash_map_new_with_capacity_fwd t i2 i i0 in - let* (ntable0, _) = - hashmap_hash_map_move_elements_fwd_back t ntable - self.hashmap_hash_map_slots 0 in + let* ntable = hashmap_HashMap_new_with_capacity t i2 i i0 in + let* (ntable0, _) = hashmap_HashMap_move_elements t ntable self.slots 0 in Return - { - ntable0 - with - hashmap_hash_map_num_entries = self.hashmap_hash_map_num_entries; - hashmap_hash_map_max_load_factor = (i, i0) + { ntable0 with num_entries = self.num_entries; max_load_factor = (i, i0) } - else Return { self with hashmap_hash_map_max_load_factor = (i, i0) } + else Return { self with max_load_factor = (i, i0) } (** [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let hashmap_hash_map_insert_fwd_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) (value : t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_insert + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : + result (hashmap_HashMap_t t) = - let* self0 = hashmap_hash_map_insert_no_resize_fwd_back t self key value in - let* i = hashmap_hash_map_len_fwd t self0 in - if i > self0.hashmap_hash_map_max_load - then hashmap_hash_map_try_resize_fwd_back t self0 + let* self0 = hashmap_HashMap_insert_no_resize t self key value in + let* i = hashmap_HashMap_len t self0 in + if i > self0.max_load + then hashmap_HashMap_try_resize t self0 else Return self0 (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_contains_key_in_list_loop_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_contains_key_in_list_loop + (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result bool) - (decreases (hashmap_hash_map_contains_key_in_list_loop_decreases t key ls)) + (decreases (hashmap_HashMap_contains_key_in_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey x tl -> + | Hashmap_List_Cons ckey x tl -> if ckey = key then Return true - else hashmap_hash_map_contains_key_in_list_loop_fwd t key tl - | HashmapListNil -> Return false + else hashmap_HashMap_contains_key_in_list_loop t key tl + | Hashmap_List_Nil -> Return false end (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -let hashmap_hash_map_contains_key_in_list_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : result bool = - hashmap_hash_map_contains_key_in_list_loop_fwd t key ls +let hashmap_HashMap_contains_key_in_list + (t : Type0) (key : usize) (ls : hashmap_List_t t) : result bool = + hashmap_HashMap_contains_key_in_list_loop t key ls (** [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function *) -let hashmap_hash_map_contains_key_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result bool = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_contains_key + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result bool = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod in - hashmap_hash_map_contains_key_in_list_fwd t key l + alloc_vec_Vec_index (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + hashmap_HashMap_contains_key_in_list t key l (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_get_in_list_loop_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_get_in_list_loop + (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result t) - (decreases (hashmap_hash_map_get_in_list_loop_decreases t key ls)) + (decreases (hashmap_HashMap_get_in_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key then Return cvalue - else hashmap_hash_map_get_in_list_loop_fwd t key tl - | HashmapListNil -> Fail Failure + else hashmap_HashMap_get_in_list_loop t key tl + | Hashmap_List_Nil -> Fail Failure end (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function *) -let hashmap_hash_map_get_in_list_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : result t = - hashmap_hash_map_get_in_list_loop_fwd t key ls +let hashmap_HashMap_get_in_list + (t : Type0) (key : usize) (ls : hashmap_List_t t) : result t = + hashmap_HashMap_get_in_list_loop t key ls (** [hashmap_main::hashmap::HashMap::{0}::get]: forward function *) -let hashmap_hash_map_get_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result t = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_get + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod in - hashmap_hash_map_get_in_list_fwd t key l + alloc_vec_Vec_index (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + hashmap_HashMap_get_in_list t key l (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -let rec hashmap_hash_map_get_mut_in_list_loop_fwd - (t : Type0) (ls : hashmap_list_t t) (key : usize) : +let rec hashmap_HashMap_get_mut_in_list_loop + (t : Type0) (ls : hashmap_List_t t) (key : usize) : Tot (result t) - (decreases (hashmap_hash_map_get_mut_in_list_loop_decreases t ls key)) + (decreases (hashmap_HashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key then Return cvalue - else hashmap_hash_map_get_mut_in_list_loop_fwd t tl key - | HashmapListNil -> Fail Failure + else hashmap_HashMap_get_mut_in_list_loop t tl key + | Hashmap_List_Nil -> Fail Failure end (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -let hashmap_hash_map_get_mut_in_list_fwd - (t : Type0) (ls : hashmap_list_t t) (key : usize) : result t = - hashmap_hash_map_get_mut_in_list_loop_fwd t ls key +let hashmap_HashMap_get_mut_in_list + (t : Type0) (ls : hashmap_List_t t) (key : usize) : result t = + hashmap_HashMap_get_mut_in_list_loop t ls key (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -let rec hashmap_hash_map_get_mut_in_list_loop_back - (t : Type0) (ls : hashmap_list_t t) (key : usize) (ret : t) : - Tot (result (hashmap_list_t t)) - (decreases (hashmap_hash_map_get_mut_in_list_loop_decreases t ls key)) +let rec hashmap_HashMap_get_mut_in_list_loop_back + (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : + Tot (result (hashmap_List_t t)) + (decreases (hashmap_HashMap_get_mut_in_list_loop_decreases t ls key)) = begin match ls with - | HashmapListCons ckey cvalue tl -> + | Hashmap_List_Cons ckey cvalue tl -> if ckey = key - then Return (HashmapListCons ckey ret tl) + then Return (Hashmap_List_Cons ckey ret tl) else - let* tl0 = hashmap_hash_map_get_mut_in_list_loop_back t tl key ret in - Return (HashmapListCons ckey cvalue tl0) - | HashmapListNil -> Fail Failure + let* tl0 = hashmap_HashMap_get_mut_in_list_loop_back t tl key ret in + Return (Hashmap_List_Cons ckey cvalue tl0) + | Hashmap_List_Nil -> Fail Failure end (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -let hashmap_hash_map_get_mut_in_list_back - (t : Type0) (ls : hashmap_list_t t) (key : usize) (ret : t) : - result (hashmap_list_t t) +let hashmap_HashMap_get_mut_in_list_back + (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : + result (hashmap_List_t t) = - hashmap_hash_map_get_mut_in_list_loop_back t ls key ret + hashmap_HashMap_get_mut_in_list_loop_back t ls key ret (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function *) -let hashmap_hash_map_get_mut_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result t = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_get_mut + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - hashmap_hash_map_get_mut_in_list_fwd t l key + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + hashmap_HashMap_get_mut_in_list t l key (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 *) -let hashmap_hash_map_get_mut_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) (ret : t) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_get_mut_back + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (ret : t) : + result (hashmap_HashMap_t t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* l0 = hashmap_hash_map_get_mut_in_list_back t l key ret in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* l0 = hashmap_HashMap_get_mut_in_list_back t l key ret in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - l0 in - Return { self with hashmap_hash_map_slots = v } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod l0 in + Return { self with slots = v } (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -let rec hashmap_hash_map_remove_from_list_loop_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : +let rec hashmap_HashMap_remove_from_list_loop + (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result (option t)) - (decreases (hashmap_hash_map_remove_from_list_loop_decreases t key ls)) + (decreases (hashmap_HashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey x tl -> + | Hashmap_List_Cons ckey x tl -> if ckey = key then let mv_ls = - mem_replace_fwd (hashmap_list_t t) (HashmapListCons ckey x tl) - HashmapListNil in + core_mem_replace (hashmap_List_t t) (Hashmap_List_Cons ckey x tl) + Hashmap_List_Nil in begin match mv_ls with - | HashmapListCons i cvalue tl0 -> Return (Some cvalue) - | HashmapListNil -> Fail Failure + | Hashmap_List_Cons i cvalue tl0 -> Return (Some cvalue) + | Hashmap_List_Nil -> Fail Failure end - else hashmap_hash_map_remove_from_list_loop_fwd t key tl - | HashmapListNil -> Return None + else hashmap_HashMap_remove_from_list_loop t key tl + | Hashmap_List_Nil -> Return None end (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function *) -let hashmap_hash_map_remove_from_list_fwd - (t : Type0) (key : usize) (ls : hashmap_list_t t) : result (option t) = - hashmap_hash_map_remove_from_list_loop_fwd t key ls +let hashmap_HashMap_remove_from_list + (t : Type0) (key : usize) (ls : hashmap_List_t t) : result (option t) = + hashmap_HashMap_remove_from_list_loop t key ls (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -let rec hashmap_hash_map_remove_from_list_loop_back - (t : Type0) (key : usize) (ls : hashmap_list_t t) : - Tot (result (hashmap_list_t t)) - (decreases (hashmap_hash_map_remove_from_list_loop_decreases t key ls)) +let rec hashmap_HashMap_remove_from_list_loop_back + (t : Type0) (key : usize) (ls : hashmap_List_t t) : + Tot (result (hashmap_List_t t)) + (decreases (hashmap_HashMap_remove_from_list_loop_decreases t key ls)) = begin match ls with - | HashmapListCons ckey x tl -> + | Hashmap_List_Cons ckey x tl -> if ckey = key then let mv_ls = - mem_replace_fwd (hashmap_list_t t) (HashmapListCons ckey x tl) - HashmapListNil in + core_mem_replace (hashmap_List_t t) (Hashmap_List_Cons ckey x tl) + Hashmap_List_Nil in begin match mv_ls with - | HashmapListCons i cvalue tl0 -> Return tl0 - | HashmapListNil -> Fail Failure + | Hashmap_List_Cons i cvalue tl0 -> Return tl0 + | Hashmap_List_Nil -> Fail Failure end else - let* tl0 = hashmap_hash_map_remove_from_list_loop_back t key tl in - Return (HashmapListCons ckey x tl0) - | HashmapListNil -> Return HashmapListNil + let* tl0 = hashmap_HashMap_remove_from_list_loop_back t key tl in + Return (Hashmap_List_Cons ckey x tl0) + | Hashmap_List_Nil -> Return Hashmap_List_Nil end (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -let hashmap_hash_map_remove_from_list_back - (t : Type0) (key : usize) (ls : hashmap_list_t t) : - result (hashmap_list_t t) +let hashmap_HashMap_remove_from_list_back + (t : Type0) (key : usize) (ls : hashmap_List_t t) : + result (hashmap_List_t t) = - hashmap_hash_map_remove_from_list_loop_back t key ls + hashmap_HashMap_remove_from_list_loop_back t key ls (** [hashmap_main::hashmap::HashMap::{0}::remove]: forward function *) -let hashmap_hash_map_remove_fwd - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : result (option t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in +let hashmap_HashMap_remove + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result (option t) = + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* x = hashmap_hash_map_remove_from_list_fwd t key l in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* x = hashmap_HashMap_remove_from_list t key l in begin match x with | None -> Return None - | Some x0 -> - let* _ = usize_sub self.hashmap_hash_map_num_entries 1 in Return (Some x0) + | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end (** [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 *) -let hashmap_hash_map_remove_back - (t : Type0) (self : hashmap_hash_map_t t) (key : usize) : - result (hashmap_hash_map_t t) +let hashmap_HashMap_remove_back + (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : + result (hashmap_HashMap_t t) = - let* hash = hashmap_hash_key_fwd key in - let i = vec_len (hashmap_list_t t) self.hashmap_hash_map_slots in + let* hash = hashmap_hash_key key in + let i = alloc_vec_Vec_len (hashmap_List_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = - vec_index_mut_fwd (hashmap_list_t t) self.hashmap_hash_map_slots hash_mod - in - let* x = hashmap_hash_map_remove_from_list_fwd t key l in + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + self.slots hash_mod in + let* x = hashmap_HashMap_remove_from_list t key l in begin match x with | None -> - let* l0 = hashmap_hash_map_remove_from_list_back t key l in + let* l0 = hashmap_HashMap_remove_from_list_back t key l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return { self with hashmap_hash_map_slots = v } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with slots = v } | Some x0 -> - let* i0 = usize_sub self.hashmap_hash_map_num_entries 1 in - let* l0 = hashmap_hash_map_remove_from_list_back t key l in + let* i0 = usize_sub self.num_entries 1 in + let* l0 = hashmap_HashMap_remove_from_list_back t key l in let* v = - vec_index_mut_back (hashmap_list_t t) self.hashmap_hash_map_slots - hash_mod l0 in - Return - { self with hashmap_hash_map_num_entries = i0; hashmap_hash_map_slots = v - } + alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + t)) self.slots hash_mod l0 in + Return { self with num_entries = i0; slots = v } end (** [hashmap_main::hashmap::test1]: forward function *) -let hashmap_test1_fwd : result unit = - let* hm = hashmap_hash_map_new_fwd u64 in - let* hm0 = hashmap_hash_map_insert_fwd_back u64 hm 0 42 in - let* hm1 = hashmap_hash_map_insert_fwd_back u64 hm0 128 18 in - let* hm2 = hashmap_hash_map_insert_fwd_back u64 hm1 1024 138 in - let* hm3 = hashmap_hash_map_insert_fwd_back u64 hm2 1056 256 in - let* i = hashmap_hash_map_get_fwd u64 hm3 128 in +let hashmap_test1 : result unit = + let* hm = hashmap_HashMap_new u64 in + let* hm0 = hashmap_HashMap_insert u64 hm 0 42 in + let* hm1 = hashmap_HashMap_insert u64 hm0 128 18 in + let* hm2 = hashmap_HashMap_insert u64 hm1 1024 138 in + let* hm3 = hashmap_HashMap_insert u64 hm2 1056 256 in + let* i = hashmap_HashMap_get u64 hm3 128 in if not (i = 18) then Fail Failure else - let* hm4 = hashmap_hash_map_get_mut_back u64 hm3 1024 56 in - let* i0 = hashmap_hash_map_get_fwd u64 hm4 1024 in + let* hm4 = hashmap_HashMap_get_mut_back u64 hm3 1024 56 in + let* i0 = hashmap_HashMap_get u64 hm4 1024 in if not (i0 = 56) then Fail Failure else - let* x = hashmap_hash_map_remove_fwd u64 hm4 1024 in + let* x = hashmap_HashMap_remove u64 hm4 1024 in begin match x with | None -> Fail Failure | Some x0 -> if not (x0 = 56) then Fail Failure else - let* hm5 = hashmap_hash_map_remove_back u64 hm4 1024 in - let* i1 = hashmap_hash_map_get_fwd u64 hm5 0 in + let* hm5 = hashmap_HashMap_remove_back u64 hm4 1024 in + let* i1 = hashmap_HashMap_get u64 hm5 0 in if not (i1 = 42) then Fail Failure else - let* i2 = hashmap_hash_map_get_fwd u64 hm5 128 in + let* i2 = hashmap_HashMap_get u64 hm5 128 in if not (i2 = 18) then Fail Failure else - let* i3 = hashmap_hash_map_get_fwd u64 hm5 1056 in + let* i3 = hashmap_HashMap_get u64 hm5 1056 in if not (i3 = 256) then Fail Failure else Return () end -(** Unit test for [hashmap_main::hashmap::test1] *) -let _ = assert_norm (hashmap_test1_fwd = Return ()) - (** [hashmap_main::insert_on_disk]: forward function *) -let insert_on_disk_fwd +let insert_on_disk (key : usize) (value : u64) (st : state) : result (state & unit) = - let* (st0, hm) = hashmap_utils_deserialize_fwd st in - let* hm0 = hashmap_hash_map_insert_fwd_back u64 hm key value in - let* (st1, _) = hashmap_utils_serialize_fwd hm0 st0 in + let* (st0, hm) = hashmap_utils_deserialize st in + let* hm0 = hashmap_HashMap_insert u64 hm key value in + let* (st1, _) = hashmap_utils_serialize hm0 st0 in Return (st1, ()) (** [hashmap_main::main]: forward function *) -let main_fwd : result unit = +let main : result unit = Return () -(** Unit test for [hashmap_main::main] *) -let _ = assert_norm (main_fwd = Return ()) - diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti index 78a6c3ba..d6cecf36 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti @@ -7,10 +7,10 @@ include HashmapMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap_main::hashmap_utils::deserialize]: forward function *) -val hashmap_utils_deserialize_fwd - : state -> result (state & (hashmap_hash_map_t u64)) +val hashmap_utils_deserialize + : state -> result (state & (hashmap_HashMap_t u64)) (** [hashmap_main::hashmap_utils::serialize]: forward function *) -val hashmap_utils_serialize_fwd - : hashmap_hash_map_t u64 -> state -> result (state & unit) +val hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state & unit) diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti index e289174b..24b78c2a 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti @@ -6,17 +6,17 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [hashmap_main::hashmap::List] *) -type hashmap_list_t (t : Type0) = -| HashmapListCons : usize -> t -> hashmap_list_t t -> hashmap_list_t t -| HashmapListNil : hashmap_list_t t +type hashmap_List_t (t : Type0) = +| Hashmap_List_Cons : usize -> t -> hashmap_List_t t -> hashmap_List_t t +| Hashmap_List_Nil : hashmap_List_t t (** [hashmap_main::hashmap::HashMap] *) -type hashmap_hash_map_t (t : Type0) = +type hashmap_HashMap_t (t : Type0) = { - hashmap_hash_map_num_entries : usize; - hashmap_hash_map_max_load_factor : (usize & usize); - hashmap_hash_map_max_load : usize; - hashmap_hash_map_slots : vec (hashmap_list_t t); + num_entries : usize; + max_load_factor : (usize & usize); + max_load : usize; + slots : alloc_vec_Vec (hashmap_List_t t); } (** The state type used in the state-error monad *) -- cgit v1.2.3 From 67fb76ae5801fdb8f134394425e466dbe611a54b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 12:26:20 +0200 Subject: Regenerate more F* files --- tests/fstar/array/Array.Funs.fst | 4 +- tests/fstar/array/Array.Opaque.fsti | 24 + tests/fstar/array/Array.Types.fst | 2 +- tests/fstar/array/Primitives.fst | 4 +- tests/fstar/betree/BetreeMain.Clauses.Template.fst | 60 +- tests/fstar/betree/BetreeMain.Clauses.fst | 90 +- tests/fstar/betree/BetreeMain.Funs.fst | 1121 ++++++++-------- tests/fstar/betree/BetreeMain.Opaque.fsti | 18 +- tests/fstar/betree/BetreeMain.Types.fsti | 50 +- tests/fstar/betree/Primitives.fst | 4 +- .../BetreeMain.Clauses.Template.fst | 60 +- .../betree_back_stateful/BetreeMain.Clauses.fst | 90 +- .../fstar/betree_back_stateful/BetreeMain.Funs.fst | 1369 +++++++++----------- .../betree_back_stateful/BetreeMain.Opaque.fsti | 18 +- .../betree_back_stateful/BetreeMain.Types.fsti | 50 +- tests/fstar/betree_back_stateful/Primitives.fst | 4 +- tests/fstar/hashmap/Primitives.fst | 4 +- tests/fstar/hashmap_on_disk/Primitives.fst | 4 +- 18 files changed, 1427 insertions(+), 1549 deletions(-) create mode 100644 tests/fstar/array/Array.Opaque.fsti diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index a6808c98..8f0bfbbd 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -277,12 +277,12 @@ let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = let* _ = array_index_usize u32 2 x 0 in Return x (** [array::take_array_t]: forward function *) -let take_array_t (a : array ab_t 2) : result unit = +let take_array_t (a : array aB_t 2) : result unit = Return () (** [array::non_copyable_array]: forward function *) let non_copyable_array : result unit = - let* _ = take_array_t (mk_array ab_t 2 [ ABA; ABB ]) in Return () + let* _ = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) in Return () (** [array::sum]: loop 0: forward function *) let rec sum_loop diff --git a/tests/fstar/array/Array.Opaque.fsti b/tests/fstar/array/Array.Opaque.fsti new file mode 100644 index 00000000..484cb9ee --- /dev/null +++ b/tests/fstar/array/Array.Opaque.fsti @@ -0,0 +1,24 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [array]: external function declarations *) +module Array.Opaque +open Primitives +include Array.Types + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [core::array::[T; N]::{15}::index]: forward function *) +val core_array_[T; N]_index_fwd + (t i : Type0) (n : usize) (inst : core_ops_index_Index (slice t) i) : + array t n -> i -> result inst.core_ops_index_Index_Output + +(** [core::array::[T; N]::{16}::index_mut]: forward function *) +val core_array_[T; N]_index_mut_fwd + (t i : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) i) : + array t n -> i -> result inst.index_inst.core_ops_index_Index_Output + +(** [core::array::[T; N]::{16}::index_mut]: backward function 0 *) +val core_array_[T; N]_index_mut_back + (t i : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) i) : + array t n -> i -> inst.index_inst.core_ops_index_Index_Output -> result + (array t n) + diff --git a/tests/fstar/array/Array.Types.fst b/tests/fstar/array/Array.Types.fst index 0ec9c12f..4e8d5566 100644 --- a/tests/fstar/array/Array.Types.fst +++ b/tests/fstar/array/Array.Types.fst @@ -6,5 +6,5 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [array::AB] *) -type ab_t = | ABA : ab_t | ABB : ab_t +type aB_t = | AB_A : aB_t | AB_B : aB_t diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 3110b247..71d75c11 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -707,5 +707,7 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == - alloc_vec_Vec_update_usize v i x) = + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = admit() diff --git a/tests/fstar/betree/BetreeMain.Clauses.Template.fst b/tests/fstar/betree/BetreeMain.Clauses.Template.fst index 823df03a..8722f0bf 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.Template.fst @@ -8,95 +8,95 @@ open BetreeMain.Types (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : nat = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : nat = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: decreases clause *) unfold -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: decreases clause *) unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () diff --git a/tests/fstar/betree/BetreeMain.Clauses.fst b/tests/fstar/betree/BetreeMain.Clauses.fst index 07484711..cda7b920 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.fst @@ -8,8 +8,8 @@ open BetreeMain.Types (*** Well-founded relations *) (* We had a few issues when proving termination of the mutually recursive functions: - * - betree_internal_flush - * - betree_node_apply_messages + * - betree_Internal_flush + * - betree_Node_apply_messages * * The quantity which effectively decreases is: * (betree_size, messages_length) @@ -103,108 +103,108 @@ let wf_nat_pair_lem (p0 p1 : nat_pair) : (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : betree_list_t t = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : betree_List_t t = self (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = n (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : betree_list_t (u64 & t) = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : betree_List_t (u64 & t) = self (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) - (key : u64) (st : state) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) + (key : u64) (st : state) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) - (key : u64) (st : state) : betree_internal_t = +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) + (key : u64) (st : state) : betree_Internal_t = self (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) - (st : state) : betree_node_t = +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) + (st : state) : betree_Node_t = self (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (*** Decrease clauses - nat_pair *) /// The following decrease clauses use the [nat_pair] definition and the well-founded /// relation proven above. -let rec betree_size (bt : betree_node_t) : nat = +let rec betree_size (bt : betree_Node_t) : nat = match bt with - | BetreeNodeInternal node -> 1 + betree_internal_size node - | BetreeNodeLeaf _ -> 1 + | Betree_Node_Internal node -> 1 + betree_Internal_size node + | Betree_Node_Leaf _ -> 1 -and betree_internal_size (node : betree_internal_t) : nat = - 1 + betree_size node.betree_internal_left + betree_size node.betree_internal_right +and betree_Internal_size (node : betree_Internal_t) : nat = + 1 + betree_size node.left + betree_size node.right -let rec betree_list_len (#a : Type0) (ls : betree_list_t a) : nat = +let rec betree_List_len (#a : Type0) (ls : betree_List_t a) : nat = match ls with - | BetreeListCons _ tl -> 1 + betree_list_len tl - | BetreeListNil -> 0 + | Betree_List_Cons _ tl -> 1 + betree_List_len tl + | Betree_List_Nil -> 0 (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_internal_size self, 0|) +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_Internal_size self, 0|) (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_size self, betree_list_len msgs|) +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_size self, betree_List_len msgs|) diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index 2bb2352b..d2bf5c7c 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -9,35 +9,35 @@ include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::load_internal_node]: forward function *) -let betree_load_internal_node_fwd +let betree_load_internal_node (id : u64) (st : state) : - result (state & (betree_list_t (u64 & betree_message_t))) + result (state & (betree_List_t (u64 & betree_Message_t))) = - betree_utils_load_internal_node_fwd id st + betree_utils_load_internal_node id st (** [betree_main::betree::store_internal_node]: forward function *) -let betree_store_internal_node_fwd - (id : u64) (content : betree_list_t (u64 & betree_message_t)) (st : state) : +let betree_store_internal_node + (id : u64) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_internal_node_fwd id content st in + let* (st0, _) = betree_utils_store_internal_node id content st in Return (st0, ()) (** [betree_main::betree::load_leaf_node]: forward function *) -let betree_load_leaf_node_fwd - (id : u64) (st : state) : result (state & (betree_list_t (u64 & u64))) = - betree_utils_load_leaf_node_fwd id st +let betree_load_leaf_node + (id : u64) (st : state) : result (state & (betree_List_t (u64 & u64))) = + betree_utils_load_leaf_node id st (** [betree_main::betree::store_leaf_node]: forward function *) -let betree_store_leaf_node_fwd - (id : u64) (content : betree_list_t (u64 & u64)) (st : state) : +let betree_store_leaf_node + (id : u64) (content : betree_List_t (u64 & u64)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_leaf_node_fwd id content st in + let* (st0, _) = betree_utils_store_leaf_node id content st in Return (st0, ()) (** [betree_main::betree::fresh_node_id]: forward function *) -let betree_fresh_node_id_fwd (counter : u64) : result u64 = +let betree_fresh_node_id (counter : u64) : result u64 = let* _ = u64_add counter 1 in Return counter (** [betree_main::betree::fresh_node_id]: backward function 0 *) @@ -45,972 +45,909 @@ let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 (** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) -let betree_node_id_counter_new_fwd : result betree_node_id_counter_t = - Return { betree_node_id_counter_next_node_id = 0 } +let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = + Return { next_node_id = 0 } (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) -let betree_node_id_counter_fresh_id_fwd - (self : betree_node_id_counter_t) : result u64 = - let* _ = u64_add self.betree_node_id_counter_next_node_id 1 in - Return self.betree_node_id_counter_next_node_id +let betree_NodeIdCounter_fresh_id + (self : betree_NodeIdCounter_t) : result u64 = + let* _ = u64_add self.next_node_id 1 in Return self.next_node_id (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) -let betree_node_id_counter_fresh_id_back - (self : betree_node_id_counter_t) : result betree_node_id_counter_t = - let* i = u64_add self.betree_node_id_counter_next_node_id 1 in - Return { betree_node_id_counter_next_node_id = i } +let betree_NodeIdCounter_fresh_id_back + (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = + let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } (** [betree_main::betree::upsert_update]: forward function *) -let betree_upsert_update_fwd - (prev : option u64) (st : betree_upsert_fun_state_t) : result u64 = +let betree_upsert_update + (prev : option u64) (st : betree_UpsertFunState_t) : result u64 = begin match prev with | None -> begin match st with - | BetreeUpsertFunStateAdd v -> Return v - | BetreeUpsertFunStateSub i -> Return 0 + | Betree_UpsertFunState_Add v -> Return v + | Betree_UpsertFunState_Sub i -> Return 0 end | Some prev0 -> begin match st with - | BetreeUpsertFunStateAdd v -> + | Betree_UpsertFunState_Add v -> let* margin = u64_sub core_u64_max prev0 in if margin >= v then u64_add prev0 v else Return core_u64_max - | BetreeUpsertFunStateSub v -> + | Betree_UpsertFunState_Sub v -> if prev0 >= v then u64_sub prev0 v else Return 0 end end (** [betree_main::betree::List::{1}::len]: forward function *) -let rec betree_list_len_fwd - (t : Type0) (self : betree_list_t t) : - Tot (result u64) (decreases (betree_list_len_decreases t self)) +let rec betree_List_len + (t : Type0) (self : betree_List_t t) : + Tot (result u64) (decreases (betree_List_len_decreases t self)) = begin match self with - | BetreeListCons x tl -> let* i = betree_list_len_fwd t tl in u64_add 1 i - | BetreeListNil -> Return 0 + | Betree_List_Cons x tl -> let* i = betree_List_len t tl in u64_add 1 i + | Betree_List_Nil -> Return 0 end (** [betree_main::betree::List::{1}::split_at]: forward function *) -let rec betree_list_split_at_fwd - (t : Type0) (self : betree_list_t t) (n : u64) : - Tot (result ((betree_list_t t) & (betree_list_t t))) - (decreases (betree_list_split_at_decreases t self n)) +let rec betree_List_split_at + (t : Type0) (self : betree_List_t t) (n : u64) : + Tot (result ((betree_List_t t) & (betree_List_t t))) + (decreases (betree_List_split_at_decreases t self n)) = if n = 0 - then Return (BetreeListNil, self) + then Return (Betree_List_Nil, self) else begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let* i = u64_sub n 1 in - let* p = betree_list_split_at_fwd t tl i in + let* p = betree_List_split_at t tl i in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons hd l, ls1) - | BetreeListNil -> Fail Failure + Return (Betree_List_Cons hd l, ls1) + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_list_push_front_fwd_back - (t : Type0) (self : betree_list_t t) (x : t) : result (betree_list_t t) = - let tl = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_push_front + (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = + let tl = core_mem_replace (betree_List_t t) self Betree_List_Nil in let l = tl in - Return (BetreeListCons x l) + Return (Betree_List_Cons x l) (** [betree_main::betree::List::{1}::pop_front]: forward function *) -let betree_list_pop_front_fwd (t : Type0) (self : betree_list_t t) : result t = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return x - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return x + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) -let betree_list_pop_front_back - (t : Type0) (self : betree_list_t t) : result (betree_list_t t) = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front_back + (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return tl - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return tl + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::hd]: forward function *) -let betree_list_hd_fwd (t : Type0) (self : betree_list_t t) : result t = +let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with - | BetreeListCons hd l -> Return hd - | BetreeListNil -> Fail Failure + | Betree_List_Cons hd l -> Return hd + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{2}::head_has_key]: forward function *) -let betree_list_head_has_key_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (key : u64) : result bool = +let betree_List_head_has_key + (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with - | BetreeListCons hd l -> let (i, _) = hd in Return (i = key) - | BetreeListNil -> Return false + | Betree_List_Cons hd l -> let (i, _) = hd in Return (i = key) + | Betree_List_Nil -> Return false end (** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -let rec betree_list_partition_at_pivot_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (pivot : u64) : - Tot (result ((betree_list_t (u64 & t)) & (betree_list_t (u64 & t)))) - (decreases (betree_list_partition_at_pivot_decreases t self pivot)) +let rec betree_List_partition_at_pivot + (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : + Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) + (decreases (betree_List_partition_at_pivot_decreases t self pivot)) = begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, x) = hd in if i >= pivot - then Return (BetreeListNil, BetreeListCons (i, x) tl) + then Return (Betree_List_Nil, Betree_List_Cons (i, x) tl) else - let* p = betree_list_partition_at_pivot_fwd t tl pivot in + let* p = betree_List_partition_at_pivot t tl pivot in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons (i, x) l, ls1) - | BetreeListNil -> Return (BetreeListNil, BetreeListNil) + Return (Betree_List_Cons (i, x) l, ls1) + | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end (** [betree_main::betree::Leaf::{3}::split]: forward function *) -let betree_leaf_split_fwd - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result (state & betree_internal_t) + result (state & betree_Internal_t) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* p0 = betree_list_hd_fwd (u64 & u64) content1 in + let* p0 = betree_List_hd (u64 & u64) content1 in let (pivot, _) = p0 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st0, _) = betree_store_leaf_node_fwd id0 content0 st in - let* (st1, _) = betree_store_leaf_node_fwd id1 content1 st0 in - let n = BetreeNodeLeaf - { betree_leaf_id = id0; betree_leaf_size = params.betree_params_split_size - } in - let n0 = BetreeNodeLeaf - { betree_leaf_id = id1; betree_leaf_size = params.betree_params_split_size - } in - Return (st1, - { - betree_internal_id = self.betree_leaf_id; - betree_internal_pivot = pivot; - betree_internal_left = n; - betree_internal_right = n0 - }) + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st0, _) = betree_store_leaf_node id0 content0 st in + let* (st1, _) = betree_store_leaf_node id1 content1 st0 in + let n = Betree_Node_Leaf { id = id0; size = params.split_size } in + let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in + Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) (** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) -let betree_leaf_split_back - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result betree_node_id_counter_t + result betree_NodeIdCounter_t = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st0, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st0 in - betree_node_id_counter_fresh_id_back node_id_cnt0 + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st0, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st0 in + betree_NodeIdCounter_fresh_id_back node_id_cnt0 (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) -let rec betree_node_lookup_first_message_for_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key - then Return (BetreeListCons (i, m) next_msgs) - else betree_node_lookup_first_message_for_key_fwd key next_msgs - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, m) next_msgs) + else betree_Node_lookup_first_message_for_key key next_msgs + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) -let rec betree_node_lookup_first_message_for_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key then Return ret else let* next_msgs0 = - betree_node_lookup_first_message_for_key_back key next_msgs ret in - Return (BetreeListCons (i, m) next_msgs0) - | BetreeListNil -> Return ret + betree_Node_lookup_first_message_for_key_back key next_msgs ret in + Return (Betree_List_Cons (i, m) next_msgs0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) -let rec betree_node_apply_upserts_fwd - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (state & u64)) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_fwd msgs0 (Some v) key st + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts msgs0 (Some v) key st end else - let* (st0, v) = core_option_option_unwrap_fwd u64 prev st in + let* (st0, v) = core_option_Option_unwrap u64 prev st in let* _ = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) in Return (st0, v) (** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) -let rec betree_node_apply_upserts_back - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts_back + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_back msgs0 (Some v) key st + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts_back msgs0 (Some v) key st end else - let* (_, v) = core_option_option_unwrap_fwd u64 prev st in - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) + let* (_, v) = core_option_Option_unwrap u64 prev st in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) (** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) -let rec betree_node_lookup_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : +let rec betree_Node_lookup_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) - (decreases (betree_node_lookup_in_bindings_decreases key bindings)) + (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i = key then Return (Some i0) - else - if i > key - then Return None - else betree_node_lookup_in_bindings_fwd key tl - | BetreeListNil -> Return None + else if i > key then Return None else betree_Node_lookup_in_bindings key tl + | Betree_List_Nil -> Return None end (** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) -let rec betree_internal_lookup_in_children_fwd - (self : betree_internal_t) (key : u64) (st : state) : +let rec betree_Internal_lookup_in_children + (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_internal_lookup_in_children_decreases self key st)) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot - then betree_node_lookup_fwd self.betree_internal_left key st - else betree_node_lookup_fwd self.betree_internal_right key st + if key < self.pivot + then betree_Node_lookup self.left key st + else betree_Node_lookup self.right key st (** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) -and betree_internal_lookup_in_children_back - (self : betree_internal_t) (key : u64) (st : state) : - Tot (result betree_internal_t) - (decreases (betree_internal_lookup_in_children_decreases self key st)) +and betree_Internal_lookup_in_children_back + (self : betree_Internal_t) (key : u64) (st : state) : + Tot (result betree_Internal_t) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot + if key < self.pivot then - let* n = betree_node_lookup_back self.betree_internal_left key st in - Return { self with betree_internal_left = n } + let* n = betree_Node_lookup_back self.left key st in + Return { self with left = n } else - let* n = betree_node_lookup_back self.betree_internal_right key st in - Return { self with betree_internal_right = n } + let* n = betree_Node_lookup_back self.right key st in + Return { self with right = n } (** [betree_main::betree::Node::{5}::lookup]: forward function *) -and betree_node_lookup_fwd - (self : betree_node_t) (key : u64) (st : state) : +and betree_Node_lookup + (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_node_lookup_decreases self key st)) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st0, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 - in + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in + Return (st1, o) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in Return (st0, Some v) - | BetreeMessageDelete -> + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in Return (st0, None) - | BetreeMessageUpsert ufs -> - let* (st1, v) = betree_internal_lookup_in_children_fwd node key st0 - in + | Betree_Message_Upsert ufs -> + let* (st1, v) = betree_Internal_lookup_in_children node key st0 in let* (st2, v0) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in - let* node0 = betree_internal_lookup_in_children_back node key st0 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in let* pending0 = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* (st3, _) = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st2 - in + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* (st3, _) = betree_store_internal_node node0.id msgs0 st2 in Return (st3, Some v0) end - | BetreeListNil -> - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 in + | Betree_List_Nil -> + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in + Return (st1, o) end - | BetreeNodeLeaf node -> - let* (st0, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* opt = betree_node_lookup_in_bindings_fwd key bindings in - Return (st0, opt) + | Betree_Node_Leaf node -> + let* (st0, bindings) = betree_load_leaf_node node.id st in + let* o = betree_Node_lookup_in_bindings key bindings in + Return (st0, o) end (** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) -and betree_node_lookup_back - (self : betree_node_t) (key : u64) (st : state) : - Tot (result betree_node_t) - (decreases (betree_node_lookup_decreases self key st)) +and betree_Node_lookup_back + (self : betree_Node_t) (key : u64) (st : state) : + Tot (result betree_Node_t) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st0, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in - let* node0 = betree_internal_lookup_in_children_back node key st0 in - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in + Return (Betree_Node_Internal node0) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in - Return (BetreeNodeInternal node) - | BetreeMessageDelete -> + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in + Return (Betree_Node_Internal node) + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in - Return (BetreeNodeInternal node) - | BetreeMessageUpsert ufs -> - let* (st1, v) = betree_internal_lookup_in_children_fwd node key st0 - in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in + Return (Betree_Node_Internal node) + | Betree_Message_Upsert ufs -> + let* (st1, v) = betree_Internal_lookup_in_children node key st0 in let* (st2, _) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in - let* node0 = betree_internal_lookup_in_children_back node key st0 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in let* pending0 = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st2 - in - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* _ = betree_store_internal_node node0.id msgs0 st2 in + Return (Betree_Node_Internal node0) end - | BetreeListNil -> + | Betree_List_Nil -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in - let* node0 = betree_internal_lookup_in_children_back node key st0 in - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in + let* node0 = betree_Internal_lookup_in_children_back node key st0 in + Return (Betree_Node_Internal node0) end - | BetreeNodeLeaf node -> - let* (_, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* _ = betree_node_lookup_in_bindings_fwd key bindings in - Return (BetreeNodeLeaf node) + | Betree_Node_Leaf node -> + let* (_, bindings) = betree_load_leaf_node node.id st in + let* _ = betree_Node_lookup_in_bindings key bindings in + Return (Betree_Node_Leaf node) end (** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_filter_messages_for_key_fwd_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_filter_messages_for_key_decreases key msgs)) +let rec betree_Node_filter_messages_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_filter_messages_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, m) = p in if k = key then let* msgs0 = - betree_list_pop_front_back (u64 & betree_message_t) (BetreeListCons (k, - m) l) in - betree_node_filter_messages_for_key_fwd_back key msgs0 - else Return (BetreeListCons (k, m) l) - | BetreeListNil -> Return BetreeListNil + betree_List_pop_front_back (u64 & betree_Message_t) (Betree_List_Cons + (k, m) l) in + betree_Node_filter_messages_for_key key msgs0 + else Return (Betree_List_Cons (k, m) l) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) -let rec betree_node_lookup_first_message_after_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key - then betree_node_lookup_first_message_after_key_fwd key next_msgs - else Return (BetreeListCons (k, m) next_msgs) - | BetreeListNil -> Return BetreeListNil + then betree_Node_lookup_first_message_after_key key next_msgs + else Return (Betree_List_Cons (k, m) next_msgs) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) -let rec betree_node_lookup_first_message_after_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key then let* next_msgs0 = - betree_node_lookup_first_message_after_key_back key next_msgs ret in - Return (BetreeListCons (k, m) next_msgs0) + betree_Node_lookup_first_message_after_key_back key next_msgs ret in + Return (Betree_List_Cons (k, m) next_msgs0) else Return ret - | BetreeListNil -> Return ret + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & betree_message_t)) +let betree_Node_apply_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & betree_Message_t)) = - let* msgs0 = betree_node_lookup_first_message_for_key_fwd key msgs in - let* b = betree_list_head_has_key_fwd betree_message_t msgs0 key in + let* msgs0 = betree_Node_lookup_first_message_for_key key msgs in + let* b = betree_List_head_has_key betree_Message_t msgs0 key in if b then begin match new_msg with - | BetreeMessageInsert i -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + | Betree_Message_Insert i -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert i) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert i) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageDelete) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert s -> - let* p = betree_list_hd_fwd (u64 & betree_message_t) msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Delete) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert s -> + let* p = betree_List_hd (u64 & betree_Message_t) msgs0 in let (_, m) = p in begin match m with - | BetreeMessageInsert prev -> - let* v = betree_upsert_update_fwd (Some prev) s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + | Betree_Message_Insert prev -> + let* v = betree_upsert_update (Some prev) s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* v = betree_upsert_update_fwd None s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* v = betree_upsert_update None s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert ufs -> - let* msgs1 = betree_node_lookup_first_message_after_key_fwd key msgs0 - in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert ufs -> + let* msgs1 = betree_Node_lookup_first_message_after_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageUpsert s) in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Upsert s) in let* msgs3 = - betree_node_lookup_first_message_after_key_back key msgs0 msgs2 in - betree_node_lookup_first_message_for_key_back key msgs msgs3 + betree_Node_lookup_first_message_after_key_back key msgs0 msgs2 in + betree_Node_lookup_first_message_for_key_back key msgs msgs3 end end else let* msgs1 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs0 (key, - new_msg) in - betree_node_lookup_first_message_for_key_back key msgs msgs1 + betree_List_push_front (u64 & betree_Message_t) msgs0 (key, new_msg) in + betree_Node_lookup_first_message_for_key_back key msgs msgs1 (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_apply_messages_to_internal_decreases msgs new_msgs)) +let rec betree_Node_apply_messages_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_apply_messages_to_internal_decreases msgs new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* msgs0 = betree_node_apply_to_internal_fwd_back msgs i m in - betree_node_apply_messages_to_internal_fwd_back msgs0 new_msgs_tl - | BetreeListNil -> Return msgs + let* msgs0 = betree_Node_apply_to_internal msgs i m in + betree_Node_apply_messages_to_internal msgs0 new_msgs_tl + | Betree_List_Nil -> Return msgs end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) -let rec betree_node_lookup_mut_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key - then Return (BetreeListCons (i, i0) tl) - else betree_node_lookup_mut_in_bindings_fwd key tl - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, i0) tl) + else betree_Node_lookup_mut_in_bindings key tl + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) -let rec betree_node_lookup_mut_in_bindings_back - (key : u64) (bindings : betree_list_t (u64 & u64)) - (ret : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings_back + (key : u64) (bindings : betree_List_t (u64 & u64)) + (ret : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key then Return ret else - let* tl0 = betree_node_lookup_mut_in_bindings_back key tl ret in - Return (BetreeListCons (i, i0) tl0) - | BetreeListNil -> Return ret + let* tl0 = betree_Node_lookup_mut_in_bindings_back key tl ret in + Return (Betree_List_Cons (i, i0) tl0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & u64)) +let betree_Node_apply_to_leaf + (bindings : betree_List_t (u64 & u64)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & u64)) = - let* bindings0 = betree_node_lookup_mut_in_bindings_fwd key bindings in - let* b = betree_list_head_has_key_fwd u64 bindings0 key in + let* bindings0 = betree_Node_lookup_mut_in_bindings key bindings in + let* b = betree_List_head_has_key u64 bindings0 key in if b then - let* hd = betree_list_pop_front_fwd (u64 & u64) bindings0 in + let* hd = betree_List_pop_front (u64 & u64) bindings0 in begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 - | BetreeMessageDelete -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageUpsert s -> + | Betree_Message_Insert v -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 + | Betree_Message_Delete -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Upsert s -> let (_, i) = hd in - let* v = betree_upsert_update_fwd (Some i) s in - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 + let* v = betree_upsert_update (Some i) s in + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 end else begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageDelete -> - betree_node_lookup_mut_in_bindings_back key bindings bindings0 - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd None s in - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Insert v -> + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Delete -> + betree_Node_lookup_mut_in_bindings_back key bindings bindings0 + | Betree_Message_Upsert s -> + let* v = betree_upsert_update None s in + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 end (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_apply_messages_to_leaf_decreases bindings new_msgs)) +let rec betree_Node_apply_messages_to_leaf + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_apply_messages_to_leaf_decreases bindings new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* bindings0 = betree_node_apply_to_leaf_fwd_back bindings i m in - betree_node_apply_messages_to_leaf_fwd_back bindings0 new_msgs_tl - | BetreeListNil -> Return bindings + let* bindings0 = betree_Node_apply_to_leaf bindings i m in + betree_Node_apply_messages_to_leaf bindings0 new_msgs_tl + | Betree_List_Nil -> Return bindings end (** [betree_main::betree::Internal::{4}::flush]: forward function *) -let rec betree_internal_flush_fwd - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (state & (betree_list_t (u64 & betree_message_t)))) +let rec betree_Internal_flush + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (_, node_id_cnt0) = - betree_node_apply_messages_back self.betree_internal_left params - node_id_cnt msgs_left st in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back self.left params node_id_cnt msgs_left st + in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st0 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st0 in let* _ = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt0 msgs_right st0 in - Return (st1, BetreeListNil) + betree_Node_apply_messages_back self.right params node_id_cnt0 + msgs_right st0 in + Return (st1, Betree_List_Nil) else Return (st0, msgs_right) else let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* _ = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages_back self.right params node_id_cnt msgs_right + st in Return (st0, msgs_left) (** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) -and betree_internal_flush_back - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (betree_internal_t & betree_node_id_counter_t)) +and betree_Internal_flush_back + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (betree_Internal_t & betree_NodeIdCounter_t)) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (n, node_id_cnt0) = - betree_node_apply_messages_back self.betree_internal_left params - node_id_cnt msgs_left st in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back self.left params node_id_cnt msgs_left st + in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (n0, node_id_cnt1) = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt0 msgs_right st0 in - Return - ({ self with betree_internal_left = n; betree_internal_right = n0 }, - node_id_cnt1) - else Return ({ self with betree_internal_left = n }, node_id_cnt0) + betree_Node_apply_messages_back self.right params node_id_cnt0 + msgs_right st0 in + Return ({ self with left = n; right = n0 }, node_id_cnt1) + else Return ({ self with left = n }, node_id_cnt0) else let* (n, node_id_cnt0) = - betree_node_apply_messages_back self.betree_internal_right params - node_id_cnt msgs_right st in - Return ({ self with betree_internal_right = n }, node_id_cnt0) + betree_Node_apply_messages_back self.right params node_id_cnt msgs_right + st in + Return ({ self with right = n }, node_id_cnt0) (** [betree_main::betree::Node::{5}::apply_messages]: forward function *) -and betree_node_apply_messages_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : +and betree_Node_apply_messages + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : Tot (result (state & unit)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st0, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st1, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st0 in + betree_Internal_flush node params node_id_cnt content0 st0 in let* (node0, _) = - betree_internal_flush_back node params node_id_cnt content0 st0 in - let* (st2, _) = - betree_store_internal_node_fwd node0.betree_internal_id content1 st1 in + betree_Internal_flush_back node params node_id_cnt content0 st0 in + let* (st2, _) = betree_store_internal_node node0.id content1 st1 in Return (st2, ()) else - let* (st1, _) = - betree_store_internal_node_fwd node.betree_internal_id content0 st0 in + let* (st1, _) = betree_store_internal_node node.id content0 st0 in Return (st1, ()) - | BetreeNodeLeaf node -> - let* (st0, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + | Betree_Node_Leaf node -> + let* (st0, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then - let* (st1, _) = - betree_leaf_split_fwd node content0 params node_id_cnt st0 in - let* (st2, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st1 in + let* (st1, _) = betree_Leaf_split node content0 params node_id_cnt st0 in + let* (st2, _) = betree_store_leaf_node node.id Betree_List_Nil st1 in Return (st2, ()) else - let* (st1, _) = - betree_store_leaf_node_fwd node.betree_leaf_id content0 st0 in + let* (st1, _) = betree_store_leaf_node node.id content0 st0 in Return (st1, ()) end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) -and betree_node_apply_messages_back - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (betree_node_t & betree_node_id_counter_t)) +and betree_Node_apply_messages_back + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (betree_Node_t & betree_NodeIdCounter_t)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st0, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st1, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st0 in + betree_Internal_flush node params node_id_cnt content0 st0 in let* (node0, node_id_cnt0) = - betree_internal_flush_back node params node_id_cnt content0 st0 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id content1 st1 in - Return (BetreeNodeInternal node0, node_id_cnt0) + betree_Internal_flush_back node params node_id_cnt content0 st0 in + let* _ = betree_store_internal_node node0.id content1 st1 in + Return (Betree_Node_Internal node0, node_id_cnt0) else - let* _ = - betree_store_internal_node_fwd node.betree_internal_id content0 st0 in - Return (BetreeNodeInternal node, node_id_cnt) - | BetreeNodeLeaf node -> - let* (st0, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + let* _ = betree_store_internal_node node.id content0 st0 in + Return (Betree_Node_Internal node, node_id_cnt) + | Betree_Node_Leaf node -> + let* (st0, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then let* (st1, new_node) = - betree_leaf_split_fwd node content0 params node_id_cnt st0 in - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st1 - in + betree_Leaf_split node content0 params node_id_cnt st0 in + let* _ = betree_store_leaf_node node.id Betree_List_Nil st1 in let* node_id_cnt0 = - betree_leaf_split_back node content0 params node_id_cnt st0 in - Return (BetreeNodeInternal new_node, node_id_cnt0) + betree_Leaf_split_back node content0 params node_id_cnt st0 in + Return (Betree_Node_Internal new_node, node_id_cnt0) else - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id content0 st0 in - Return (BetreeNodeLeaf { node with betree_leaf_size = len }, node_id_cnt) + let* _ = betree_store_leaf_node node.id content0 st0 in + Return (Betree_Node_Leaf { node with size = len }, node_id_cnt) end (** [betree_main::betree::Node::{5}::apply]: forward function *) -let betree_node_apply_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) : +let betree_Node_apply + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : result (state & unit) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st0, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* _ = - betree_node_apply_messages_back self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st in Return (st0, ()) (** [betree_main::betree::Node::{5}::apply]: backward function 0 *) -let betree_node_apply_back - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) : - result (betree_node_t & betree_node_id_counter_t) +let betree_Node_apply_back + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : + result (betree_Node_t & betree_NodeIdCounter_t) = - let l = BetreeListNil in - betree_node_apply_messages_back self params node_id_cnt (BetreeListCons (key, - new_msg) l) st + let l = Betree_List_Nil in + betree_Node_apply_messages_back self params node_id_cnt (Betree_List_Cons + (key, new_msg) l) st (** [betree_main::betree::BeTree::{6}::new]: forward function *) -let betree_be_tree_new_fwd +let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = - let* node_id_cnt = betree_node_id_counter_new_fwd in - let* id = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* (st0, _) = betree_store_leaf_node_fwd id BetreeListNil st in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in + let* node_id_cnt = betree_NodeIdCounter_new in + let* id = betree_NodeIdCounter_fresh_id node_id_cnt in + let* (st0, _) = betree_store_leaf_node id Betree_List_Nil st in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in Return (st0, { - betree_be_tree_params = - { - betree_params_min_flush_size = min_flush_size; - betree_params_split_size = split_size - }; - betree_be_tree_node_id_cnt = node_id_cnt0; - betree_be_tree_root = - (BetreeNodeLeaf { betree_leaf_id = id; betree_leaf_size = 0 }) + params = { min_flush_size = min_flush_size; split_size = split_size }; + node_id_cnt = node_id_cnt0; + root = (Betree_Node_Leaf { id = id; size = 0 }) }) (** [betree_main::betree::BeTree::{6}::apply]: forward function *) -let betree_be_tree_apply_fwd - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) : +let betree_BeTree_apply + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) = let* (st0, _) = - betree_node_apply_fwd self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply self.root self.params self.node_id_cnt key msg st in let* _ = - betree_node_apply_back self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) -let betree_be_tree_apply_back - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) : - result betree_be_tree_t +let betree_BeTree_apply_back + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : + result betree_BeTree_t = let* (n, nic) = - betree_node_apply_back self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in - Return - { self with betree_be_tree_node_id_cnt = nic; betree_be_tree_root = n } + betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in + Return { self with node_id_cnt = nic; root = n } (** [betree_main::betree::BeTree::{6}::insert]: forward function *) -let betree_be_tree_insert_fwd - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) : +let betree_BeTree_insert + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageInsert value) st in - let* _ = betree_be_tree_apply_back self key (BetreeMessageInsert value) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Insert value) st + in + let* _ = betree_BeTree_apply_back self key (Betree_Message_Insert value) st + in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) -let betree_be_tree_insert_back - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) : - result betree_be_tree_t +let betree_BeTree_insert_back + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : + result betree_BeTree_t = - betree_be_tree_apply_back self key (BetreeMessageInsert value) st + betree_BeTree_apply_back self key (Betree_Message_Insert value) st (** [betree_main::betree::BeTree::{6}::delete]: forward function *) -let betree_be_tree_delete_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : result (state & unit) = - let* (st0, _) = betree_be_tree_apply_fwd self key BetreeMessageDelete st in - let* _ = betree_be_tree_apply_back self key BetreeMessageDelete st in +let betree_BeTree_delete + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = + let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in + let* _ = betree_BeTree_apply_back self key Betree_Message_Delete st in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) -let betree_be_tree_delete_back - (self : betree_be_tree_t) (key : u64) (st : state) : - result betree_be_tree_t - = - betree_be_tree_apply_back self key BetreeMessageDelete st +let betree_BeTree_delete_back + (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = + betree_BeTree_apply_back self key Betree_Message_Delete st (** [betree_main::betree::BeTree::{6}::upsert]: forward function *) -let betree_be_tree_upsert_fwd - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageUpsert upd) st in - let* _ = betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Upsert upd) st + in + let* _ = betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) -let betree_be_tree_upsert_back - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert_back + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : - result betree_be_tree_t + result betree_BeTree_t = - betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st + betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st (** [betree_main::betree::BeTree::{6}::lookup]: forward function *) -let betree_be_tree_lookup_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : +let betree_BeTree_lookup + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = - betree_node_lookup_fwd self.betree_be_tree_root key st + betree_Node_lookup self.root key st (** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) -let betree_be_tree_lookup_back - (self : betree_be_tree_t) (key : u64) (st : state) : - result betree_be_tree_t - = - let* n = betree_node_lookup_back self.betree_be_tree_root key st in - Return { self with betree_be_tree_root = n } +let betree_BeTree_lookup_back + (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = + let* n = betree_Node_lookup_back self.root key st in + Return { self with root = n } (** [betree_main::main]: forward function *) -let main_fwd : result unit = +let main : result unit = Return () (** Unit test for [betree_main::main] *) -let _ = assert_norm (main_fwd = Return ()) +let _ = assert_norm (main = Return ()) diff --git a/tests/fstar/betree/BetreeMain.Opaque.fsti b/tests/fstar/betree/BetreeMain.Opaque.fsti index c33cf225..c5d0a814 100644 --- a/tests/fstar/betree/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree/BetreeMain.Opaque.fsti @@ -7,24 +7,24 @@ include BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree_utils::load_internal_node]: forward function *) -val betree_utils_load_internal_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & betree_message_t))) +val betree_utils_load_internal_node + : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) (** [betree_main::betree_utils::store_internal_node]: forward function *) -val betree_utils_store_internal_node_fwd +val betree_utils_store_internal_node : - u64 -> betree_list_t (u64 & betree_message_t) -> state -> result (state & + u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & unit) (** [betree_main::betree_utils::load_leaf_node]: forward function *) -val betree_utils_load_leaf_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & u64))) +val betree_utils_load_leaf_node + : u64 -> state -> result (state & (betree_List_t (u64 & u64))) (** [betree_main::betree_utils::store_leaf_node]: forward function *) -val betree_utils_store_leaf_node_fwd - : u64 -> betree_list_t (u64 & u64) -> state -> result (state & unit) +val betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) (** [core::option::Option::{0}::unwrap]: forward function *) -val core_option_option_unwrap_fwd +val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree/BetreeMain.Types.fsti b/tests/fstar/betree/BetreeMain.Types.fsti index a937c726..9320f6b7 100644 --- a/tests/fstar/betree/BetreeMain.Types.fsti +++ b/tests/fstar/betree/BetreeMain.Types.fsti @@ -6,53 +6,47 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::List] *) -type betree_list_t (t : Type0) = -| BetreeListCons : t -> betree_list_t t -> betree_list_t t -| BetreeListNil : betree_list_t t +type betree_List_t (t : Type0) = +| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t +| Betree_List_Nil : betree_List_t t (** [betree_main::betree::UpsertFunState] *) -type betree_upsert_fun_state_t = -| BetreeUpsertFunStateAdd : u64 -> betree_upsert_fun_state_t -| BetreeUpsertFunStateSub : u64 -> betree_upsert_fun_state_t +type betree_UpsertFunState_t = +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t (** [betree_main::betree::Message] *) -type betree_message_t = -| BetreeMessageInsert : u64 -> betree_message_t -| BetreeMessageDelete : betree_message_t -| BetreeMessageUpsert : betree_upsert_fun_state_t -> betree_message_t +type betree_Message_t = +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t (** [betree_main::betree::Leaf] *) -type betree_leaf_t = { betree_leaf_id : u64; betree_leaf_size : u64; } +type betree_Leaf_t = { id : u64; size : u64; } (** [betree_main::betree::Internal] *) -type betree_internal_t = +type betree_Internal_t = { - betree_internal_id : u64; - betree_internal_pivot : u64; - betree_internal_left : betree_node_t; - betree_internal_right : betree_node_t; + id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; } (** [betree_main::betree::Node] *) -and betree_node_t = -| BetreeNodeInternal : betree_internal_t -> betree_node_t -| BetreeNodeLeaf : betree_leaf_t -> betree_node_t +and betree_Node_t = +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t (** [betree_main::betree::Params] *) -type betree_params_t = -{ - betree_params_min_flush_size : u64; betree_params_split_size : u64; -} +type betree_Params_t = { min_flush_size : u64; split_size : u64; } (** [betree_main::betree::NodeIdCounter] *) -type betree_node_id_counter_t = { betree_node_id_counter_next_node_id : u64; } +type betree_NodeIdCounter_t = { next_node_id : u64; } (** [betree_main::betree::BeTree] *) -type betree_be_tree_t = +type betree_BeTree_t = { - betree_be_tree_params : betree_params_t; - betree_be_tree_node_id_cnt : betree_node_id_counter_t; - betree_be_tree_root : betree_node_t; + params : betree_Params_t; + node_id_cnt : betree_NodeIdCounter_t; + root : betree_Node_t; } (** The state type used in the state-error monad *) diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 3110b247..71d75c11 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -707,5 +707,7 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == - alloc_vec_Vec_update_usize v i x) = + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = admit() diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst index 823df03a..8722f0bf 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst @@ -8,95 +8,95 @@ open BetreeMain.Types (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : nat = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : nat = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: decreases clause *) unfold -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : nat = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: decreases clause *) unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : nat = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat = +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst index 07484711..cda7b920 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst @@ -8,8 +8,8 @@ open BetreeMain.Types (*** Well-founded relations *) (* We had a few issues when proving termination of the mutually recursive functions: - * - betree_internal_flush - * - betree_node_apply_messages + * - betree_Internal_flush + * - betree_Node_apply_messages * * The quantity which effectively decreases is: * (betree_size, messages_length) @@ -103,108 +103,108 @@ let wf_nat_pair_lem (p0 p1 : nat_pair) : (** [betree_main::betree::List::{1}::len]: decreases clause *) unfold -let betree_list_len_decreases (t : Type0) (self : betree_list_t t) : betree_list_t t = +let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : betree_List_t t = self (** [betree_main::betree::List::{1}::split_at]: decreases clause *) unfold -let betree_list_split_at_decreases (t : Type0) (self : betree_list_t t) +let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = n (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_list_partition_at_pivot_decreases (t : Type0) - (self : betree_list_t (u64 & t)) (pivot : u64) : betree_list_t (u64 & t) = +let betree_List_partition_at_pivot_decreases (t : Type0) + (self : betree_List_t (u64 & t)) (pivot : u64) : betree_List_t (u64 & t) = self (** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) unfold -let betree_node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) unfold -let betree_node_lookup_first_message_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) unfold -let betree_node_apply_upserts_decreases - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) - (key : u64) (st : state) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_upserts_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) + (key : u64) (st : state) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) unfold -let betree_internal_lookup_in_children_decreases (self : betree_internal_t) - (key : u64) (st : state) : betree_internal_t = +let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) + (key : u64) (st : state) : betree_Internal_t = self (** [betree_main::betree::Node::{5}::lookup]: decreases clause *) unfold -let betree_node_lookup_decreases (self : betree_node_t) (key : u64) - (st : state) : betree_node_t = +let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) + (st : state) : betree_Node_t = self (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) unfold -let betree_node_lookup_mut_in_bindings_decreases (key : u64) - (bindings : betree_list_t (u64 & u64)) : betree_list_t (u64 & u64) = +let betree_Node_lookup_mut_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : betree_List_t (u64 & u64) = bindings unfold -let betree_node_apply_messages_to_leaf_decreases - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_leaf_decreases + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) unfold -let betree_node_filter_messages_for_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_filter_messages_for_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) unfold -let betree_node_lookup_first_message_after_key_decreases (key : u64) - (msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_lookup_first_message_after_key_decreases (key : u64) + (msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = msgs -let betree_node_apply_messages_to_internal_decreases - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : betree_list_t (u64 & betree_message_t) = +let betree_Node_apply_messages_to_internal_decreases + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : betree_List_t (u64 & betree_Message_t) = new_msgs (*** Decrease clauses - nat_pair *) /// The following decrease clauses use the [nat_pair] definition and the well-founded /// relation proven above. -let rec betree_size (bt : betree_node_t) : nat = +let rec betree_size (bt : betree_Node_t) : nat = match bt with - | BetreeNodeInternal node -> 1 + betree_internal_size node - | BetreeNodeLeaf _ -> 1 + | Betree_Node_Internal node -> 1 + betree_Internal_size node + | Betree_Node_Leaf _ -> 1 -and betree_internal_size (node : betree_internal_t) : nat = - 1 + betree_size node.betree_internal_left + betree_size node.betree_internal_right +and betree_Internal_size (node : betree_Internal_t) : nat = + 1 + betree_size node.left + betree_size node.right -let rec betree_list_len (#a : Type0) (ls : betree_list_t a) : nat = +let rec betree_List_len (#a : Type0) (ls : betree_List_t a) : nat = match ls with - | BetreeListCons _ tl -> 1 + betree_list_len tl - | BetreeListNil -> 0 + | Betree_List_Cons _ tl -> 1 + betree_List_len tl + | Betree_List_Nil -> 0 (** [betree_main::betree::Internal::{4}::flush]: decreases clause *) unfold -let betree_internal_flush_decreases (self : betree_internal_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_internal_size self, 0|) +let betree_Internal_flush_decreases (self : betree_Internal_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_Internal_size self, 0|) (** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) unfold -let betree_node_apply_messages_decreases (self : betree_node_t) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : nat_pair = - (|betree_size self, betree_list_len msgs|) +let betree_Node_apply_messages_decreases (self : betree_Node_t) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : nat_pair = + (|betree_size self, betree_List_len msgs|) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index 8083ee8f..08c4f615 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -9,35 +9,35 @@ include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::load_internal_node]: forward function *) -let betree_load_internal_node_fwd +let betree_load_internal_node (id : u64) (st : state) : - result (state & (betree_list_t (u64 & betree_message_t))) + result (state & (betree_List_t (u64 & betree_Message_t))) = - betree_utils_load_internal_node_fwd id st + betree_utils_load_internal_node id st (** [betree_main::betree::store_internal_node]: forward function *) -let betree_store_internal_node_fwd - (id : u64) (content : betree_list_t (u64 & betree_message_t)) (st : state) : +let betree_store_internal_node + (id : u64) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_internal_node_fwd id content st in + let* (st0, _) = betree_utils_store_internal_node id content st in Return (st0, ()) (** [betree_main::betree::load_leaf_node]: forward function *) -let betree_load_leaf_node_fwd - (id : u64) (st : state) : result (state & (betree_list_t (u64 & u64))) = - betree_utils_load_leaf_node_fwd id st +let betree_load_leaf_node + (id : u64) (st : state) : result (state & (betree_List_t (u64 & u64))) = + betree_utils_load_leaf_node id st (** [betree_main::betree::store_leaf_node]: forward function *) -let betree_store_leaf_node_fwd - (id : u64) (content : betree_list_t (u64 & u64)) (st : state) : +let betree_store_leaf_node + (id : u64) (content : betree_List_t (u64 & u64)) (st : state) : result (state & unit) = - let* (st0, _) = betree_utils_store_leaf_node_fwd id content st in + let* (st0, _) = betree_utils_store_leaf_node id content st in Return (st0, ()) (** [betree_main::betree::fresh_node_id]: forward function *) -let betree_fresh_node_id_fwd (counter : u64) : result u64 = +let betree_fresh_node_id (counter : u64) : result u64 = let* _ = u64_add counter 1 in Return counter (** [betree_main::betree::fresh_node_id]: backward function 0 *) @@ -45,1204 +45,1123 @@ let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 (** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) -let betree_node_id_counter_new_fwd : result betree_node_id_counter_t = - Return { betree_node_id_counter_next_node_id = 0 } +let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = + Return { next_node_id = 0 } (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) -let betree_node_id_counter_fresh_id_fwd - (self : betree_node_id_counter_t) : result u64 = - let* _ = u64_add self.betree_node_id_counter_next_node_id 1 in - Return self.betree_node_id_counter_next_node_id +let betree_NodeIdCounter_fresh_id + (self : betree_NodeIdCounter_t) : result u64 = + let* _ = u64_add self.next_node_id 1 in Return self.next_node_id (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) -let betree_node_id_counter_fresh_id_back - (self : betree_node_id_counter_t) : result betree_node_id_counter_t = - let* i = u64_add self.betree_node_id_counter_next_node_id 1 in - Return { betree_node_id_counter_next_node_id = i } +let betree_NodeIdCounter_fresh_id_back + (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = + let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } (** [betree_main::betree::upsert_update]: forward function *) -let betree_upsert_update_fwd - (prev : option u64) (st : betree_upsert_fun_state_t) : result u64 = +let betree_upsert_update + (prev : option u64) (st : betree_UpsertFunState_t) : result u64 = begin match prev with | None -> begin match st with - | BetreeUpsertFunStateAdd v -> Return v - | BetreeUpsertFunStateSub i -> Return 0 + | Betree_UpsertFunState_Add v -> Return v + | Betree_UpsertFunState_Sub i -> Return 0 end | Some prev0 -> begin match st with - | BetreeUpsertFunStateAdd v -> + | Betree_UpsertFunState_Add v -> let* margin = u64_sub core_u64_max prev0 in if margin >= v then u64_add prev0 v else Return core_u64_max - | BetreeUpsertFunStateSub v -> + | Betree_UpsertFunState_Sub v -> if prev0 >= v then u64_sub prev0 v else Return 0 end end (** [betree_main::betree::List::{1}::len]: forward function *) -let rec betree_list_len_fwd - (t : Type0) (self : betree_list_t t) : - Tot (result u64) (decreases (betree_list_len_decreases t self)) +let rec betree_List_len + (t : Type0) (self : betree_List_t t) : + Tot (result u64) (decreases (betree_List_len_decreases t self)) = begin match self with - | BetreeListCons x tl -> let* i = betree_list_len_fwd t tl in u64_add 1 i - | BetreeListNil -> Return 0 + | Betree_List_Cons x tl -> let* i = betree_List_len t tl in u64_add 1 i + | Betree_List_Nil -> Return 0 end (** [betree_main::betree::List::{1}::split_at]: forward function *) -let rec betree_list_split_at_fwd - (t : Type0) (self : betree_list_t t) (n : u64) : - Tot (result ((betree_list_t t) & (betree_list_t t))) - (decreases (betree_list_split_at_decreases t self n)) +let rec betree_List_split_at + (t : Type0) (self : betree_List_t t) (n : u64) : + Tot (result ((betree_List_t t) & (betree_List_t t))) + (decreases (betree_List_split_at_decreases t self n)) = if n = 0 - then Return (BetreeListNil, self) + then Return (Betree_List_Nil, self) else begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let* i = u64_sub n 1 in - let* p = betree_list_split_at_fwd t tl i in + let* p = betree_List_split_at t tl i in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons hd l, ls1) - | BetreeListNil -> Fail Failure + Return (Betree_List_Cons hd l, ls1) + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_list_push_front_fwd_back - (t : Type0) (self : betree_list_t t) (x : t) : result (betree_list_t t) = - let tl = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_push_front + (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = + let tl = core_mem_replace (betree_List_t t) self Betree_List_Nil in let l = tl in - Return (BetreeListCons x l) + Return (Betree_List_Cons x l) (** [betree_main::betree::List::{1}::pop_front]: forward function *) -let betree_list_pop_front_fwd (t : Type0) (self : betree_list_t t) : result t = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return x - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return x + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) -let betree_list_pop_front_back - (t : Type0) (self : betree_list_t t) : result (betree_list_t t) = - let ls = mem_replace_fwd (betree_list_t t) self BetreeListNil in +let betree_List_pop_front_back + (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = + let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with - | BetreeListCons x tl -> Return tl - | BetreeListNil -> Fail Failure + | Betree_List_Cons x tl -> Return tl + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{1}::hd]: forward function *) -let betree_list_hd_fwd (t : Type0) (self : betree_list_t t) : result t = +let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with - | BetreeListCons hd l -> Return hd - | BetreeListNil -> Fail Failure + | Betree_List_Cons hd l -> Return hd + | Betree_List_Nil -> Fail Failure end (** [betree_main::betree::List::{2}::head_has_key]: forward function *) -let betree_list_head_has_key_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (key : u64) : result bool = +let betree_List_head_has_key + (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with - | BetreeListCons hd l -> let (i, _) = hd in Return (i = key) - | BetreeListNil -> Return false + | Betree_List_Cons hd l -> let (i, _) = hd in Return (i = key) + | Betree_List_Nil -> Return false end (** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -let rec betree_list_partition_at_pivot_fwd - (t : Type0) (self : betree_list_t (u64 & t)) (pivot : u64) : - Tot (result ((betree_list_t (u64 & t)) & (betree_list_t (u64 & t)))) - (decreases (betree_list_partition_at_pivot_decreases t self pivot)) +let rec betree_List_partition_at_pivot + (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : + Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) + (decreases (betree_List_partition_at_pivot_decreases t self pivot)) = begin match self with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, x) = hd in if i >= pivot - then Return (BetreeListNil, BetreeListCons (i, x) tl) + then Return (Betree_List_Nil, Betree_List_Cons (i, x) tl) else - let* p = betree_list_partition_at_pivot_fwd t tl pivot in + let* p = betree_List_partition_at_pivot t tl pivot in let (ls0, ls1) = p in let l = ls0 in - Return (BetreeListCons (i, x) l, ls1) - | BetreeListNil -> Return (BetreeListNil, BetreeListNil) + Return (Betree_List_Cons (i, x) l, ls1) + | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end (** [betree_main::betree::Leaf::{3}::split]: forward function *) -let betree_leaf_split_fwd - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result (state & betree_internal_t) + result (state & betree_Internal_t) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* p0 = betree_list_hd_fwd (u64 & u64) content1 in + let* p0 = betree_List_hd (u64 & u64) content1 in let (pivot, _) = p0 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st0, _) = betree_store_leaf_node_fwd id0 content0 st in - let* (st1, _) = betree_store_leaf_node_fwd id1 content1 st0 in - let n = BetreeNodeLeaf - { betree_leaf_id = id0; betree_leaf_size = params.betree_params_split_size - } in - let n0 = BetreeNodeLeaf - { betree_leaf_id = id1; betree_leaf_size = params.betree_params_split_size - } in - Return (st1, - { - betree_internal_id = self.betree_leaf_id; - betree_internal_pivot = pivot; - betree_internal_left = n; - betree_internal_right = n0 - }) + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st0, _) = betree_store_leaf_node id0 content0 st in + let* (st1, _) = betree_store_leaf_node id1 content1 st0 in + let n = Betree_Node_Leaf { id = id0; size = params.split_size } in + let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in + Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) (** [betree_main::betree::Leaf::{3}::split]: backward function 0 *) -let betree_leaf_split_back0 - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back0 + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) (st0 : state) : result (state & unit) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st1, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st1 in + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st1, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) (** [betree_main::betree::Leaf::{3}::split]: backward function 1 *) -let betree_leaf_split_back1 - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back1 + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) (st0 : state) : result (state & unit) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st1, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st1 in + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st1, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) (** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) -let betree_leaf_split_back2 - (self : betree_leaf_t) (content : betree_list_t (u64 & u64)) - (params : betree_params_t) (node_id_cnt : betree_node_id_counter_t) +let betree_Leaf_split_back2 + (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) (st0 : state) : - result (state & betree_node_id_counter_t) + result (state & betree_NodeIdCounter_t) = - let* p = - betree_list_split_at_fwd (u64 & u64) content - params.betree_params_split_size in + let* p = betree_List_split_at (u64 & u64) content params.split_size in let (content0, content1) = p in - let* _ = betree_list_hd_fwd (u64 & u64) content1 in - let* id0 = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in - let* id1 = betree_node_id_counter_fresh_id_fwd node_id_cnt0 in - let* (st1, _) = betree_store_leaf_node_fwd id0 content0 st in - let* _ = betree_store_leaf_node_fwd id1 content1 st1 in - let* node_id_cnt1 = betree_node_id_counter_fresh_id_back node_id_cnt0 in + let* _ = betree_List_hd (u64 & u64) content1 in + let* id0 = betree_NodeIdCounter_fresh_id node_id_cnt in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in + let* id1 = betree_NodeIdCounter_fresh_id node_id_cnt0 in + let* (st1, _) = betree_store_leaf_node id0 content0 st in + let* _ = betree_store_leaf_node id1 content1 st1 in + let* node_id_cnt1 = betree_NodeIdCounter_fresh_id_back node_id_cnt0 in Return (st0, node_id_cnt1) (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) -let rec betree_node_lookup_first_message_for_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key - then Return (BetreeListCons (i, m) next_msgs) - else betree_node_lookup_first_message_for_key_fwd key next_msgs - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, m) next_msgs) + else betree_Node_lookup_first_message_for_key key next_msgs + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) -let rec betree_node_lookup_first_message_for_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_for_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_for_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons x next_msgs -> + | Betree_List_Cons x next_msgs -> let (i, m) = x in if i >= key then Return ret else let* next_msgs0 = - betree_node_lookup_first_message_for_key_back key next_msgs ret in - Return (BetreeListCons (i, m) next_msgs0) - | BetreeListNil -> Return ret + betree_Node_lookup_first_message_for_key_back key next_msgs ret in + Return (Betree_List_Cons (i, m) next_msgs0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) -let rec betree_node_apply_upserts_fwd - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (state & u64)) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_fwd msgs0 (Some v) key st + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts msgs0 (Some v) key st end else - let* (st0, v) = core_option_option_unwrap_fwd u64 prev st in + let* (st0, v) = core_option_Option_unwrap u64 prev st in let* _ = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) in Return (st0, v) (** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) -let rec betree_node_apply_upserts_back - (msgs : betree_list_t (u64 & betree_message_t)) (prev : option u64) +let rec betree_Node_apply_upserts_back + (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) (st0 : state) : - Tot (result (state & (betree_list_t (u64 & betree_message_t)))) - (decreases (betree_node_apply_upserts_decreases msgs prev key st)) + Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) + (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_list_head_has_key_fwd betree_message_t msgs key in + let* b = betree_List_head_has_key betree_Message_t msgs key in if b then - let* msg = betree_list_pop_front_fwd (u64 & betree_message_t) msgs in + let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in let (_, m) = msg in begin match m with - | BetreeMessageInsert i -> Fail Failure - | BetreeMessageDelete -> Fail Failure - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd prev s in - let* msgs0 = betree_list_pop_front_back (u64 & betree_message_t) msgs in - betree_node_apply_upserts_back msgs0 (Some v) key st st0 + | Betree_Message_Insert i -> Fail Failure + | Betree_Message_Delete -> Fail Failure + | Betree_Message_Upsert s -> + let* v = betree_upsert_update prev s in + let* msgs0 = betree_List_pop_front_back (u64 & betree_Message_t) msgs in + betree_Node_apply_upserts_back msgs0 (Some v) key st st0 end else - let* (_, v) = core_option_option_unwrap_fwd u64 prev st in + let* (_, v) = core_option_Option_unwrap u64 prev st in let* msgs0 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs (key, - BetreeMessageInsert v) in + betree_List_push_front (u64 & betree_Message_t) msgs (key, + Betree_Message_Insert v) in Return (st0, msgs0) (** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) -let rec betree_node_lookup_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : +let rec betree_Node_lookup_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) - (decreases (betree_node_lookup_in_bindings_decreases key bindings)) + (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i = key then Return (Some i0) - else - if i > key - then Return None - else betree_node_lookup_in_bindings_fwd key tl - | BetreeListNil -> Return None + else if i > key then Return None else betree_Node_lookup_in_bindings key tl + | Betree_List_Nil -> Return None end (** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) -let rec betree_internal_lookup_in_children_fwd - (self : betree_internal_t) (key : u64) (st : state) : +let rec betree_Internal_lookup_in_children + (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_internal_lookup_in_children_decreases self key st)) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot - then betree_node_lookup_fwd self.betree_internal_left key st - else betree_node_lookup_fwd self.betree_internal_right key st + if key < self.pivot + then betree_Node_lookup self.left key st + else betree_Node_lookup self.right key st (** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) -and betree_internal_lookup_in_children_back - (self : betree_internal_t) (key : u64) (st : state) (st0 : state) : - Tot (result (state & betree_internal_t)) - (decreases (betree_internal_lookup_in_children_decreases self key st)) +and betree_Internal_lookup_in_children_back + (self : betree_Internal_t) (key : u64) (st : state) (st0 : state) : + Tot (result (state & betree_Internal_t)) + (decreases (betree_Internal_lookup_in_children_decreases self key st)) = - if key < self.betree_internal_pivot + if key < self.pivot then - let* (st1, n) = - betree_node_lookup_back self.betree_internal_left key st st0 in - Return (st1, { self with betree_internal_left = n }) + let* (st1, n) = betree_Node_lookup_back self.left key st st0 in + Return (st1, { self with left = n }) else - let* (st1, n) = - betree_node_lookup_back self.betree_internal_right key st st0 in - Return (st1, { self with betree_internal_right = n }) + let* (st1, n) = betree_Node_lookup_back self.right key st st0 in + Return (st1, { self with right = n }) (** [betree_main::betree::Node::{5}::lookup]: forward function *) -and betree_node_lookup_fwd - (self : betree_node_t) (key : u64) (st : state) : +and betree_Node_lookup + (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) - (decreases (betree_node_lookup_decreases self key st)) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st0, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 - in + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in + Return (st1, o) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in Return (st0, Some v) - | BetreeMessageDelete -> + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in Return (st0, None) - | BetreeMessageUpsert ufs -> - let* (st1, v) = betree_internal_lookup_in_children_fwd node key st0 - in + | Betree_Message_Upsert ufs -> + let* (st1, v) = betree_Internal_lookup_in_children node key st0 in let* (st2, v0) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 in let* (st3, node0) = - betree_internal_lookup_in_children_back node key st0 st2 in + betree_Internal_lookup_in_children_back node key st0 st2 in let* (st4, pending0) = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1 st3 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1 st3 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* (st5, _) = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st4 - in + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* (st5, _) = betree_store_internal_node node0.id msgs0 st4 in Return (st5, Some v0) end - | BetreeListNil -> - let* (st1, opt) = betree_internal_lookup_in_children_fwd node key st0 in + | Betree_List_Nil -> + let* (st1, o) = betree_Internal_lookup_in_children node key st0 in let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in + Return (st1, o) end - | BetreeNodeLeaf node -> - let* (st0, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* opt = betree_node_lookup_in_bindings_fwd key bindings in - Return (st0, opt) + | Betree_Node_Leaf node -> + let* (st0, bindings) = betree_load_leaf_node node.id st in + let* o = betree_Node_lookup_in_bindings key bindings in + Return (st0, o) end (** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) -and betree_node_lookup_back - (self : betree_node_t) (key : u64) (st : state) (st0 : state) : - Tot (result (state & betree_node_t)) - (decreases (betree_node_lookup_decreases self key st)) +and betree_Node_lookup_back + (self : betree_Node_t) (key : u64) (st : state) (st0 : state) : + Tot (result (state & betree_Node_t)) + (decreases (betree_Node_lookup_decreases self key st)) = begin match self with - | BetreeNodeInternal node -> - let* (st1, msgs) = betree_load_internal_node_fwd node.betree_internal_id st - in - let* pending = betree_node_lookup_first_message_for_key_fwd key msgs in + | Betree_Node_Internal node -> + let* (st1, msgs) = betree_load_internal_node node.id st in + let* pending = betree_Node_lookup_first_message_for_key key msgs in begin match pending with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, msg) = p in if k <> key then let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, msg) l) in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, msg) l) in let* (st2, node0) = - betree_internal_lookup_in_children_back node key st1 st0 in - Return (st2, BetreeNodeInternal node0) + betree_Internal_lookup_in_children_back node key st1 st0 in + Return (st2, Betree_Node_Internal node0) else begin match msg with - | BetreeMessageInsert v -> + | Betree_Message_Insert v -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageInsert v) l) in - Return (st0, BetreeNodeInternal node) - | BetreeMessageDelete -> + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l) in + Return (st0, Betree_Node_Internal node) + | Betree_Message_Delete -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs - (BetreeListCons (k, BetreeMessageDelete) l) in - Return (st0, BetreeNodeInternal node) - | BetreeMessageUpsert ufs -> - let* (st2, v) = betree_internal_lookup_in_children_fwd node key st1 - in + betree_Node_lookup_first_message_for_key_back key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l) in + Return (st0, Betree_Node_Internal node) + | Betree_Message_Upsert ufs -> + let* (st2, v) = betree_Internal_lookup_in_children node key st1 in let* (st3, _) = - betree_node_apply_upserts_fwd (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st2 in + betree_Node_apply_upserts (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st2 in let* (st4, node0) = - betree_internal_lookup_in_children_back node key st1 st3 in + betree_Internal_lookup_in_children_back node key st1 st3 in let* (st5, pending0) = - betree_node_apply_upserts_back (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st2 st4 in + betree_Node_apply_upserts_back (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st2 st4 in let* msgs0 = - betree_node_lookup_first_message_for_key_back key msgs pending0 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id msgs0 st5 - in - Return (st0, BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back key msgs pending0 in + let* _ = betree_store_internal_node node0.id msgs0 st5 in + Return (st0, Betree_Node_Internal node0) end - | BetreeListNil -> + | Betree_List_Nil -> let* _ = - betree_node_lookup_first_message_for_key_back key msgs BetreeListNil in + betree_Node_lookup_first_message_for_key_back key msgs Betree_List_Nil + in let* (st2, node0) = - betree_internal_lookup_in_children_back node key st1 st0 in - Return (st2, BetreeNodeInternal node0) + betree_Internal_lookup_in_children_back node key st1 st0 in + Return (st2, Betree_Node_Internal node0) end - | BetreeNodeLeaf node -> - let* (_, bindings) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* _ = betree_node_lookup_in_bindings_fwd key bindings in - Return (st0, BetreeNodeLeaf node) + | Betree_Node_Leaf node -> + let* (_, bindings) = betree_load_leaf_node node.id st in + let* _ = betree_Node_lookup_in_bindings key bindings in + Return (st0, Betree_Node_Leaf node) end (** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_filter_messages_for_key_fwd_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_filter_messages_for_key_decreases key msgs)) +let rec betree_Node_filter_messages_for_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_filter_messages_for_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p l -> + | Betree_List_Cons p l -> let (k, m) = p in if k = key then let* msgs0 = - betree_list_pop_front_back (u64 & betree_message_t) (BetreeListCons (k, - m) l) in - betree_node_filter_messages_for_key_fwd_back key msgs0 - else Return (BetreeListCons (k, m) l) - | BetreeListNil -> Return BetreeListNil + betree_List_pop_front_back (u64 & betree_Message_t) (Betree_List_Cons + (k, m) l) in + betree_Node_filter_messages_for_key key msgs0 + else Return (Betree_List_Cons (k, m) l) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) -let rec betree_node_lookup_first_message_after_key_fwd - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key - then betree_node_lookup_first_message_after_key_fwd key next_msgs - else Return (BetreeListCons (k, m) next_msgs) - | BetreeListNil -> Return BetreeListNil + then betree_Node_lookup_first_message_after_key key next_msgs + else Return (Betree_List_Cons (k, m) next_msgs) + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) -let rec betree_node_lookup_first_message_after_key_back - (key : u64) (msgs : betree_list_t (u64 & betree_message_t)) - (ret : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_lookup_first_message_after_key_decreases key msgs)) +let rec betree_Node_lookup_first_message_after_key_back + (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) + (ret : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_lookup_first_message_after_key_decreases key msgs)) = begin match msgs with - | BetreeListCons p next_msgs -> + | Betree_List_Cons p next_msgs -> let (k, m) = p in if k = key then let* next_msgs0 = - betree_node_lookup_first_message_after_key_back key next_msgs ret in - Return (BetreeListCons (k, m) next_msgs0) + betree_Node_lookup_first_message_after_key_back key next_msgs ret in + Return (Betree_List_Cons (k, m) next_msgs0) else Return ret - | BetreeListNil -> Return ret + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & betree_message_t)) +let betree_Node_apply_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & betree_Message_t)) = - let* msgs0 = betree_node_lookup_first_message_for_key_fwd key msgs in - let* b = betree_list_head_has_key_fwd betree_message_t msgs0 key in + let* msgs0 = betree_Node_lookup_first_message_for_key key msgs in + let* b = betree_List_head_has_key betree_Message_t msgs0 key in if b then begin match new_msg with - | BetreeMessageInsert i -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + | Betree_Message_Insert i -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert i) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* msgs1 = betree_node_filter_messages_for_key_fwd_back key msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert i) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* msgs1 = betree_Node_filter_messages_for_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageDelete) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert s -> - let* p = betree_list_hd_fwd (u64 & betree_message_t) msgs0 in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Delete) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert s -> + let* p = betree_List_hd (u64 & betree_Message_t) msgs0 in let (_, m) = p in begin match m with - | BetreeMessageInsert prev -> - let* v = betree_upsert_update_fwd (Some prev) s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + | Betree_Message_Insert prev -> + let* v = betree_upsert_update (Some prev) s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageDelete -> - let* v = betree_upsert_update_fwd None s in - let* msgs1 = betree_list_pop_front_back (u64 & betree_message_t) msgs0 + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Delete -> + let* v = betree_upsert_update None s in + let* msgs1 = betree_List_pop_front_back (u64 & betree_Message_t) msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageInsert v) in - betree_node_lookup_first_message_for_key_back key msgs msgs2 - | BetreeMessageUpsert ufs -> - let* msgs1 = betree_node_lookup_first_message_after_key_fwd key msgs0 - in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Insert v) in + betree_Node_lookup_first_message_for_key_back key msgs msgs2 + | Betree_Message_Upsert ufs -> + let* msgs1 = betree_Node_lookup_first_message_after_key key msgs0 in let* msgs2 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs1 (key, - BetreeMessageUpsert s) in + betree_List_push_front (u64 & betree_Message_t) msgs1 (key, + Betree_Message_Upsert s) in let* msgs3 = - betree_node_lookup_first_message_after_key_back key msgs0 msgs2 in - betree_node_lookup_first_message_for_key_back key msgs msgs3 + betree_Node_lookup_first_message_after_key_back key msgs0 msgs2 in + betree_Node_lookup_first_message_for_key_back key msgs msgs3 end end else let* msgs1 = - betree_list_push_front_fwd_back (u64 & betree_message_t) msgs0 (key, - new_msg) in - betree_node_lookup_first_message_for_key_back key msgs msgs1 + betree_List_push_front (u64 & betree_Message_t) msgs0 (key, new_msg) in + betree_Node_lookup_first_message_for_key_back key msgs msgs1 (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_internal_fwd_back - (msgs : betree_list_t (u64 & betree_message_t)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & betree_message_t))) - (decreases (betree_node_apply_messages_to_internal_decreases msgs new_msgs)) +let rec betree_Node_apply_messages_to_internal + (msgs : betree_List_t (u64 & betree_Message_t)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & betree_Message_t))) + (decreases (betree_Node_apply_messages_to_internal_decreases msgs new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* msgs0 = betree_node_apply_to_internal_fwd_back msgs i m in - betree_node_apply_messages_to_internal_fwd_back msgs0 new_msgs_tl - | BetreeListNil -> Return msgs + let* msgs0 = betree_Node_apply_to_internal msgs i m in + betree_Node_apply_messages_to_internal msgs0 new_msgs_tl + | Betree_List_Nil -> Return msgs end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) -let rec betree_node_lookup_mut_in_bindings_fwd - (key : u64) (bindings : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key - then Return (BetreeListCons (i, i0) tl) - else betree_node_lookup_mut_in_bindings_fwd key tl - | BetreeListNil -> Return BetreeListNil + then Return (Betree_List_Cons (i, i0) tl) + else betree_Node_lookup_mut_in_bindings key tl + | Betree_List_Nil -> Return Betree_List_Nil end (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) -let rec betree_node_lookup_mut_in_bindings_back - (key : u64) (bindings : betree_list_t (u64 & u64)) - (ret : betree_list_t (u64 & u64)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_lookup_mut_in_bindings_decreases key bindings)) +let rec betree_Node_lookup_mut_in_bindings_back + (key : u64) (bindings : betree_List_t (u64 & u64)) + (ret : betree_List_t (u64 & u64)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_lookup_mut_in_bindings_decreases key bindings)) = begin match bindings with - | BetreeListCons hd tl -> + | Betree_List_Cons hd tl -> let (i, i0) = hd in if i >= key then Return ret else - let* tl0 = betree_node_lookup_mut_in_bindings_back key tl ret in - Return (BetreeListCons (i, i0) tl0) - | BetreeListNil -> Return ret + let* tl0 = betree_Node_lookup_mut_in_bindings_back key tl ret in + Return (Betree_List_Cons (i, i0) tl0) + | Betree_List_Nil -> Return ret end (** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let betree_node_apply_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) (key : u64) - (new_msg : betree_message_t) : - result (betree_list_t (u64 & u64)) +let betree_Node_apply_to_leaf + (bindings : betree_List_t (u64 & u64)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 & u64)) = - let* bindings0 = betree_node_lookup_mut_in_bindings_fwd key bindings in - let* b = betree_list_head_has_key_fwd u64 bindings0 key in + let* bindings0 = betree_Node_lookup_mut_in_bindings key bindings in + let* b = betree_List_head_has_key u64 bindings0 key in if b then - let* hd = betree_list_pop_front_fwd (u64 & u64) bindings0 in + let* hd = betree_List_pop_front (u64 & u64) bindings0 in begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 - | BetreeMessageDelete -> - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageUpsert s -> + | Betree_Message_Insert v -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 + | Betree_Message_Delete -> + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Upsert s -> let (_, i) = hd in - let* v = betree_upsert_update_fwd (Some i) s in - let* bindings1 = betree_list_pop_front_back (u64 & u64) bindings0 in - let* bindings2 = - betree_list_push_front_fwd_back (u64 & u64) bindings1 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings2 + let* v = betree_upsert_update (Some i) s in + let* bindings1 = betree_List_pop_front_back (u64 & u64) bindings0 in + let* bindings2 = betree_List_push_front (u64 & u64) bindings1 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings2 end else begin match new_msg with - | BetreeMessageInsert v -> - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 - | BetreeMessageDelete -> - betree_node_lookup_mut_in_bindings_back key bindings bindings0 - | BetreeMessageUpsert s -> - let* v = betree_upsert_update_fwd None s in - let* bindings1 = - betree_list_push_front_fwd_back (u64 & u64) bindings0 (key, v) in - betree_node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Insert v -> + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 + | Betree_Message_Delete -> + betree_Node_lookup_mut_in_bindings_back key bindings bindings0 + | Betree_Message_Upsert s -> + let* v = betree_upsert_update None s in + let* bindings1 = betree_List_push_front (u64 & u64) bindings0 (key, v) in + betree_Node_lookup_mut_in_bindings_back key bindings bindings1 end (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -let rec betree_node_apply_messages_to_leaf_fwd_back - (bindings : betree_list_t (u64 & u64)) - (new_msgs : betree_list_t (u64 & betree_message_t)) : - Tot (result (betree_list_t (u64 & u64))) - (decreases (betree_node_apply_messages_to_leaf_decreases bindings new_msgs)) +let rec betree_Node_apply_messages_to_leaf + (bindings : betree_List_t (u64 & u64)) + (new_msgs : betree_List_t (u64 & betree_Message_t)) : + Tot (result (betree_List_t (u64 & u64))) + (decreases (betree_Node_apply_messages_to_leaf_decreases bindings new_msgs)) = begin match new_msgs with - | BetreeListCons new_msg new_msgs_tl -> + | Betree_List_Cons new_msg new_msgs_tl -> let (i, m) = new_msg in - let* bindings0 = betree_node_apply_to_leaf_fwd_back bindings i m in - betree_node_apply_messages_to_leaf_fwd_back bindings0 new_msgs_tl - | BetreeListNil -> Return bindings + let* bindings0 = betree_Node_apply_to_leaf bindings i m in + betree_Node_apply_messages_to_leaf bindings0 new_msgs_tl + | Betree_List_Nil -> Return bindings end (** [betree_main::betree::Internal::{4}::flush]: forward function *) -let rec betree_internal_flush_fwd - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) : - Tot (result (state & (betree_list_t (u64 & betree_message_t)))) +let rec betree_Internal_flush + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) : + Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (st1, (_, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_left params - node_id_cnt msgs_left st st0 in + betree_Node_apply_messages_back'a self.left params node_id_cnt msgs_left + st st0 in let* (st2, ()) = - betree_node_apply_messages_back1 self.betree_internal_left params - node_id_cnt msgs_left st st1 in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back1 self.left params node_id_cnt msgs_left + st st1 in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st3, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st2 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st2 in let* (st4, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt0 msgs_right st2 st3 in + betree_Node_apply_messages_back'a self.right params node_id_cnt0 + msgs_right st2 st3 in let* (st5, ()) = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt0 msgs_right st2 st4 in - Return (st5, BetreeListNil) + betree_Node_apply_messages_back1 self.right params node_id_cnt0 + msgs_right st2 st4 in + Return (st5, Betree_List_Nil) else Return (st2, msgs_right) else let* (st0, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* (st1, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt msgs_right st st0 in + betree_Node_apply_messages_back'a self.right params node_id_cnt + msgs_right st st0 in let* (st2, ()) = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt msgs_right st st1 in + betree_Node_apply_messages_back1 self.right params node_id_cnt msgs_right + st st1 in Return (st2, msgs_left) (** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) -and betree_internal_flush_back'a - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) +and betree_Internal_flush_back'a + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : - Tot (result (state & (betree_internal_t & betree_node_id_counter_t))) + Tot (result (state & (betree_Internal_t & betree_NodeIdCounter_t))) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (st2, (n, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_left params - node_id_cnt msgs_left st st1 in + betree_Node_apply_messages_back'a self.left params node_id_cnt msgs_left + st st1 in let* (st3, ()) = - betree_node_apply_messages_back1 self.betree_internal_left params - node_id_cnt msgs_left st st2 in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back1 self.left params node_id_cnt msgs_left + st st2 in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st4, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st3 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st3 in let* (st5, (n0, node_id_cnt1)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt0 msgs_right st3 st4 in + betree_Node_apply_messages_back'a self.right params node_id_cnt0 + msgs_right st3 st4 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt0 msgs_right st3 st5 in - Return (st0, - ({ self with betree_internal_left = n; betree_internal_right = n0 }, - node_id_cnt1)) - else Return (st0, ({ self with betree_internal_left = n }, node_id_cnt0)) + betree_Node_apply_messages_back1 self.right params node_id_cnt0 + msgs_right st3 st5 in + Return (st0, ({ self with left = n; right = n0 }, node_id_cnt1)) + else Return (st0, ({ self with left = n }, node_id_cnt0)) else let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* (st2, (n, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt msgs_right st st1 in + betree_Node_apply_messages_back'a self.right params node_id_cnt + msgs_right st st1 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt msgs_right st st2 in - Return (st0, ({ self with betree_internal_right = n }, node_id_cnt0)) + betree_Node_apply_messages_back1 self.right params node_id_cnt msgs_right + st st2 in + Return (st0, ({ self with right = n }, node_id_cnt0)) (** [betree_main::betree::Internal::{4}::flush]: backward function 1 *) -and betree_internal_flush_back1 - (self : betree_internal_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (content : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) +and betree_Internal_flush_back1 + (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : Tot (result (state & unit)) (decreases ( - betree_internal_flush_decreases self params node_id_cnt content st)) + betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = - betree_list_partition_at_pivot_fwd betree_message_t content - self.betree_internal_pivot in + let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + in let (msgs_left, msgs_right) = p in - let* len_left = betree_list_len_fwd (u64 & betree_message_t) msgs_left in - if len_left >= params.betree_params_min_flush_size + let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in + if len_left >= params.min_flush_size then let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_left params - node_id_cnt msgs_left st in + betree_Node_apply_messages self.left params node_id_cnt msgs_left st in let* (st2, (_, node_id_cnt0)) = - betree_node_apply_messages_back'a self.betree_internal_left params - node_id_cnt msgs_left st st1 in + betree_Node_apply_messages_back'a self.left params node_id_cnt msgs_left + st st1 in let* (st3, ()) = - betree_node_apply_messages_back1 self.betree_internal_left params - node_id_cnt msgs_left st st2 in - let* len_right = betree_list_len_fwd (u64 & betree_message_t) msgs_right in - if len_right >= params.betree_params_min_flush_size + betree_Node_apply_messages_back1 self.left params node_id_cnt msgs_left + st st2 in + let* len_right = betree_List_len (u64 & betree_Message_t) msgs_right in + if len_right >= params.min_flush_size then let* (st4, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt0 msgs_right st3 in + betree_Node_apply_messages self.right params node_id_cnt0 msgs_right + st3 in let* (st5, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt0 msgs_right st3 st4 in + betree_Node_apply_messages_back'a self.right params node_id_cnt0 + msgs_right st3 st4 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt0 msgs_right st3 st5 in + betree_Node_apply_messages_back1 self.right params node_id_cnt0 + msgs_right st3 st5 in Return (st0, ()) else Return (st0, ()) else let* (st1, _) = - betree_node_apply_messages_fwd self.betree_internal_right params - node_id_cnt msgs_right st in + betree_Node_apply_messages self.right params node_id_cnt msgs_right st in let* (st2, (_, _)) = - betree_node_apply_messages_back'a self.betree_internal_right params - node_id_cnt msgs_right st st1 in + betree_Node_apply_messages_back'a self.right params node_id_cnt + msgs_right st st1 in let* _ = - betree_node_apply_messages_back1 self.betree_internal_right params - node_id_cnt msgs_right st st2 in + betree_Node_apply_messages_back1 self.right params node_id_cnt msgs_right + st st2 in Return (st0, ()) (** [betree_main::betree::Node::{5}::apply_messages]: forward function *) -and betree_node_apply_messages_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) : +and betree_Node_apply_messages + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) : Tot (result (state & unit)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st0, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st0, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st1, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st0 in + betree_Internal_flush node params node_id_cnt content0 st0 in let* (st2, (node0, _)) = - betree_internal_flush_back'a node params node_id_cnt content0 st0 st1 + betree_Internal_flush_back'a node params node_id_cnt content0 st0 st1 in - let* (st3, _) = - betree_store_internal_node_fwd node0.betree_internal_id content1 st2 in + let* (st3, _) = betree_store_internal_node node0.id content1 st2 in Return (st3, ()) else - let* (st1, _) = - betree_store_internal_node_fwd node.betree_internal_id content0 st0 in + let* (st1, _) = betree_store_internal_node node.id content0 st0 in Return (st1, ()) - | BetreeNodeLeaf node -> - let* (st0, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + | Betree_Node_Leaf node -> + let* (st0, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then - let* (st1, _) = - betree_leaf_split_fwd node content0 params node_id_cnt st0 in - let* (st2, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st1 in - betree_leaf_split_back0 node content0 params node_id_cnt st0 st2 + let* (st1, _) = betree_Leaf_split node content0 params node_id_cnt st0 in + let* (st2, _) = betree_store_leaf_node node.id Betree_List_Nil st1 in + betree_Leaf_split_back0 node content0 params node_id_cnt st0 st2 else - let* (st1, _) = - betree_store_leaf_node_fwd node.betree_leaf_id content0 st0 in + let* (st1, _) = betree_store_leaf_node node.id content0 st0 in Return (st1, ()) end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) -and betree_node_apply_messages_back'a - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) : - Tot (result (state & (betree_node_t & betree_node_id_counter_t))) +and betree_Node_apply_messages_back'a + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : + Tot (result (state & (betree_Node_t & betree_NodeIdCounter_t))) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st1, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st1, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st2, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st1 in + betree_Internal_flush node params node_id_cnt content0 st1 in let* (st3, (node0, node_id_cnt0)) = - betree_internal_flush_back'a node params node_id_cnt content0 st1 st2 + betree_Internal_flush_back'a node params node_id_cnt content0 st1 st2 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id content1 st3 in - Return (st0, (BetreeNodeInternal node0, node_id_cnt0)) + let* _ = betree_store_internal_node node0.id content1 st3 in + Return (st0, (Betree_Node_Internal node0, node_id_cnt0)) else - let* _ = - betree_store_internal_node_fwd node.betree_internal_id content0 st1 in - Return (st0, (BetreeNodeInternal node, node_id_cnt)) - | BetreeNodeLeaf node -> - let* (st1, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + let* _ = betree_store_internal_node node.id content0 st1 in + Return (st0, (Betree_Node_Internal node, node_id_cnt)) + | Betree_Node_Leaf node -> + let* (st1, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then let* (st2, new_node) = - betree_leaf_split_fwd node content0 params node_id_cnt st1 in - let* (st3, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st2 in - let* _ = betree_leaf_split_back0 node content0 params node_id_cnt st1 st3 + betree_Leaf_split node content0 params node_id_cnt st1 in + let* (st3, _) = betree_store_leaf_node node.id Betree_List_Nil st2 in + let* _ = betree_Leaf_split_back0 node content0 params node_id_cnt st1 st3 in let* (st4, node_id_cnt0) = - betree_leaf_split_back2 node content0 params node_id_cnt st1 st0 in - Return (st4, (BetreeNodeInternal new_node, node_id_cnt0)) + betree_Leaf_split_back2 node content0 params node_id_cnt st1 st0 in + Return (st4, (Betree_Node_Internal new_node, node_id_cnt0)) else - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id content0 st1 in - Return (st0, (BetreeNodeLeaf { node with betree_leaf_size = len }, - node_id_cnt)) + let* _ = betree_store_leaf_node node.id content0 st1 in + Return (st0, (Betree_Node_Leaf { node with size = len }, node_id_cnt)) end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 1 *) -and betree_node_apply_messages_back1 - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) - (msgs : betree_list_t (u64 & betree_message_t)) (st : state) (st0 : state) : +and betree_Node_apply_messages_back1 + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 & betree_Message_t)) (st : state) (st0 : state) : Tot (result (state & unit)) (decreases ( - betree_node_apply_messages_decreases self params node_id_cnt msgs st)) + betree_Node_apply_messages_decreases self params node_id_cnt msgs st)) = begin match self with - | BetreeNodeInternal node -> - let* (st1, content) = - betree_load_internal_node_fwd node.betree_internal_id st in - let* content0 = - betree_node_apply_messages_to_internal_fwd_back content msgs in - let* num_msgs = betree_list_len_fwd (u64 & betree_message_t) content0 in - if num_msgs >= params.betree_params_min_flush_size + | Betree_Node_Internal node -> + let* (st1, content) = betree_load_internal_node node.id st in + let* content0 = betree_Node_apply_messages_to_internal content msgs in + let* num_msgs = betree_List_len (u64 & betree_Message_t) content0 in + if num_msgs >= params.min_flush_size then let* (st2, content1) = - betree_internal_flush_fwd node params node_id_cnt content0 st1 in + betree_Internal_flush node params node_id_cnt content0 st1 in let* (st3, (node0, _)) = - betree_internal_flush_back'a node params node_id_cnt content0 st1 st2 + betree_Internal_flush_back'a node params node_id_cnt content0 st1 st2 in - let* _ = - betree_store_internal_node_fwd node0.betree_internal_id content1 st3 in - betree_internal_flush_back1 node params node_id_cnt content0 st1 st0 + let* _ = betree_store_internal_node node0.id content1 st3 in + betree_Internal_flush_back1 node params node_id_cnt content0 st1 st0 else - let* _ = - betree_store_internal_node_fwd node.betree_internal_id content0 st1 in + let* _ = betree_store_internal_node node.id content0 st1 in Return (st0, ()) - | BetreeNodeLeaf node -> - let* (st1, content) = betree_load_leaf_node_fwd node.betree_leaf_id st in - let* content0 = betree_node_apply_messages_to_leaf_fwd_back content msgs in - let* len = betree_list_len_fwd (u64 & u64) content0 in - let* i = u64_mul 2 params.betree_params_split_size in + | Betree_Node_Leaf node -> + let* (st1, content) = betree_load_leaf_node node.id st in + let* content0 = betree_Node_apply_messages_to_leaf content msgs in + let* len = betree_List_len (u64 & u64) content0 in + let* i = u64_mul 2 params.split_size in if len >= i then - let* (st2, _) = - betree_leaf_split_fwd node content0 params node_id_cnt st1 in - let* (st3, _) = - betree_store_leaf_node_fwd node.betree_leaf_id BetreeListNil st2 in - let* _ = betree_leaf_split_back0 node content0 params node_id_cnt st1 st3 + let* (st2, _) = betree_Leaf_split node content0 params node_id_cnt st1 in + let* (st3, _) = betree_store_leaf_node node.id Betree_List_Nil st2 in + let* _ = betree_Leaf_split_back0 node content0 params node_id_cnt st1 st3 in - betree_leaf_split_back1 node content0 params node_id_cnt st1 st0 + betree_Leaf_split_back1 node content0 params node_id_cnt st1 st0 else - let* _ = betree_store_leaf_node_fwd node.betree_leaf_id content0 st1 in - Return (st0, ()) + let* _ = betree_store_leaf_node node.id content0 st1 in Return (st0, ()) end (** [betree_main::betree::Node::{5}::apply]: forward function *) -let betree_node_apply_fwd - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) : +let betree_Node_apply + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : result (state & unit) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st0, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* (st1, (_, _)) = - betree_node_apply_messages_back'a self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back'a self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st0 in - betree_node_apply_messages_back1 self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 (** [betree_main::betree::Node::{5}::apply]: backward function 0 *) -let betree_node_apply_back'a - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) (st0 : state) : - result (state & (betree_node_t & betree_node_id_counter_t)) +let betree_Node_apply_back'a + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) (st0 : state) : + result (state & (betree_Node_t & betree_NodeIdCounter_t)) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st1, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* (st2, (self0, node_id_cnt0)) = - betree_node_apply_messages_back'a self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back'a self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 in let* _ = - betree_node_apply_messages_back1 self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st2 in Return (st0, (self0, node_id_cnt0)) (** [betree_main::betree::Node::{5}::apply]: backward function 1 *) -let betree_node_apply_back1 - (self : betree_node_t) (params : betree_params_t) - (node_id_cnt : betree_node_id_counter_t) (key : u64) - (new_msg : betree_message_t) (st : state) (st0 : state) : +let betree_Node_apply_back1 + (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) (st0 : state) : result (state & unit) = - let l = BetreeListNil in + let l = Betree_List_Nil in let* (st1, _) = - betree_node_apply_messages_fwd self params node_id_cnt (BetreeListCons - (key, new_msg) l) st in + betree_Node_apply_messages self params node_id_cnt (Betree_List_Cons (key, + new_msg) l) st in let* (st2, (_, _)) = - betree_node_apply_messages_back'a self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back'a self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 in let* _ = - betree_node_apply_messages_back1 self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st2 in Return (st0, ()) (** [betree_main::betree::BeTree::{6}::new]: forward function *) -let betree_be_tree_new_fwd +let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = - let* node_id_cnt = betree_node_id_counter_new_fwd in - let* id = betree_node_id_counter_fresh_id_fwd node_id_cnt in - let* (st0, _) = betree_store_leaf_node_fwd id BetreeListNil st in - let* node_id_cnt0 = betree_node_id_counter_fresh_id_back node_id_cnt in + let* node_id_cnt = betree_NodeIdCounter_new in + let* id = betree_NodeIdCounter_fresh_id node_id_cnt in + let* (st0, _) = betree_store_leaf_node id Betree_List_Nil st in + let* node_id_cnt0 = betree_NodeIdCounter_fresh_id_back node_id_cnt in Return (st0, { - betree_be_tree_params = - { - betree_params_min_flush_size = min_flush_size; - betree_params_split_size = split_size - }; - betree_be_tree_node_id_cnt = node_id_cnt0; - betree_be_tree_root = - (BetreeNodeLeaf { betree_leaf_id = id; betree_leaf_size = 0 }) + params = { min_flush_size = min_flush_size; split_size = split_size }; + node_id_cnt = node_id_cnt0; + root = (Betree_Node_Leaf { id = id; size = 0 }) }) (** [betree_main::betree::BeTree::{6}::apply]: forward function *) -let betree_be_tree_apply_fwd - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) : +let betree_BeTree_apply + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) = let* (st0, _) = - betree_node_apply_fwd self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply self.root self.params self.node_id_cnt key msg st in let* (st1, (_, _)) = - betree_node_apply_back'a self.betree_be_tree_root - self.betree_be_tree_params self.betree_be_tree_node_id_cnt key msg st st0 - in - betree_node_apply_back1 self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st st1 + betree_Node_apply_back'a self.root self.params self.node_id_cnt key msg st + st0 in + betree_Node_apply_back1 self.root self.params self.node_id_cnt key msg st st1 (** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) -let betree_be_tree_apply_back - (self : betree_be_tree_t) (key : u64) (msg : betree_message_t) (st : state) +let betree_BeTree_apply_back + (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) (st0 : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = let* (st1, _) = - betree_node_apply_fwd self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st in + betree_Node_apply self.root self.params self.node_id_cnt key msg st in let* (st2, (n, nic)) = - betree_node_apply_back'a self.betree_be_tree_root - self.betree_be_tree_params self.betree_be_tree_node_id_cnt key msg st st1 - in + betree_Node_apply_back'a self.root self.params self.node_id_cnt key msg st + st1 in let* _ = - betree_node_apply_back1 self.betree_be_tree_root self.betree_be_tree_params - self.betree_be_tree_node_id_cnt key msg st st2 in - Return (st0, - { self with betree_be_tree_node_id_cnt = nic; betree_be_tree_root = n }) + betree_Node_apply_back1 self.root self.params self.node_id_cnt key msg st + st2 in + Return (st0, { self with node_id_cnt = nic; root = n }) (** [betree_main::betree::BeTree::{6}::insert]: forward function *) -let betree_be_tree_insert_fwd - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) : +let betree_BeTree_insert + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageInsert value) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Insert value) st + in let* (st1, _) = - betree_be_tree_apply_back self key (BetreeMessageInsert value) st st0 in + betree_BeTree_apply_back self key (Betree_Message_Insert value) st st0 in Return (st1, ()) (** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) -let betree_be_tree_insert_back - (self : betree_be_tree_t) (key : u64) (value : u64) (st : state) - (st0 : state) : - result (state & betree_be_tree_t) +let betree_BeTree_insert_back + (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) (st0 : state) + : + result (state & betree_BeTree_t) = - let* (st1, _) = - betree_be_tree_apply_fwd self key (BetreeMessageInsert value) st in + let* (st1, _) = betree_BeTree_apply self key (Betree_Message_Insert value) st + in let* (_, self0) = - betree_be_tree_apply_back self key (BetreeMessageInsert value) st st1 in + betree_BeTree_apply_back self key (Betree_Message_Insert value) st st1 in Return (st0, self0) (** [betree_main::betree::BeTree::{6}::delete]: forward function *) -let betree_be_tree_delete_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : result (state & unit) = - let* (st0, _) = betree_be_tree_apply_fwd self key BetreeMessageDelete st in - let* (st1, _) = betree_be_tree_apply_back self key BetreeMessageDelete st st0 - in +let betree_BeTree_delete + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = + let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in + let* (st1, _) = + betree_BeTree_apply_back self key Betree_Message_Delete st st0 in Return (st1, ()) (** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) -let betree_be_tree_delete_back - (self : betree_be_tree_t) (key : u64) (st : state) (st0 : state) : - result (state & betree_be_tree_t) +let betree_BeTree_delete_back + (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : + result (state & betree_BeTree_t) = - let* (st1, _) = betree_be_tree_apply_fwd self key BetreeMessageDelete st in + let* (st1, _) = betree_BeTree_apply self key Betree_Message_Delete st in let* (_, self0) = - betree_be_tree_apply_back self key BetreeMessageDelete st st1 in + betree_BeTree_apply_back self key Betree_Message_Delete st st1 in Return (st0, self0) (** [betree_main::betree::BeTree::{6}::upsert]: forward function *) -let betree_be_tree_upsert_fwd - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : result (state & unit) = - let* (st0, _) = - betree_be_tree_apply_fwd self key (BetreeMessageUpsert upd) st in + let* (st0, _) = betree_BeTree_apply self key (Betree_Message_Upsert upd) st + in let* (st1, _) = - betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st st0 in + betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st0 in Return (st1, ()) (** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) -let betree_be_tree_upsert_back - (self : betree_be_tree_t) (key : u64) (upd : betree_upsert_fun_state_t) +let betree_BeTree_upsert_back + (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) (st0 : state) : - result (state & betree_be_tree_t) + result (state & betree_BeTree_t) = - let* (st1, _) = - betree_be_tree_apply_fwd self key (BetreeMessageUpsert upd) st in + let* (st1, _) = betree_BeTree_apply self key (Betree_Message_Upsert upd) st + in let* (_, self0) = - betree_be_tree_apply_back self key (BetreeMessageUpsert upd) st st1 in + betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st1 in Return (st0, self0) (** [betree_main::betree::BeTree::{6}::lookup]: forward function *) -let betree_be_tree_lookup_fwd - (self : betree_be_tree_t) (key : u64) (st : state) : +let betree_BeTree_lookup + (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = - betree_node_lookup_fwd self.betree_be_tree_root key st + betree_Node_lookup self.root key st (** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) -let betree_be_tree_lookup_back - (self : betree_be_tree_t) (key : u64) (st : state) (st0 : state) : - result (state & betree_be_tree_t) +let betree_BeTree_lookup_back + (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : + result (state & betree_BeTree_t) = - let* (st1, n) = betree_node_lookup_back self.betree_be_tree_root key st st0 - in - Return (st1, { self with betree_be_tree_root = n }) + let* (st1, n) = betree_Node_lookup_back self.root key st st0 in + Return (st1, { self with root = n }) (** [betree_main::main]: forward function *) -let main_fwd : result unit = +let main : result unit = Return () (** Unit test for [betree_main::main] *) -let _ = assert_norm (main_fwd = Return ()) +let _ = assert_norm (main = Return ()) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti index c33cf225..c5d0a814 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti @@ -7,24 +7,24 @@ include BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree_utils::load_internal_node]: forward function *) -val betree_utils_load_internal_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & betree_message_t))) +val betree_utils_load_internal_node + : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) (** [betree_main::betree_utils::store_internal_node]: forward function *) -val betree_utils_store_internal_node_fwd +val betree_utils_store_internal_node : - u64 -> betree_list_t (u64 & betree_message_t) -> state -> result (state & + u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & unit) (** [betree_main::betree_utils::load_leaf_node]: forward function *) -val betree_utils_load_leaf_node_fwd - : u64 -> state -> result (state & (betree_list_t (u64 & u64))) +val betree_utils_load_leaf_node + : u64 -> state -> result (state & (betree_List_t (u64 & u64))) (** [betree_main::betree_utils::store_leaf_node]: forward function *) -val betree_utils_store_leaf_node_fwd - : u64 -> betree_list_t (u64 & u64) -> state -> result (state & unit) +val betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) (** [core::option::Option::{0}::unwrap]: forward function *) -val core_option_option_unwrap_fwd +val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti index a937c726..9320f6b7 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti @@ -6,53 +6,47 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [betree_main::betree::List] *) -type betree_list_t (t : Type0) = -| BetreeListCons : t -> betree_list_t t -> betree_list_t t -| BetreeListNil : betree_list_t t +type betree_List_t (t : Type0) = +| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t +| Betree_List_Nil : betree_List_t t (** [betree_main::betree::UpsertFunState] *) -type betree_upsert_fun_state_t = -| BetreeUpsertFunStateAdd : u64 -> betree_upsert_fun_state_t -| BetreeUpsertFunStateSub : u64 -> betree_upsert_fun_state_t +type betree_UpsertFunState_t = +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t (** [betree_main::betree::Message] *) -type betree_message_t = -| BetreeMessageInsert : u64 -> betree_message_t -| BetreeMessageDelete : betree_message_t -| BetreeMessageUpsert : betree_upsert_fun_state_t -> betree_message_t +type betree_Message_t = +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t (** [betree_main::betree::Leaf] *) -type betree_leaf_t = { betree_leaf_id : u64; betree_leaf_size : u64; } +type betree_Leaf_t = { id : u64; size : u64; } (** [betree_main::betree::Internal] *) -type betree_internal_t = +type betree_Internal_t = { - betree_internal_id : u64; - betree_internal_pivot : u64; - betree_internal_left : betree_node_t; - betree_internal_right : betree_node_t; + id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; } (** [betree_main::betree::Node] *) -and betree_node_t = -| BetreeNodeInternal : betree_internal_t -> betree_node_t -| BetreeNodeLeaf : betree_leaf_t -> betree_node_t +and betree_Node_t = +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t (** [betree_main::betree::Params] *) -type betree_params_t = -{ - betree_params_min_flush_size : u64; betree_params_split_size : u64; -} +type betree_Params_t = { min_flush_size : u64; split_size : u64; } (** [betree_main::betree::NodeIdCounter] *) -type betree_node_id_counter_t = { betree_node_id_counter_next_node_id : u64; } +type betree_NodeIdCounter_t = { next_node_id : u64; } (** [betree_main::betree::BeTree] *) -type betree_be_tree_t = +type betree_BeTree_t = { - betree_be_tree_params : betree_params_t; - betree_be_tree_node_id_cnt : betree_node_id_counter_t; - betree_be_tree_root : betree_node_t; + params : betree_Params_t; + node_id_cnt : betree_NodeIdCounter_t; + root : betree_Node_t; } (** The state type used in the state-error monad *) diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 3110b247..71d75c11 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -707,5 +707,7 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == - alloc_vec_Vec_update_usize v i x) = + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = admit() diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 3110b247..71d75c11 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -707,5 +707,7 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == - alloc_vec_Vec_update_usize v i x) = + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = admit() diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 3110b247..71d75c11 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -707,5 +707,7 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == - alloc_vec_Vec_update_usize v i x) = + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = admit() -- cgit v1.2.3 From 1c55079dac0c51e45f7d77c67bfdbdb8c52ed192 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 13:26:08 +0200 Subject: Update Primitives.v --- backends/coq/Primitives.v | 402 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 342 insertions(+), 60 deletions(-) diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index b92eb967..8e0e973d 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -408,12 +410,75 @@ Definition core_i64_max := i64_max %i64. Definition core_i128_max := i64_max %i128. Axiom core_isize_max : isize. (** TODO *) -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; +}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -436,51 +501,47 @@ Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. (* For initialization *) Axiom array_repeat : forall {T : Type} (n : usize) (x : T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -491,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. -- cgit v1.2.3 From 49117ba254679f98938223711810191c3f7d788f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 13:34:03 +0200 Subject: Regenerate the Coq test files --- backends/coq/Primitives.v | 2 +- tests/coq/array/Array_Funs.v | 402 +++++---- tests/coq/array/Array_Types.v | 4 +- tests/coq/array/Primitives.v | 405 +++++++-- tests/coq/betree/BetreeMain_Funs.v | 1065 ++++++++++++------------ tests/coq/betree/BetreeMain_Opaque.v | 18 +- tests/coq/betree/BetreeMain_Types.v | 92 +- tests/coq/betree/Primitives.v | 405 +++++++-- tests/coq/hashmap/Hashmap_Funs.v | 514 ++++++------ tests/coq/hashmap/Hashmap_Types.v | 30 +- tests/coq/hashmap/Primitives.v | 405 +++++++-- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 604 +++++++------- tests/coq/hashmap_on_disk/HashmapMain_Opaque.v | 8 +- tests/coq/hashmap_on_disk/HashmapMain_Types.v | 32 +- tests/coq/hashmap_on_disk/Primitives.v | 405 +++++++-- tests/coq/misc/Constants.v | 56 +- tests/coq/misc/External_Funs.v | 39 +- tests/coq/misc/External_Opaque.v | 8 +- tests/coq/misc/External_Types.v | 2 +- tests/coq/misc/Loops.v | 412 ++++----- tests/coq/misc/NoNestedBorrows.v | 305 ++++--- tests/coq/misc/Paper.v | 67 +- tests/coq/misc/PoloniusList.v | 22 +- tests/coq/misc/Primitives.v | 405 +++++++-- 24 files changed, 3589 insertions(+), 2118 deletions(-) diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 8e0e973d..85e38f01 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -499,7 +499,7 @@ Qed. Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. (* For initialization *) -Axiom array_repeat : forall {T : Type} (n : usize) (x : T), array T n. +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). diff --git a/tests/coq/array/Array_Funs.v b/tests/coq/array/Array_Funs.v index 6ff3066a..9980a6e8 100644 --- a/tests/coq/array/Array_Funs.v +++ b/tests/coq/array/Array_Funs.v @@ -10,16 +10,21 @@ Require Export Array_Types. Import Array_Types. Module Array_Funs. +(** [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition incr (x : u32) : result u32 := + u32_add x 1%u32. + (** [array::array_to_shared_slice_]: forward function *) -Definition array_to_shared_slice__fwd +Definition array_to_shared_slice_ (T : Type) (s : array T 32%usize) : result (slice T) := - array_to_slice_shared T 32%usize s + array_to_slice T 32%usize s . (** [array::array_to_mut_slice_]: forward function *) -Definition array_to_mut_slice__fwd +Definition array_to_mut_slice_ (T : Type) (s : array T 32%usize) : result (slice T) := - array_to_slice_mut_fwd T 32%usize s + array_to_slice T 32%usize s . (** [array::array_to_mut_slice_]: backward function 0 *) @@ -27,58 +32,44 @@ Definition array_to_mut_slice__back (T : Type) (s : array T 32%usize) (ret : slice T) : result (array T 32%usize) := - array_to_slice_mut_back T 32%usize s ret + array_from_slice T 32%usize s ret . (** [array::array_len]: forward function *) -Definition array_len_fwd (T : Type) (s : array T 32%usize) : result usize := - s0 <- array_to_slice_shared T 32%usize s; let i := slice_len T s0 in Return i +Definition array_len (T : Type) (s : array T 32%usize) : result usize := + s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i . (** [array::shared_array_len]: forward function *) -Definition shared_array_len_fwd - (T : Type) (s : array T 32%usize) : result usize := - s0 <- array_to_slice_shared T 32%usize s; let i := slice_len T s0 in Return i +Definition shared_array_len (T : Type) (s : array T 32%usize) : result usize := + s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i . (** [array::shared_slice_len]: forward function *) -Definition shared_slice_len_fwd (T : Type) (s : slice T) : result usize := +Definition shared_slice_len (T : Type) (s : slice T) : result usize := let i := slice_len T s in Return i . (** [array::index_array_shared]: forward function *) -Definition index_array_shared_fwd +Definition index_array_shared (T : Type) (s : array T 32%usize) (i : usize) : result T := - array_index_shared T 32%usize s i + array_index_usize T 32%usize s i . (** [array::index_array_u32]: forward function *) -Definition index_array_u32_fwd - (s : array u32 32%usize) (i : usize) : result u32 := - array_index_shared u32 32%usize s i -. - -(** [array::index_array_generic]: forward function *) -Definition index_array_generic_fwd - (N : usize) (s : array u32 N) (i : usize) : result u32 := - array_index_shared u32 N s i -. - -(** [array::index_array_generic_call]: forward function *) -Definition index_array_generic_call_fwd - (N : usize) (s : array u32 N) (i : usize) : result u32 := - index_array_generic_fwd N s i +Definition index_array_u32 (s : array u32 32%usize) (i : usize) : result u32 := + array_index_usize u32 32%usize s i . (** [array::index_array_copy]: forward function *) -Definition index_array_copy_fwd (x : array u32 32%usize) : result u32 := - array_index_shared u32 32%usize x 0%usize +Definition index_array_copy (x : array u32 32%usize) : result u32 := + array_index_usize u32 32%usize x 0%usize . (** [array::index_mut_array]: forward function *) -Definition index_mut_array_fwd +Definition index_mut_array (T : Type) (s : array T 32%usize) (i : usize) : result T := - array_index_mut_fwd T 32%usize s i + array_index_usize T 32%usize s i . (** [array::index_mut_array]: backward function 0 *) @@ -86,298 +77,314 @@ Definition index_mut_array_back (T : Type) (s : array T 32%usize) (i : usize) (ret : T) : result (array T 32%usize) := - array_index_mut_back T 32%usize s i ret + array_update_usize T 32%usize s i ret . (** [array::index_slice]: forward function *) -Definition index_slice_fwd (T : Type) (s : slice T) (i : usize) : result T := - slice_index_shared T s i +Definition index_slice (T : Type) (s : slice T) (i : usize) : result T := + slice_index_usize T s i . (** [array::index_mut_slice]: forward function *) -Definition index_mut_slice_fwd - (T : Type) (s : slice T) (i : usize) : result T := - slice_index_mut_fwd T s i +Definition index_mut_slice (T : Type) (s : slice T) (i : usize) : result T := + slice_index_usize T s i . (** [array::index_mut_slice]: backward function 0 *) Definition index_mut_slice_back (T : Type) (s : slice T) (i : usize) (ret : T) : result (slice T) := - slice_index_mut_back T s i ret + slice_update_usize T s i ret . (** [array::slice_subslice_shared_]: forward function *) -Definition slice_subslice_shared__fwd - (x : slice u32) (y : usize) (z : usize) : result (slice u32) := - slice_subslice_shared u32 x (mk_range y z) +Definition slice_subslice_shared_ + (n : nat) (x : slice u32) (y : usize) (z : usize) : result (slice u32) := + core_slice_index_Slice_index u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . (** [array::slice_subslice_mut_]: forward function *) -Definition slice_subslice_mut__fwd - (x : slice u32) (y : usize) (z : usize) : result (slice u32) := - slice_subslice_mut_fwd u32 x (mk_range y z) +Definition slice_subslice_mut_ + (n : nat) (x : slice u32) (y : usize) (z : usize) : result (slice u32) := + core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . (** [array::slice_subslice_mut_]: backward function 0 *) Definition slice_subslice_mut__back - (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : + (n : nat) (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : result (slice u32) := - slice_subslice_mut_back u32 x (mk_range y z) ret + core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret . (** [array::array_to_slice_shared_]: forward function *) -Definition array_to_slice_shared__fwd +Definition array_to_slice_shared_ (x : array u32 32%usize) : result (slice u32) := - array_to_slice_shared u32 32%usize x + array_to_slice u32 32%usize x . (** [array::array_to_slice_mut_]: forward function *) -Definition array_to_slice_mut__fwd - (x : array u32 32%usize) : result (slice u32) := - array_to_slice_mut_fwd u32 32%usize x +Definition array_to_slice_mut_ (x : array u32 32%usize) : result (slice u32) := + array_to_slice u32 32%usize x . (** [array::array_to_slice_mut_]: backward function 0 *) Definition array_to_slice_mut__back (x : array u32 32%usize) (ret : slice u32) : result (array u32 32%usize) := - array_to_slice_mut_back u32 32%usize x ret + array_from_slice u32 32%usize x ret . (** [array::array_subslice_shared_]: forward function *) -Definition array_subslice_shared__fwd - (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := - array_subslice_shared u32 32%usize x (mk_range y z) +Definition array_subslice_shared_ + (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) : + result (slice u32) + := + core_array_Array_index u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . (** [array::array_subslice_mut_]: forward function *) -Definition array_subslice_mut__fwd - (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := - array_subslice_mut_fwd u32 32%usize x (mk_range y z) +Definition array_subslice_mut_ + (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) : + result (slice u32) + := + core_array_Array_index_mut u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . (** [array::array_subslice_mut_]: backward function 0 *) Definition array_subslice_mut__back - (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) : + (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) + : result (array u32 32%usize) := - array_subslice_mut_back u32 32%usize x (mk_range y z) ret + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret . (** [array::index_slice_0]: forward function *) -Definition index_slice_0_fwd (T : Type) (s : slice T) : result T := - slice_index_shared T s 0%usize +Definition index_slice_0 (T : Type) (s : slice T) : result T := + slice_index_usize T s 0%usize . (** [array::index_array_0]: forward function *) -Definition index_array_0_fwd (T : Type) (s : array T 32%usize) : result T := - array_index_shared T 32%usize s 0%usize +Definition index_array_0 (T : Type) (s : array T 32%usize) : result T := + array_index_usize T 32%usize s 0%usize . (** [array::index_index_array]: forward function *) -Definition index_index_array_fwd +Definition index_index_array (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : result u32 := - a <- array_index_shared (array u32 32%usize) 32%usize s i; - array_index_shared u32 32%usize a j + a <- array_index_usize (array u32 32%usize) 32%usize s i; + array_index_usize u32 32%usize a j . -(** [array::const_gen_ret]: forward function *) -Definition const_gen_ret_fwd (N : usize) : result usize := - Return N. - (** [array::update_update_array]: forward function *) -Definition update_update_array_fwd +Definition update_update_array (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : result unit := - a <- array_index_mut_fwd (array u32 32%usize) 32%usize s i; - a0 <- array_index_mut_back u32 32%usize a j 0%u32; - _ <- array_index_mut_back (array u32 32%usize) 32%usize s i a0; + a <- array_index_usize (array u32 32%usize) 32%usize s i; + a0 <- array_update_usize u32 32%usize a j 0%u32; + _ <- array_update_usize (array u32 32%usize) 32%usize s i a0; Return tt . (** [array::array_local_deep_copy]: forward function *) -Definition array_local_deep_copy_fwd (x : array u32 32%usize) : result unit := +Definition array_local_deep_copy (x : array u32 32%usize) : result unit := Return tt . (** [array::take_array]: forward function *) -Definition take_array_fwd (a : array u32 2%usize) : result unit := +Definition take_array (a : array u32 2%usize) : result unit := Return tt. (** [array::take_array_borrow]: forward function *) -Definition take_array_borrow_fwd (a : array u32 2%usize) : result unit := +Definition take_array_borrow (a : array u32 2%usize) : result unit := Return tt . (** [array::take_slice]: forward function *) -Definition take_slice_fwd (s : slice u32) : result unit := +Definition take_slice (s : slice u32) : result unit := Return tt. (** [array::take_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition take_mut_slice_fwd_back (s : slice u32) : result (slice u32) := - Return s -. +Definition take_mut_slice (s : slice u32) : result (slice u32) := + Return s. (** [array::take_all]: forward function *) -Definition take_all_fwd : result unit := - _ <- take_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - _ <- take_array_borrow_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s <- - array_to_slice_shared u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - _ <- take_slice_fwd s; - s0 <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s1 <- take_mut_slice_fwd_back s0; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s1; +Definition take_all : result unit := + _ <- take_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + _ <- take_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + _ <- take_slice s; + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s1 <- take_mut_slice s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; Return tt . (** [array::index_array]: forward function *) -Definition index_array_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize +Definition index_array (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize . (** [array::index_array_borrow]: forward function *) -Definition index_array_borrow_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize +Definition index_array_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize . (** [array::index_slice_u32_0]: forward function *) -Definition index_slice_u32_0_fwd (x : slice u32) : result u32 := - slice_index_shared u32 x 0%usize +Definition index_slice_u32_0 (x : slice u32) : result u32 := + slice_index_usize u32 x 0%usize . (** [array::index_mut_slice_u32_0]: forward function *) -Definition index_mut_slice_u32_0_fwd (x : slice u32) : result u32 := - slice_index_shared u32 x 0%usize +Definition index_mut_slice_u32_0 (x : slice u32) : result u32 := + slice_index_usize u32 x 0%usize . (** [array::index_mut_slice_u32_0]: backward function 0 *) Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := - _ <- slice_index_shared u32 x 0%usize; Return x + _ <- slice_index_usize u32 x 0%usize; Return x . (** [array::index_all]: forward function *) -Definition index_all_fwd : result u32 := - i <- index_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i0 <- index_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); +Definition index_all : result u32 := + i <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i0 <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); i1 <- u32_add i i0; - i2 <- index_array_borrow_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i2 <- index_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); i3 <- u32_add i1 i2; - s <- - array_to_slice_shared u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i4 <- index_slice_u32_0_fwd s; + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i4 <- index_slice_u32_0 s; i5 <- u32_add i3 i4; - s0 <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i6 <- index_mut_slice_u32_0_fwd s0; + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i6 <- index_mut_slice_u32_0 s0; i7 <- u32_add i5 i6; s1 <- index_mut_slice_u32_0_back s0; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s1; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; Return i7 . (** [array::update_array]: forward function *) -Definition update_array_fwd (x : array u32 2%usize) : result unit := - _ <- array_index_mut_back u32 2%usize x 0%usize 1%u32; Return tt +Definition update_array (x : array u32 2%usize) : result unit := + _ <- array_update_usize u32 2%usize x 0%usize 1%u32; Return tt . (** [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition update_array_mut_borrow_fwd_back +Definition update_array_mut_borrow (x : array u32 2%usize) : result (array u32 2%usize) := - array_index_mut_back u32 2%usize x 0%usize 1%u32 + array_update_usize u32 2%usize x 0%usize 1%u32 . (** [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition update_mut_slice_fwd_back (x : slice u32) : result (slice u32) := - slice_index_mut_back u32 x 0%usize 1%u32 +Definition update_mut_slice (x : slice u32) : result (slice u32) := + slice_update_usize u32 x 0%usize 1%u32 . (** [array::update_all]: forward function *) -Definition update_all_fwd : result unit := - _ <- update_array_fwd (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - x <- - update_array_mut_borrow_fwd_back (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s <- array_to_slice_mut_fwd u32 2%usize x; - s0 <- update_mut_slice_fwd_back s; - _ <- array_to_slice_mut_back u32 2%usize x s0; +Definition update_all : result unit := + _ <- update_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + x <- update_array_mut_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s <- array_to_slice u32 2%usize x; + s0 <- update_mut_slice s; + _ <- array_from_slice u32 2%usize x s0; Return tt . (** [array::range_all]: forward function *) -Definition range_all_fwd : result unit := +Definition range_all (n : nat) : result unit := s <- - array_subslice_mut_fwd u32 4%usize - (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) (mk_range 1%usize - 3%usize); - s0 <- update_mut_slice_fwd_back s; + core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) + {| + core_ops_range_Range_start := 1%usize; + core_ops_range_Range_end_ := 3%usize + |}; + s0 <- update_mut_slice s; _ <- - array_subslice_mut_back u32 4%usize - (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) (mk_range 1%usize - 3%usize) s0; + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) + {| + core_ops_range_Range_start := 1%usize; + core_ops_range_Range_end_ := 3%usize + |} s0; Return tt . (** [array::deref_array_borrow]: forward function *) -Definition deref_array_borrow_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize +Definition deref_array_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize . (** [array::deref_array_mut_borrow]: forward function *) -Definition deref_array_mut_borrow_fwd (x : array u32 2%usize) : result u32 := - array_index_shared u32 2%usize x 0%usize +Definition deref_array_mut_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize . (** [array::deref_array_mut_borrow]: backward function 0 *) Definition deref_array_mut_borrow_back (x : array u32 2%usize) : result (array u32 2%usize) := - _ <- array_index_shared u32 2%usize x 0%usize; Return x + _ <- array_index_usize u32 2%usize x 0%usize; Return x . (** [array::take_array_t]: forward function *) -Definition take_array_t_fwd (a : array T_t 2%usize) : result unit := +Definition take_array_t (a : array AB_t 2%usize) : result unit := Return tt. (** [array::non_copyable_array]: forward function *) -Definition non_copyable_array_fwd : result unit := - _ <- take_array_t_fwd (mk_array T_t 2%usize [ TA; TB ]); Return tt +Definition non_copyable_array : result unit := + _ <- take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]); Return tt . (** [array::sum]: loop 0: forward function *) -Fixpoint sum_loop_fwd - (n : nat) (s : slice u32) (sum : u32) (i : usize) : result u32 := +Fixpoint sum_loop + (n : nat) (s : slice u32) (sum0 : u32) (i : usize) : result u32 := match n with | O => Fail_ OutOfFuel | S n0 => let i0 := slice_len u32 s in if i s< i0 then ( - i1 <- slice_index_shared u32 s i; - sum0 <- u32_add sum i1; + i1 <- slice_index_usize u32 s i; + sum1 <- u32_add sum0 i1; i2 <- usize_add i 1%usize; - sum_loop_fwd n0 s sum0 i2) - else Return sum + sum_loop n0 s sum1 i2) + else Return sum0 end . (** [array::sum]: forward function *) -Definition sum_fwd (n : nat) (s : slice u32) : result u32 := - sum_loop_fwd n s 0%u32 0%usize +Definition sum (n : nat) (s : slice u32) : result u32 := + sum_loop n s 0%u32 0%usize . (** [array::sum2]: loop 0: forward function *) -Fixpoint sum2_loop_fwd - (n : nat) (s : slice u32) (s2 : slice u32) (sum : u32) (i : usize) : +Fixpoint sum2_loop + (n : nat) (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : result u32 := match n with @@ -386,69 +393,64 @@ Fixpoint sum2_loop_fwd let i0 := slice_len u32 s in if i s< i0 then ( - i1 <- slice_index_shared u32 s i; - i2 <- slice_index_shared u32 s2 i; + i1 <- slice_index_usize u32 s i; + i2 <- slice_index_usize u32 s2 i; i3 <- u32_add i1 i2; - sum0 <- u32_add sum i3; + sum1 <- u32_add sum0 i3; i4 <- usize_add i 1%usize; - sum2_loop_fwd n0 s s2 sum0 i4) - else Return sum + sum2_loop n0 s s2 sum1 i4) + else Return sum0 end . (** [array::sum2]: forward function *) -Definition sum2_fwd (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := +Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := let i := slice_len u32 s in let i0 := slice_len u32 s2 in - if negb (i s= i0) then Fail_ Failure else sum2_loop_fwd n s s2 0%u32 0%usize + if negb (i s= i0) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize . (** [array::f0]: forward function *) -Definition f0_fwd : result unit := - s <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); - s0 <- slice_index_mut_back u32 s 0%usize 1%u32; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) - s0; +Definition f0 : result unit := + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); + s0 <- slice_update_usize u32 s 0%usize 1%u32; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) s0; Return tt . (** [array::f1]: forward function *) -Definition f1_fwd : result unit := +Definition f1 : result unit := _ <- - array_index_mut_back u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) + array_update_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) 0%usize 1%u32; Return tt . (** [array::f2]: forward function *) -Definition f2_fwd (i : u32) : result unit := +Definition f2 (i : u32) : result unit := Return tt. (** [array::f4]: forward function *) -Definition f4_fwd - (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := - array_subslice_shared u32 32%usize x (mk_range y z) +Definition f4 + (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) : + result (slice u32) + := + core_array_Array_index u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . (** [array::f3]: forward function *) -Definition f3_fwd (n : nat) : result u32 := +Definition f3 (n : nat) : result u32 := i <- - array_index_shared u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) + array_index_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) 0%usize; - _ <- f2_fwd i; - s <- - array_to_slice_shared u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); - s0 <- - f4_fwd - (mk_array u32 32%usize [ - 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; - 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; - 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; 0%u32; - 0%u32; 0%u32 - ]) 16%usize 18%usize; - sum2_fwd n s s0 + _ <- f2 i; + let b := array_repeat u32 32%usize 0%u32 in + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); + s0 <- f4 n b 16%usize 18%usize; + sum2 n s s0 . (** [array::SZ] *) @@ -456,24 +458,18 @@ Definition sz_body : result usize := Return 32%usize. Definition sz_c : usize := sz_body%global. (** [array::f5]: forward function *) -Definition f5_fwd (x : array u32 32%usize) : result u32 := - array_index_shared u32 32%usize x 0%usize +Definition f5 (x : array u32 32%usize) : result u32 := + array_index_usize u32 32%usize x 0%usize . (** [array::ite]: forward function *) -Definition ite_fwd : result unit := - s <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s0 <- - array_to_slice_mut_fwd u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); +Definition ite : result unit := + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); s1 <- index_mut_slice_u32_0_back s0; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s1; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; s2 <- index_mut_slice_u32_0_back s; - _ <- - array_to_slice_mut_back u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) - s2; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s2; Return tt . diff --git a/tests/coq/array/Array_Types.v b/tests/coq/array/Array_Types.v index 7be6dc9b..a13d64e6 100644 --- a/tests/coq/array/Array_Types.v +++ b/tests/coq/array/Array_Types.v @@ -8,7 +8,7 @@ Import ListNotations. Local Open Scope Primitives_scope. Module Array_Types. -(** [array::T] *) -Inductive T_t := | TA : T_t | TB : T_t. +(** [array::AB] *) +Inductive AB_t := | AB_A : AB_t | AB_B : AB_t. End Array_Types . diff --git a/tests/coq/array/Primitives.v b/tests/coq/array/Primitives.v index 8d6c9c8d..85e38f01 100644 --- a/tests/coq/array/Primitives.v +++ b/tests/coq/array/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -408,12 +410,75 @@ Definition core_i64_max := i64_max %i64. Definition core_i128_max := i64_max %i128. Axiom core_isize_max : isize. (** TODO *) -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -433,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -488,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index cfa1f8fb..261e8270 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -13,41 +13,41 @@ Import BetreeMain_Opaque. Module BetreeMain_Funs. (** [betree_main::betree::load_internal_node]: forward function *) -Definition betree_load_internal_node_fwd +Definition betree_load_internal_node (id : u64) (st : state) : - result (state * (Betree_list_t (u64 * Betree_message_t))) + result (state * (betree_List_t (u64 * betree_Message_t))) := - betree_utils_load_internal_node_fwd id st + betree_utils_load_internal_node id st . (** [betree_main::betree::store_internal_node]: forward function *) -Definition betree_store_internal_node_fwd - (id : u64) (content : Betree_list_t (u64 * Betree_message_t)) (st : state) : +Definition betree_store_internal_node + (id : u64) (content : betree_List_t (u64 * betree_Message_t)) (st : state) : result (state * unit) := - p <- betree_utils_store_internal_node_fwd id content st; + p <- betree_utils_store_internal_node id content st; let (st0, _) := p in Return (st0, tt) . (** [betree_main::betree::load_leaf_node]: forward function *) -Definition betree_load_leaf_node_fwd - (id : u64) (st : state) : result (state * (Betree_list_t (u64 * u64))) := - betree_utils_load_leaf_node_fwd id st +Definition betree_load_leaf_node + (id : u64) (st : state) : result (state * (betree_List_t (u64 * u64))) := + betree_utils_load_leaf_node id st . (** [betree_main::betree::store_leaf_node]: forward function *) -Definition betree_store_leaf_node_fwd - (id : u64) (content : Betree_list_t (u64 * u64)) (st : state) : +Definition betree_store_leaf_node + (id : u64) (content : betree_List_t (u64 * u64)) (st : state) : result (state * unit) := - p <- betree_utils_store_leaf_node_fwd id content st; + p <- betree_utils_store_leaf_node id content st; let (st0, _) := p in Return (st0, tt) . (** [betree_main::betree::fresh_node_id]: forward function *) -Definition betree_fresh_node_id_fwd (counter : u64) : result u64 := +Definition betree_fresh_node_id (counter : u64) : result u64 := _ <- u64_add counter 1%u64; Return counter . @@ -57,1136 +57,1121 @@ Definition betree_fresh_node_id_back (counter : u64) : result u64 := . (** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) -Definition betree_node_id_counter_new_fwd : result Betree_node_id_counter_t := - Return {| Betree_node_id_counter_next_node_id := 0%u64 |} +Definition betree_NodeIdCounter_new : result betree_NodeIdCounter_t := + Return {| betree_NodeIdCounter_next_node_id := 0%u64 |} . (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) -Definition betree_node_id_counter_fresh_id_fwd - (self : Betree_node_id_counter_t) : result u64 := - _ <- u64_add self.(Betree_node_id_counter_next_node_id) 1%u64; - Return self.(Betree_node_id_counter_next_node_id) +Definition betree_NodeIdCounter_fresh_id + (self : betree_NodeIdCounter_t) : result u64 := + _ <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; + Return self.(betree_NodeIdCounter_next_node_id) . (** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) -Definition betree_node_id_counter_fresh_id_back - (self : Betree_node_id_counter_t) : result Betree_node_id_counter_t := - i <- u64_add self.(Betree_node_id_counter_next_node_id) 1%u64; - Return {| Betree_node_id_counter_next_node_id := i |} +Definition betree_NodeIdCounter_fresh_id_back + (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t := + i <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; + Return {| betree_NodeIdCounter_next_node_id := i |} . (** [betree_main::betree::upsert_update]: forward function *) -Definition betree_upsert_update_fwd - (prev : option u64) (st : Betree_upsert_fun_state_t) : result u64 := +Definition betree_upsert_update + (prev : option u64) (st : betree_UpsertFunState_t) : result u64 := match prev with | None => match st with - | BetreeUpsertFunStateAdd v => Return v - | BetreeUpsertFunStateSub i => Return 0%u64 + | Betree_UpsertFunState_Add v => Return v + | Betree_UpsertFunState_Sub i => Return 0%u64 end | Some prev0 => match st with - | BetreeUpsertFunStateAdd v => + | Betree_UpsertFunState_Add v => margin <- u64_sub core_u64_max prev0; if margin s>= v then u64_add prev0 v else Return core_u64_max - | BetreeUpsertFunStateSub v => + | Betree_UpsertFunState_Sub v => if prev0 s>= v then u64_sub prev0 v else Return 0%u64 end end . (** [betree_main::betree::List::{1}::len]: forward function *) -Fixpoint betree_list_len_fwd - (T : Type) (n : nat) (self : Betree_list_t T) : result u64 := +Fixpoint betree_List_len + (T : Type) (n : nat) (self : betree_List_t T) : result u64 := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeListCons t tl => i <- betree_list_len_fwd T n0 tl; u64_add 1%u64 i - | BetreeListNil => Return 0%u64 + | Betree_List_Cons t tl => i <- betree_List_len T n0 tl; u64_add 1%u64 i + | Betree_List_Nil => Return 0%u64 end end . (** [betree_main::betree::List::{1}::split_at]: forward function *) -Fixpoint betree_list_split_at_fwd - (T : Type) (n : nat) (self : Betree_list_t T) (n0 : u64) : - result ((Betree_list_t T) * (Betree_list_t T)) +Fixpoint betree_List_split_at + (T : Type) (n : nat) (self : betree_List_t T) (n0 : u64) : + result ((betree_List_t T) * (betree_List_t T)) := match n with | O => Fail_ OutOfFuel | S n1 => if n0 s= 0%u64 - then Return (BetreeListNil, self) + then Return (Betree_List_Nil, self) else match self with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => i <- u64_sub n0 1%u64; - p <- betree_list_split_at_fwd T n1 tl i; + p <- betree_List_split_at T n1 tl i; let (ls0, ls1) := p in let l := ls0 in - Return (BetreeListCons hd l, ls1) - | BetreeListNil => Fail_ Failure + Return (Betree_List_Cons hd l, ls1) + | Betree_List_Nil => Fail_ Failure end end . (** [betree_main::betree::List::{1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition betree_list_push_front_fwd_back - (T : Type) (self : Betree_list_t T) (x : T) : result (Betree_list_t T) := - let tl := mem_replace_fwd (Betree_list_t T) self BetreeListNil in +Definition betree_List_push_front + (T : Type) (self : betree_List_t T) (x : T) : result (betree_List_t T) := + let tl := core_mem_replace (betree_List_t T) self Betree_List_Nil in let l := tl in - Return (BetreeListCons x l) + Return (Betree_List_Cons x l) . (** [betree_main::betree::List::{1}::pop_front]: forward function *) -Definition betree_list_pop_front_fwd - (T : Type) (self : Betree_list_t T) : result T := - let ls := mem_replace_fwd (Betree_list_t T) self BetreeListNil in +Definition betree_List_pop_front + (T : Type) (self : betree_List_t T) : result T := + let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in match ls with - | BetreeListCons x tl => Return x - | BetreeListNil => Fail_ Failure + | Betree_List_Cons x tl => Return x + | Betree_List_Nil => Fail_ Failure end . (** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) -Definition betree_list_pop_front_back - (T : Type) (self : Betree_list_t T) : result (Betree_list_t T) := - let ls := mem_replace_fwd (Betree_list_t T) self BetreeListNil in +Definition betree_List_pop_front_back + (T : Type) (self : betree_List_t T) : result (betree_List_t T) := + let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in match ls with - | BetreeListCons x tl => Return tl - | BetreeListNil => Fail_ Failure + | Betree_List_Cons x tl => Return tl + | Betree_List_Nil => Fail_ Failure end . (** [betree_main::betree::List::{1}::hd]: forward function *) -Definition betree_list_hd_fwd (T : Type) (self : Betree_list_t T) : result T := +Definition betree_List_hd (T : Type) (self : betree_List_t T) : result T := match self with - | BetreeListCons hd l => Return hd - | BetreeListNil => Fail_ Failure + | Betree_List_Cons hd l => Return hd + | Betree_List_Nil => Fail_ Failure end . (** [betree_main::betree::List::{2}::head_has_key]: forward function *) -Definition betree_list_head_has_key_fwd - (T : Type) (self : Betree_list_t (u64 * T)) (key : u64) : result bool := +Definition betree_List_head_has_key + (T : Type) (self : betree_List_t (u64 * T)) (key : u64) : result bool := match self with - | BetreeListCons hd l => let (i, _) := hd in Return (i s= key) - | BetreeListNil => Return false + | Betree_List_Cons hd l => let (i, _) := hd in Return (i s= key) + | Betree_List_Nil => Return false end . (** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -Fixpoint betree_list_partition_at_pivot_fwd - (T : Type) (n : nat) (self : Betree_list_t (u64 * T)) (pivot : u64) : - result ((Betree_list_t (u64 * T)) * (Betree_list_t (u64 * T))) +Fixpoint betree_List_partition_at_pivot + (T : Type) (n : nat) (self : betree_List_t (u64 * T)) (pivot : u64) : + result ((betree_List_t (u64 * T)) * (betree_List_t (u64 * T))) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, t) := hd in if i s>= pivot - then Return (BetreeListNil, BetreeListCons (i, t) tl) + then Return (Betree_List_Nil, Betree_List_Cons (i, t) tl) else ( - p <- betree_list_partition_at_pivot_fwd T n0 tl pivot; + p <- betree_List_partition_at_pivot T n0 tl pivot; let (ls0, ls1) := p in let l := ls0 in - Return (BetreeListCons (i, t) l, ls1)) - | BetreeListNil => Return (BetreeListNil, BetreeListNil) + Return (Betree_List_Cons (i, t) l, ls1)) + | Betree_List_Nil => Return (Betree_List_Nil, Betree_List_Nil) end end . (** [betree_main::betree::Leaf::{3}::split]: forward function *) -Definition betree_leaf_split_fwd - (n : nat) (self : Betree_leaf_t) (content : Betree_list_t (u64 * u64)) - (params : Betree_params_t) (node_id_cnt : Betree_node_id_counter_t) +Definition betree_Leaf_split + (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result (state * Betree_internal_t) + result (state * betree_Internal_t) := p <- - betree_list_split_at_fwd (u64 * u64) n content - params.(Betree_params_split_size); + betree_List_split_at (u64 * u64) n content + params.(betree_Params_split_size); let (content0, content1) := p in - p0 <- betree_list_hd_fwd (u64 * u64) content1; + p0 <- betree_List_hd (u64 * u64) content1; let (pivot, _) := p0 in - id0 <- betree_node_id_counter_fresh_id_fwd node_id_cnt; - node_id_cnt0 <- betree_node_id_counter_fresh_id_back node_id_cnt; - id1 <- betree_node_id_counter_fresh_id_fwd node_id_cnt0; - p1 <- betree_store_leaf_node_fwd id0 content0 st; + id0 <- betree_NodeIdCounter_fresh_id node_id_cnt; + node_id_cnt0 <- betree_NodeIdCounter_fresh_id_back node_id_cnt; + id1 <- betree_NodeIdCounter_fresh_id node_id_cnt0; + p1 <- betree_store_leaf_node id0 content0 st; let (st0, _) := p1 in - p2 <- betree_store_leaf_node_fwd id1 content1 st0; + p2 <- betree_store_leaf_node id1 content1 st0; let (st1, _) := p2 in - let n0 := BetreeNodeLeaf + let n0 := Betree_Node_Leaf {| - Betree_leaf_id := id0; - Betree_leaf_size := params.(Betree_params_split_size) + betree_Leaf_id := id0; + betree_Leaf_size := params.(betree_Params_split_size) |} in - let n1 := BetreeNodeLeaf + let n1 := Betree_Node_Leaf {| - Betree_leaf_id := id1; - Betree_leaf_size := params.(Betree_params_split_size) + betree_Leaf_id := id1; + betree_Leaf_size := params.(betree_Params_split_size) |} in - Return (st1, mkBetree_internal_t self.(Betree_leaf_id) pivot n0 n1) + Return (st1, mkbetree_Internal_t self.(betree_Leaf_id) pivot n0 n1) . (** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) -Definition betree_leaf_split_back - (n : nat) (self : Betree_leaf_t) (content : Betree_list_t (u64 * u64)) - (params : Betree_params_t) (node_id_cnt : Betree_node_id_counter_t) +Definition betree_Leaf_split_back + (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) + (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (st : state) : - result Betree_node_id_counter_t + result betree_NodeIdCounter_t := p <- - betree_list_split_at_fwd (u64 * u64) n content - params.(Betree_params_split_size); + betree_List_split_at (u64 * u64) n content + params.(betree_Params_split_size); let (content0, content1) := p in - _ <- betree_list_hd_fwd (u64 * u64) content1; - id0 <- betree_node_id_counter_fresh_id_fwd node_id_cnt; - node_id_cnt0 <- betree_node_id_counter_fresh_id_back node_id_cnt; - id1 <- betree_node_id_counter_fresh_id_fwd node_id_cnt0; - p0 <- betree_store_leaf_node_fwd id0 content0 st; + _ <- betree_List_hd (u64 * u64) content1; + id0 <- betree_NodeIdCounter_fresh_id node_id_cnt; + node_id_cnt0 <- betree_NodeIdCounter_fresh_id_back node_id_cnt; + id1 <- betree_NodeIdCounter_fresh_id node_id_cnt0; + p0 <- betree_store_leaf_node id0 content0 st; let (st0, _) := p0 in - _ <- betree_store_leaf_node_fwd id1 content1 st0; - betree_node_id_counter_fresh_id_back node_id_cnt0 + _ <- betree_store_leaf_node id1 content1 st0; + betree_NodeIdCounter_fresh_id_back node_id_cnt0 . (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) -Fixpoint betree_node_lookup_first_message_for_key_fwd - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_for_key + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons x next_msgs => + | Betree_List_Cons x next_msgs => let (i, m) := x in if i s>= key - then Return (BetreeListCons (i, m) next_msgs) - else betree_node_lookup_first_message_for_key_fwd n0 key next_msgs - | BetreeListNil => Return BetreeListNil + then Return (Betree_List_Cons (i, m) next_msgs) + else betree_Node_lookup_first_message_for_key n0 key next_msgs + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) -Fixpoint betree_node_lookup_first_message_for_key_back - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) - (ret : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_for_key_back + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) + (ret : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons x next_msgs => + | Betree_List_Cons x next_msgs => let (i, m) := x in if i s>= key then Return ret else ( next_msgs0 <- - betree_node_lookup_first_message_for_key_back n0 key next_msgs ret; - Return (BetreeListCons (i, m) next_msgs0)) - | BetreeListNil => Return ret + betree_Node_lookup_first_message_for_key_back n0 key next_msgs ret; + Return (Betree_List_Cons (i, m) next_msgs0)) + | Betree_List_Nil => Return ret end end . (** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) -Fixpoint betree_node_apply_upserts_fwd - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) (prev : option u64) +Fixpoint betree_Node_apply_upserts + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : result (state * u64) := match n with | O => Fail_ OutOfFuel | S n0 => - b <- betree_list_head_has_key_fwd Betree_message_t msgs key; + b <- betree_List_head_has_key betree_Message_t msgs key; if b then ( - msg <- betree_list_pop_front_fwd (u64 * Betree_message_t) msgs; + msg <- betree_List_pop_front (u64 * betree_Message_t) msgs; let (_, m) := msg in match m with - | BetreeMessageInsert i => Fail_ Failure - | BetreeMessageDelete => Fail_ Failure - | BetreeMessageUpsert s => - v <- betree_upsert_update_fwd prev s; - msgs0 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs; - betree_node_apply_upserts_fwd n0 msgs0 (Some v) key st + | Betree_Message_Insert i => Fail_ Failure + | Betree_Message_Delete => Fail_ Failure + | Betree_Message_Upsert s => + v <- betree_upsert_update prev s; + msgs0 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs; + betree_Node_apply_upserts n0 msgs0 (Some v) key st end) else ( - p <- core_option_option_unwrap_fwd u64 prev st; + p <- core_option_Option_unwrap u64 prev st; let (st0, v) := p in _ <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs (key, - BetreeMessageInsert v); + betree_List_push_front (u64 * betree_Message_t) msgs (key, + Betree_Message_Insert v); Return (st0, v)) end . (** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) -Fixpoint betree_node_apply_upserts_back - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) (prev : option u64) +Fixpoint betree_Node_apply_upserts_back + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : - result (Betree_list_t (u64 * Betree_message_t)) + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => - b <- betree_list_head_has_key_fwd Betree_message_t msgs key; + b <- betree_List_head_has_key betree_Message_t msgs key; if b then ( - msg <- betree_list_pop_front_fwd (u64 * Betree_message_t) msgs; + msg <- betree_List_pop_front (u64 * betree_Message_t) msgs; let (_, m) := msg in match m with - | BetreeMessageInsert i => Fail_ Failure - | BetreeMessageDelete => Fail_ Failure - | BetreeMessageUpsert s => - v <- betree_upsert_update_fwd prev s; - msgs0 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs; - betree_node_apply_upserts_back n0 msgs0 (Some v) key st + | Betree_Message_Insert i => Fail_ Failure + | Betree_Message_Delete => Fail_ Failure + | Betree_Message_Upsert s => + v <- betree_upsert_update prev s; + msgs0 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs; + betree_Node_apply_upserts_back n0 msgs0 (Some v) key st end) else ( - p <- core_option_option_unwrap_fwd u64 prev st; + p <- core_option_Option_unwrap u64 prev st; let (_, v) := p in - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs (key, - BetreeMessageInsert v)) + betree_List_push_front (u64 * betree_Message_t) msgs (key, + Betree_Message_Insert v)) end . (** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) -Fixpoint betree_node_lookup_in_bindings_fwd - (n : nat) (key : u64) (bindings : Betree_list_t (u64 * u64)) : +Fixpoint betree_Node_lookup_in_bindings + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : result (option u64) := match n with | O => Fail_ OutOfFuel | S n0 => match bindings with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, i0) := hd in if i s= key then Return (Some i0) else if i s> key then Return None - else betree_node_lookup_in_bindings_fwd n0 key tl - | BetreeListNil => Return None + else betree_Node_lookup_in_bindings n0 key tl + | Betree_List_Nil => Return None end end . (** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) -Fixpoint betree_internal_lookup_in_children_fwd - (n : nat) (self : Betree_internal_t) (key : u64) (st : state) : +Fixpoint betree_Internal_lookup_in_children + (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : result (state * (option u64)) := match n with | O => Fail_ OutOfFuel | S n0 => - if key s< self.(Betree_internal_pivot) - then betree_node_lookup_fwd n0 self.(Betree_internal_left) key st - else betree_node_lookup_fwd n0 self.(Betree_internal_right) key st + if key s< self.(betree_Internal_pivot) + then betree_Node_lookup n0 self.(betree_Internal_left) key st + else betree_Node_lookup n0 self.(betree_Internal_right) key st end (** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) -with betree_internal_lookup_in_children_back - (n : nat) (self : Betree_internal_t) (key : u64) (st : state) : - result Betree_internal_t +with betree_Internal_lookup_in_children_back + (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : + result betree_Internal_t := match n with | O => Fail_ OutOfFuel | S n0 => - if key s< self.(Betree_internal_pivot) + if key s< self.(betree_Internal_pivot) then ( - n1 <- betree_node_lookup_back n0 self.(Betree_internal_left) key st; - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) n1 self.(Betree_internal_right))) + n1 <- betree_Node_lookup_back n0 self.(betree_Internal_left) key st; + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) n1 self.(betree_Internal_right))) else ( - n1 <- betree_node_lookup_back n0 self.(Betree_internal_right) key st; - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) self.(Betree_internal_left) n1)) + n1 <- betree_Node_lookup_back n0 self.(betree_Internal_right) key st; + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) self.(betree_Internal_left) n1)) end (** [betree_main::betree::Node::{5}::lookup]: forward function *) -with betree_node_lookup_fwd - (n : nat) (self : Betree_node_t) (key : u64) (st : state) : +with betree_Node_lookup + (n : nat) (self : betree_Node_t) (key : u64) (st : state) : result (state * (option u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, msgs) := p in - pending <- betree_node_lookup_first_message_for_key_fwd n0 key msgs; + pending <- betree_Node_lookup_first_message_for_key n0 key msgs; match pending with - | BetreeListCons p0 l => + | Betree_List_Cons p0 l => let (k, msg) := p0 in if k s<> key then ( - p1 <- betree_internal_lookup_in_children_fwd n0 node key st0; - let (st1, opt) := p1 in + p1 <- betree_Internal_lookup_in_children n0 node key st0; + let (st1, o) := p1 in _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, msg) l); - Return (st1, opt)) + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, msg) l); + Return (st1, o)) else match msg with - | BetreeMessageInsert v => + | Betree_Message_Insert v => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageInsert v) l); + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l); Return (st0, Some v) - | BetreeMessageDelete => + | Betree_Message_Delete => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageDelete) l); + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l); Return (st0, None) - | BetreeMessageUpsert ufs => - p1 <- betree_internal_lookup_in_children_fwd n0 node key st0; + | Betree_Message_Upsert ufs => + p1 <- betree_Internal_lookup_in_children n0 node key st0; let (st1, v) := p1 in p2 <- - betree_node_apply_upserts_fwd n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; let (st2, v0) := p2 in - node0 <- betree_internal_lookup_in_children_back n0 node key st0; + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; pending0 <- - betree_node_apply_upserts_back n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts_back n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; msgs0 <- - betree_node_lookup_first_message_for_key_back n0 key msgs + betree_Node_lookup_first_message_for_key_back n0 key msgs pending0; p3 <- - betree_store_internal_node_fwd node0.(Betree_internal_id) msgs0 - st2; + betree_store_internal_node node0.(betree_Internal_id) msgs0 st2; let (st3, _) := p3 in Return (st3, Some v0) end - | BetreeListNil => - p0 <- betree_internal_lookup_in_children_fwd n0 node key st0; - let (st1, opt) := p0 in + | Betree_List_Nil => + p0 <- betree_Internal_lookup_in_children n0 node key st0; + let (st1, o) := p0 in _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - BetreeListNil; - Return (st1, opt) + betree_Node_lookup_first_message_for_key_back n0 key msgs + Betree_List_Nil; + Return (st1, o) end - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (st0, bindings) := p in - opt <- betree_node_lookup_in_bindings_fwd n0 key bindings; - Return (st0, opt) + o <- betree_Node_lookup_in_bindings n0 key bindings; + Return (st0, o) end end (** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) -with betree_node_lookup_back - (n : nat) (self : Betree_node_t) (key : u64) (st : state) : - result Betree_node_t +with betree_Node_lookup_back + (n : nat) (self : betree_Node_t) (key : u64) (st : state) : + result betree_Node_t := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, msgs) := p in - pending <- betree_node_lookup_first_message_for_key_fwd n0 key msgs; + pending <- betree_Node_lookup_first_message_for_key n0 key msgs; match pending with - | BetreeListCons p0 l => + | Betree_List_Cons p0 l => let (k, msg) := p0 in if k s<> key then ( _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, msg) l); - node0 <- betree_internal_lookup_in_children_back n0 node key st0; - Return (BetreeNodeInternal node0)) + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, msg) l); + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; + Return (Betree_Node_Internal node0)) else match msg with - | BetreeMessageInsert v => + | Betree_Message_Insert v => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageInsert v) l); - Return (BetreeNodeInternal node) - | BetreeMessageDelete => + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Insert v) l); + Return (Betree_Node_Internal node) + | Betree_Message_Delete => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - (BetreeListCons (k, BetreeMessageDelete) l); - Return (BetreeNodeInternal node) - | BetreeMessageUpsert ufs => - p1 <- betree_internal_lookup_in_children_fwd n0 node key st0; + betree_Node_lookup_first_message_for_key_back n0 key msgs + (Betree_List_Cons (k, Betree_Message_Delete) l); + Return (Betree_Node_Internal node) + | Betree_Message_Upsert ufs => + p1 <- betree_Internal_lookup_in_children n0 node key st0; let (st1, v) := p1 in p2 <- - betree_node_apply_upserts_fwd n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; let (st2, _) := p2 in - node0 <- betree_internal_lookup_in_children_back n0 node key st0; + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; pending0 <- - betree_node_apply_upserts_back n0 (BetreeListCons (k, - BetreeMessageUpsert ufs) l) v key st1; + betree_Node_apply_upserts_back n0 (Betree_List_Cons (k, + Betree_Message_Upsert ufs) l) v key st1; msgs0 <- - betree_node_lookup_first_message_for_key_back n0 key msgs + betree_Node_lookup_first_message_for_key_back n0 key msgs pending0; _ <- - betree_store_internal_node_fwd node0.(Betree_internal_id) msgs0 - st2; - Return (BetreeNodeInternal node0) + betree_store_internal_node node0.(betree_Internal_id) msgs0 st2; + Return (Betree_Node_Internal node0) end - | BetreeListNil => + | Betree_List_Nil => _ <- - betree_node_lookup_first_message_for_key_back n0 key msgs - BetreeListNil; - node0 <- betree_internal_lookup_in_children_back n0 node key st0; - Return (BetreeNodeInternal node0) + betree_Node_lookup_first_message_for_key_back n0 key msgs + Betree_List_Nil; + node0 <- betree_Internal_lookup_in_children_back n0 node key st0; + Return (Betree_Node_Internal node0) end - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (_, bindings) := p in - _ <- betree_node_lookup_in_bindings_fwd n0 key bindings; - Return (BetreeNodeLeaf node) + _ <- betree_Node_lookup_in_bindings n0 key bindings; + Return (Betree_Node_Leaf node) end end . (** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint betree_node_filter_messages_for_key_fwd_back - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_filter_messages_for_key + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons p l => + | Betree_List_Cons p l => let (k, m) := p in if k s= key then ( msgs0 <- - betree_list_pop_front_back (u64 * Betree_message_t) (BetreeListCons + betree_List_pop_front_back (u64 * betree_Message_t) (Betree_List_Cons (k, m) l); - betree_node_filter_messages_for_key_fwd_back n0 key msgs0) - else Return (BetreeListCons (k, m) l) - | BetreeListNil => Return BetreeListNil + betree_Node_filter_messages_for_key n0 key msgs0) + else Return (Betree_List_Cons (k, m) l) + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) -Fixpoint betree_node_lookup_first_message_after_key_fwd - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_after_key + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons p next_msgs => + | Betree_List_Cons p next_msgs => let (k, m) := p in if k s= key - then betree_node_lookup_first_message_after_key_fwd n0 key next_msgs - else Return (BetreeListCons (k, m) next_msgs) - | BetreeListNil => Return BetreeListNil + then betree_Node_lookup_first_message_after_key n0 key next_msgs + else Return (Betree_List_Cons (k, m) next_msgs) + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) -Fixpoint betree_node_lookup_first_message_after_key_back - (n : nat) (key : u64) (msgs : Betree_list_t (u64 * Betree_message_t)) - (ret : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_lookup_first_message_after_key_back + (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) + (ret : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match msgs with - | BetreeListCons p next_msgs => + | Betree_List_Cons p next_msgs => let (k, m) := p in if k s= key then ( next_msgs0 <- - betree_node_lookup_first_message_after_key_back n0 key next_msgs ret; - Return (BetreeListCons (k, m) next_msgs0)) + betree_Node_lookup_first_message_after_key_back n0 key next_msgs ret; + Return (Betree_List_Cons (k, m) next_msgs0)) else Return ret - | BetreeListNil => Return ret + | Betree_List_Nil => Return ret end end . (** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition betree_node_apply_to_internal_fwd_back - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) (key : u64) - (new_msg : Betree_message_t) : - result (Betree_list_t (u64 * Betree_message_t)) +Definition betree_Node_apply_to_internal + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 * betree_Message_t)) := - msgs0 <- betree_node_lookup_first_message_for_key_fwd n key msgs; - b <- betree_list_head_has_key_fwd Betree_message_t msgs0 key; + msgs0 <- betree_Node_lookup_first_message_for_key n key msgs; + b <- betree_List_head_has_key betree_Message_t msgs0 key; if b then match new_msg with - | BetreeMessageInsert i => - msgs1 <- betree_node_filter_messages_for_key_fwd_back n key msgs0; + | Betree_Message_Insert i => + msgs1 <- betree_Node_filter_messages_for_key n key msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageInsert i); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageDelete => - msgs1 <- betree_node_filter_messages_for_key_fwd_back n key msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Insert i); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Delete => + msgs1 <- betree_Node_filter_messages_for_key n key msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageDelete); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageUpsert s => - p <- betree_list_hd_fwd (u64 * Betree_message_t) msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Delete); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Upsert s => + p <- betree_List_hd (u64 * betree_Message_t) msgs0; let (_, m) := p in match m with - | BetreeMessageInsert prev => - v <- betree_upsert_update_fwd (Some prev) s; - msgs1 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs0; + | Betree_Message_Insert prev => + v <- betree_upsert_update (Some prev) s; + msgs1 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageInsert v); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageDelete => - v <- betree_upsert_update_fwd None s; - msgs1 <- betree_list_pop_front_back (u64 * Betree_message_t) msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Insert v); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Delete => + v <- betree_upsert_update None s; + msgs1 <- betree_List_pop_front_back (u64 * betree_Message_t) msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageInsert v); - betree_node_lookup_first_message_for_key_back n key msgs msgs2 - | BetreeMessageUpsert ufs => - msgs1 <- betree_node_lookup_first_message_after_key_fwd n key msgs0; + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Insert v); + betree_Node_lookup_first_message_for_key_back n key msgs msgs2 + | Betree_Message_Upsert ufs => + msgs1 <- betree_Node_lookup_first_message_after_key n key msgs0; msgs2 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs1 (key, - BetreeMessageUpsert s); + betree_List_push_front (u64 * betree_Message_t) msgs1 (key, + Betree_Message_Upsert s); msgs3 <- - betree_node_lookup_first_message_after_key_back n key msgs0 msgs2; - betree_node_lookup_first_message_for_key_back n key msgs msgs3 + betree_Node_lookup_first_message_after_key_back n key msgs0 msgs2; + betree_Node_lookup_first_message_for_key_back n key msgs msgs3 end end else ( msgs1 <- - betree_list_push_front_fwd_back (u64 * Betree_message_t) msgs0 (key, - new_msg); - betree_node_lookup_first_message_for_key_back n key msgs msgs1) + betree_List_push_front (u64 * betree_Message_t) msgs0 (key, new_msg); + betree_Node_lookup_first_message_for_key_back n key msgs msgs1) . (** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint betree_node_apply_messages_to_internal_fwd_back - (n : nat) (msgs : Betree_list_t (u64 * Betree_message_t)) - (new_msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * Betree_message_t)) +Fixpoint betree_Node_apply_messages_to_internal + (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) + (new_msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * betree_Message_t)) := match n with | O => Fail_ OutOfFuel | S n0 => match new_msgs with - | BetreeListCons new_msg new_msgs_tl => + | Betree_List_Cons new_msg new_msgs_tl => let (i, m) := new_msg in - msgs0 <- betree_node_apply_to_internal_fwd_back n0 msgs i m; - betree_node_apply_messages_to_internal_fwd_back n0 msgs0 new_msgs_tl - | BetreeListNil => Return msgs + msgs0 <- betree_Node_apply_to_internal n0 msgs i m; + betree_Node_apply_messages_to_internal n0 msgs0 new_msgs_tl + | Betree_List_Nil => Return msgs end end . (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) -Fixpoint betree_node_lookup_mut_in_bindings_fwd - (n : nat) (key : u64) (bindings : Betree_list_t (u64 * u64)) : - result (Betree_list_t (u64 * u64)) +Fixpoint betree_Node_lookup_mut_in_bindings + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : + result (betree_List_t (u64 * u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match bindings with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, i0) := hd in if i s>= key - then Return (BetreeListCons (i, i0) tl) - else betree_node_lookup_mut_in_bindings_fwd n0 key tl - | BetreeListNil => Return BetreeListNil + then Return (Betree_List_Cons (i, i0) tl) + else betree_Node_lookup_mut_in_bindings n0 key tl + | Betree_List_Nil => Return Betree_List_Nil end end . (** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) -Fixpoint betree_node_lookup_mut_in_bindings_back - (n : nat) (key : u64) (bindings : Betree_list_t (u64 * u64)) - (ret : Betree_list_t (u64 * u64)) : - result (Betree_list_t (u64 * u64)) +Fixpoint betree_Node_lookup_mut_in_bindings_back + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) + (ret : betree_List_t (u64 * u64)) : + result (betree_List_t (u64 * u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match bindings with - | BetreeListCons hd tl => + | Betree_List_Cons hd tl => let (i, i0) := hd in if i s>= key then Return ret else ( - tl0 <- betree_node_lookup_mut_in_bindings_back n0 key tl ret; - Return (BetreeListCons (i, i0) tl0)) - | BetreeListNil => Return ret + tl0 <- betree_Node_lookup_mut_in_bindings_back n0 key tl ret; + Return (Betree_List_Cons (i, i0) tl0)) + | Betree_List_Nil => Return ret end end . (** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition betree_node_apply_to_leaf_fwd_back - (n : nat) (bindings : Betree_list_t (u64 * u64)) (key : u64) - (new_msg : Betree_message_t) : - result (Betree_list_t (u64 * u64)) +Definition betree_Node_apply_to_leaf + (n : nat) (bindings : betree_List_t (u64 * u64)) (key : u64) + (new_msg : betree_Message_t) : + result (betree_List_t (u64 * u64)) := - bindings0 <- betree_node_lookup_mut_in_bindings_fwd n key bindings; - b <- betree_list_head_has_key_fwd u64 bindings0 key; + bindings0 <- betree_Node_lookup_mut_in_bindings n key bindings; + b <- betree_List_head_has_key u64 bindings0 key; if b then ( - hd <- betree_list_pop_front_fwd (u64 * u64) bindings0; + hd <- betree_List_pop_front (u64 * u64) bindings0; match new_msg with - | BetreeMessageInsert v => - bindings1 <- betree_list_pop_front_back (u64 * u64) bindings0; - bindings2 <- - betree_list_push_front_fwd_back (u64 * u64) bindings1 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings2 - | BetreeMessageDelete => - bindings1 <- betree_list_pop_front_back (u64 * u64) bindings0; - betree_node_lookup_mut_in_bindings_back n key bindings bindings1 - | BetreeMessageUpsert s => + | Betree_Message_Insert v => + bindings1 <- betree_List_pop_front_back (u64 * u64) bindings0; + bindings2 <- betree_List_push_front (u64 * u64) bindings1 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings2 + | Betree_Message_Delete => + bindings1 <- betree_List_pop_front_back (u64 * u64) bindings0; + betree_Node_lookup_mut_in_bindings_back n key bindings bindings1 + | Betree_Message_Upsert s => let (_, i) := hd in - v <- betree_upsert_update_fwd (Some i) s; - bindings1 <- betree_list_pop_front_back (u64 * u64) bindings0; - bindings2 <- - betree_list_push_front_fwd_back (u64 * u64) bindings1 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings2 + v <- betree_upsert_update (Some i) s; + bindings1 <- betree_List_pop_front_back (u64 * u64) bindings0; + bindings2 <- betree_List_push_front (u64 * u64) bindings1 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings2 end) else match new_msg with - | BetreeMessageInsert v => - bindings1 <- - betree_list_push_front_fwd_back (u64 * u64) bindings0 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings1 - | BetreeMessageDelete => - betree_node_lookup_mut_in_bindings_back n key bindings bindings0 - | BetreeMessageUpsert s => - v <- betree_upsert_update_fwd None s; - bindings1 <- - betree_list_push_front_fwd_back (u64 * u64) bindings0 (key, v); - betree_node_lookup_mut_in_bindings_back n key bindings bindings1 + | Betree_Message_Insert v => + bindings1 <- betree_List_push_front (u64 * u64) bindings0 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings1 + | Betree_Message_Delete => + betree_Node_lookup_mut_in_bindings_back n key bindings bindings0 + | Betree_Message_Upsert s => + v <- betree_upsert_update None s; + bindings1 <- betree_List_push_front (u64 * u64) bindings0 (key, v); + betree_Node_lookup_mut_in_bindings_back n key bindings bindings1 end . (** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint betree_node_apply_messages_to_leaf_fwd_back - (n : nat) (bindings : Betree_list_t (u64 * u64)) - (new_msgs : Betree_list_t (u64 * Betree_message_t)) : - result (Betree_list_t (u64 * u64)) +Fixpoint betree_Node_apply_messages_to_leaf + (n : nat) (bindings : betree_List_t (u64 * u64)) + (new_msgs : betree_List_t (u64 * betree_Message_t)) : + result (betree_List_t (u64 * u64)) := match n with | O => Fail_ OutOfFuel | S n0 => match new_msgs with - | BetreeListCons new_msg new_msgs_tl => + | Betree_List_Cons new_msg new_msgs_tl => let (i, m) := new_msg in - bindings0 <- betree_node_apply_to_leaf_fwd_back n0 bindings i m; - betree_node_apply_messages_to_leaf_fwd_back n0 bindings0 new_msgs_tl - | BetreeListNil => Return bindings + bindings0 <- betree_Node_apply_to_leaf n0 bindings i m; + betree_Node_apply_messages_to_leaf n0 bindings0 new_msgs_tl + | Betree_List_Nil => Return bindings end end . (** [betree_main::betree::Internal::{4}::flush]: forward function *) -Fixpoint betree_internal_flush_fwd - (n : nat) (self : Betree_internal_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (content : Betree_list_t (u64 * Betree_message_t)) (st : state) : - result (state * (Betree_list_t (u64 * Betree_message_t))) +Fixpoint betree_Internal_flush + (n : nat) (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 * betree_Message_t)) (st : state) : + result (state * (betree_List_t (u64 * betree_Message_t))) := match n with | O => Fail_ OutOfFuel | S n0 => p <- - betree_list_partition_at_pivot_fwd Betree_message_t n0 content - self.(Betree_internal_pivot); + betree_List_partition_at_pivot betree_Message_t n0 content + self.(betree_Internal_pivot); let (msgs_left, msgs_right) := p in - len_left <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_left; - if len_left s>= params.(Betree_params_min_flush_size) + len_left <- betree_List_len (u64 * betree_Message_t) n0 msgs_left; + if len_left s>= params.(betree_Params_min_flush_size) then ( p0 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_left) params + betree_Node_apply_messages n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (st0, _) := p0 in p1 <- - betree_node_apply_messages_back n0 self.(Betree_internal_left) params + betree_Node_apply_messages_back n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (_, node_id_cnt0) := p1 in - len_right <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_right; - if len_right s>= params.(Betree_params_min_flush_size) + len_right <- betree_List_len (u64 * betree_Message_t) n0 msgs_right; + if len_right s>= params.(betree_Params_min_flush_size) then ( p2 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_right) params + betree_Node_apply_messages n0 self.(betree_Internal_right) params node_id_cnt0 msgs_right st0; let (st1, _) := p2 in _ <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt0 msgs_right st0; - Return (st1, BetreeListNil)) + Return (st1, Betree_List_Nil)) else Return (st0, msgs_right)) else ( p0 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_right) params + betree_Node_apply_messages n0 self.(betree_Internal_right) params node_id_cnt msgs_right st; let (st0, _) := p0 in _ <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) params + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt msgs_right st; Return (st0, msgs_left)) end (** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) -with betree_internal_flush_back - (n : nat) (self : Betree_internal_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (content : Betree_list_t (u64 * Betree_message_t)) (st : state) : - result (Betree_internal_t * Betree_node_id_counter_t) +with betree_Internal_flush_back + (n : nat) (self : betree_Internal_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (content : betree_List_t (u64 * betree_Message_t)) (st : state) : + result (betree_Internal_t * betree_NodeIdCounter_t) := match n with | O => Fail_ OutOfFuel | S n0 => p <- - betree_list_partition_at_pivot_fwd Betree_message_t n0 content - self.(Betree_internal_pivot); + betree_List_partition_at_pivot betree_Message_t n0 content + self.(betree_Internal_pivot); let (msgs_left, msgs_right) := p in - len_left <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_left; - if len_left s>= params.(Betree_params_min_flush_size) + len_left <- betree_List_len (u64 * betree_Message_t) n0 msgs_left; + if len_left s>= params.(betree_Params_min_flush_size) then ( p0 <- - betree_node_apply_messages_fwd n0 self.(Betree_internal_left) params + betree_Node_apply_messages n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (st0, _) := p0 in p1 <- - betree_node_apply_messages_back n0 self.(Betree_internal_left) params + betree_Node_apply_messages_back n0 self.(betree_Internal_left) params node_id_cnt msgs_left st; let (n1, node_id_cnt0) := p1 in - len_right <- betree_list_len_fwd (u64 * Betree_message_t) n0 msgs_right; - if len_right s>= params.(Betree_params_min_flush_size) + len_right <- betree_List_len (u64 * betree_Message_t) n0 msgs_right; + if len_right s>= params.(betree_Params_min_flush_size) then ( p2 <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt0 msgs_right st0; let (n2, node_id_cnt1) := p2 in - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) n1 n2, node_id_cnt1)) + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) n1 n2, node_id_cnt1)) else - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) n1 self.(Betree_internal_right), + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) n1 self.(betree_Internal_right), node_id_cnt0)) else ( p0 <- - betree_node_apply_messages_back n0 self.(Betree_internal_right) params + betree_Node_apply_messages_back n0 self.(betree_Internal_right) params node_id_cnt msgs_right st; let (n1, node_id_cnt0) := p0 in - Return (mkBetree_internal_t self.(Betree_internal_id) - self.(Betree_internal_pivot) self.(Betree_internal_left) n1, + Return (mkbetree_Internal_t self.(betree_Internal_id) + self.(betree_Internal_pivot) self.(betree_Internal_left) n1, node_id_cnt0)) end (** [betree_main::betree::Node::{5}::apply_messages]: forward function *) -with betree_node_apply_messages_fwd - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (msgs : Betree_list_t (u64 * Betree_message_t)) (st : state) : +with betree_Node_apply_messages + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 * betree_Message_t)) (st : state) : result (state * unit) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, content) := p in - content0 <- - betree_node_apply_messages_to_internal_fwd_back n0 content msgs; - num_msgs <- betree_list_len_fwd (u64 * Betree_message_t) n0 content0; - if num_msgs s>= params.(Betree_params_min_flush_size) + content0 <- betree_Node_apply_messages_to_internal n0 content msgs; + num_msgs <- betree_List_len (u64 * betree_Message_t) n0 content0; + if num_msgs s>= params.(betree_Params_min_flush_size) then ( - p0 <- - betree_internal_flush_fwd n0 node params node_id_cnt content0 st0; + p0 <- betree_Internal_flush n0 node params node_id_cnt content0 st0; let (st1, content1) := p0 in p1 <- - betree_internal_flush_back n0 node params node_id_cnt content0 st0; + betree_Internal_flush_back n0 node params node_id_cnt content0 st0; let (node0, _) := p1 in p2 <- - betree_store_internal_node_fwd node0.(Betree_internal_id) content1 - st1; + betree_store_internal_node node0.(betree_Internal_id) content1 st1; let (st2, _) := p2 in Return (st2, tt)) else ( p0 <- - betree_store_internal_node_fwd node.(Betree_internal_id) content0 st0; + betree_store_internal_node node.(betree_Internal_id) content0 st0; let (st1, _) := p0 in Return (st1, tt)) - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (st0, content) := p in - content0 <- betree_node_apply_messages_to_leaf_fwd_back n0 content msgs; - len <- betree_list_len_fwd (u64 * u64) n0 content0; - i <- u64_mul 2%u64 params.(Betree_params_split_size); + content0 <- betree_Node_apply_messages_to_leaf n0 content msgs; + len <- betree_List_len (u64 * u64) n0 content0; + i <- u64_mul 2%u64 params.(betree_Params_split_size); if len s>= i then ( - p0 <- betree_leaf_split_fwd n0 node content0 params node_id_cnt st0; + p0 <- betree_Leaf_split n0 node content0 params node_id_cnt st0; let (st1, _) := p0 in - p1 <- - betree_store_leaf_node_fwd node.(Betree_leaf_id) BetreeListNil st1; + p1 <- betree_store_leaf_node node.(betree_Leaf_id) Betree_List_Nil st1; let (st2, _) := p1 in Return (st2, tt)) else ( - p0 <- betree_store_leaf_node_fwd node.(Betree_leaf_id) content0 st0; + p0 <- betree_store_leaf_node node.(betree_Leaf_id) content0 st0; let (st1, _) := p0 in Return (st1, tt)) end end (** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) -with betree_node_apply_messages_back - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) - (msgs : Betree_list_t (u64 * Betree_message_t)) (st : state) : - result (Betree_node_t * Betree_node_id_counter_t) +with betree_Node_apply_messages_back + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) + (msgs : betree_List_t (u64 * betree_Message_t)) (st : state) : + result (betree_Node_t * betree_NodeIdCounter_t) := match n with | O => Fail_ OutOfFuel | S n0 => match self with - | BetreeNodeInternal node => - p <- betree_load_internal_node_fwd node.(Betree_internal_id) st; + | Betree_Node_Internal node => + p <- betree_load_internal_node node.(betree_Internal_id) st; let (st0, content) := p in - content0 <- - betree_node_apply_messages_to_internal_fwd_back n0 content msgs; - num_msgs <- betree_list_len_fwd (u64 * Betree_message_t) n0 content0; - if num_msgs s>= params.(Betree_params_min_flush_size) + content0 <- betree_Node_apply_messages_to_internal n0 content msgs; + num_msgs <- betree_List_len (u64 * betree_Message_t) n0 content0; + if num_msgs s>= params.(betree_Params_min_flush_size) then ( - p0 <- - betree_internal_flush_fwd n0 node params node_id_cnt content0 st0; + p0 <- betree_Internal_flush n0 node params node_id_cnt content0 st0; let (st1, content1) := p0 in p1 <- - betree_internal_flush_back n0 node params node_id_cnt content0 st0; + betree_Internal_flush_back n0 node params node_id_cnt content0 st0; let (node0, node_id_cnt0) := p1 in _ <- - betree_store_internal_node_fwd node0.(Betree_internal_id) content1 - st1; - Return (BetreeNodeInternal node0, node_id_cnt0)) + betree_store_internal_node node0.(betree_Internal_id) content1 st1; + Return (Betree_Node_Internal node0, node_id_cnt0)) else ( - _ <- - betree_store_internal_node_fwd node.(Betree_internal_id) content0 st0; - Return (BetreeNodeInternal node, node_id_cnt)) - | BetreeNodeLeaf node => - p <- betree_load_leaf_node_fwd node.(Betree_leaf_id) st; + _ <- betree_store_internal_node node.(betree_Internal_id) content0 st0; + Return (Betree_Node_Internal node, node_id_cnt)) + | Betree_Node_Leaf node => + p <- betree_load_leaf_node node.(betree_Leaf_id) st; let (st0, content) := p in - content0 <- betree_node_apply_messages_to_leaf_fwd_back n0 content msgs; - len <- betree_list_len_fwd (u64 * u64) n0 content0; - i <- u64_mul 2%u64 params.(Betree_params_split_size); + content0 <- betree_Node_apply_messages_to_leaf n0 content msgs; + len <- betree_List_len (u64 * u64) n0 content0; + i <- u64_mul 2%u64 params.(betree_Params_split_size); if len s>= i then ( - p0 <- betree_leaf_split_fwd n0 node content0 params node_id_cnt st0; + p0 <- betree_Leaf_split n0 node content0 params node_id_cnt st0; let (st1, new_node) := p0 in - _ <- - betree_store_leaf_node_fwd node.(Betree_leaf_id) BetreeListNil st1; + _ <- betree_store_leaf_node node.(betree_Leaf_id) Betree_List_Nil st1; node_id_cnt0 <- - betree_leaf_split_back n0 node content0 params node_id_cnt st0; - Return (BetreeNodeInternal new_node, node_id_cnt0)) + betree_Leaf_split_back n0 node content0 params node_id_cnt st0; + Return (Betree_Node_Internal new_node, node_id_cnt0)) else ( - _ <- betree_store_leaf_node_fwd node.(Betree_leaf_id) content0 st0; - Return (BetreeNodeLeaf - {| Betree_leaf_id := node.(Betree_leaf_id); Betree_leaf_size := len + _ <- betree_store_leaf_node node.(betree_Leaf_id) content0 st0; + Return (Betree_Node_Leaf + {| betree_Leaf_id := node.(betree_Leaf_id); betree_Leaf_size := len |}, node_id_cnt)) end end . (** [betree_main::betree::Node::{5}::apply]: forward function *) -Definition betree_node_apply_fwd - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) (key : u64) - (new_msg : Betree_message_t) (st : state) : +Definition betree_Node_apply + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : result (state * unit) := - let l := BetreeListNil in + let l := Betree_List_Nil in p <- - betree_node_apply_messages_fwd n self params node_id_cnt (BetreeListCons + betree_Node_apply_messages n self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st; let (st0, _) := p in _ <- - betree_node_apply_messages_back n self params node_id_cnt (BetreeListCons + betree_Node_apply_messages_back n self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st; Return (st0, tt) . (** [betree_main::betree::Node::{5}::apply]: backward function 0 *) -Definition betree_node_apply_back - (n : nat) (self : Betree_node_t) (params : Betree_params_t) - (node_id_cnt : Betree_node_id_counter_t) (key : u64) - (new_msg : Betree_message_t) (st : state) : - result (Betree_node_t * Betree_node_id_counter_t) +Definition betree_Node_apply_back + (n : nat) (self : betree_Node_t) (params : betree_Params_t) + (node_id_cnt : betree_NodeIdCounter_t) (key : u64) + (new_msg : betree_Message_t) (st : state) : + result (betree_Node_t * betree_NodeIdCounter_t) := - let l := BetreeListNil in - betree_node_apply_messages_back n self params node_id_cnt (BetreeListCons + let l := Betree_List_Nil in + betree_Node_apply_messages_back n self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st . (** [betree_main::betree::BeTree::{6}::new]: forward function *) -Definition betree_be_tree_new_fwd +Definition betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : - result (state * Betree_be_tree_t) + result (state * betree_BeTree_t) := - node_id_cnt <- betree_node_id_counter_new_fwd; - id <- betree_node_id_counter_fresh_id_fwd node_id_cnt; - p <- betree_store_leaf_node_fwd id BetreeListNil st; + node_id_cnt <- betree_NodeIdCounter_new; + id <- betree_NodeIdCounter_fresh_id node_id_cnt; + p <- betree_store_leaf_node id Betree_List_Nil st; let (st0, _) := p in - node_id_cnt0 <- betree_node_id_counter_fresh_id_back node_id_cnt; + node_id_cnt0 <- betree_NodeIdCounter_fresh_id_back node_id_cnt; Return (st0, {| - Betree_be_tree_params := + betree_BeTree_params := {| - Betree_params_min_flush_size := min_flush_size; - Betree_params_split_size := split_size + betree_Params_min_flush_size := min_flush_size; + betree_Params_split_size := split_size |}; - Betree_be_tree_node_id_cnt := node_id_cnt0; - Betree_be_tree_root := - (BetreeNodeLeaf {| Betree_leaf_id := id; Betree_leaf_size := 0%u64 |}) + betree_BeTree_node_id_cnt := node_id_cnt0; + betree_BeTree_root := + (Betree_Node_Leaf + {| betree_Leaf_id := id; betree_Leaf_size := 0%u64 |}) |}) . (** [betree_main::betree::BeTree::{6}::apply]: forward function *) -Definition betree_be_tree_apply_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (msg : Betree_message_t) +Definition betree_BeTree_apply + (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state * unit) := p <- - betree_node_apply_fwd n self.(Betree_be_tree_root) - self.(Betree_be_tree_params) self.(Betree_be_tree_node_id_cnt) key msg st; + betree_Node_apply n self.(betree_BeTree_root) self.(betree_BeTree_params) + self.(betree_BeTree_node_id_cnt) key msg st; let (st0, _) := p in _ <- - betree_node_apply_back n self.(Betree_be_tree_root) - self.(Betree_be_tree_params) self.(Betree_be_tree_node_id_cnt) key msg st; + betree_Node_apply_back n self.(betree_BeTree_root) + self.(betree_BeTree_params) self.(betree_BeTree_node_id_cnt) key msg st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) -Definition betree_be_tree_apply_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (msg : Betree_message_t) +Definition betree_BeTree_apply_back + (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : - result Betree_be_tree_t + result betree_BeTree_t := p <- - betree_node_apply_back n self.(Betree_be_tree_root) - self.(Betree_be_tree_params) self.(Betree_be_tree_node_id_cnt) key msg st; + betree_Node_apply_back n self.(betree_BeTree_root) + self.(betree_BeTree_params) self.(betree_BeTree_node_id_cnt) key msg st; let (n0, nic) := p in Return {| - Betree_be_tree_params := self.(Betree_be_tree_params); - Betree_be_tree_node_id_cnt := nic; - Betree_be_tree_root := n0 + betree_BeTree_params := self.(betree_BeTree_params); + betree_BeTree_node_id_cnt := nic; + betree_BeTree_root := n0 |} . (** [betree_main::betree::BeTree::{6}::insert]: forward function *) -Definition betree_be_tree_insert_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (value : u64) (st : state) : +Definition betree_BeTree_insert + (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state * unit) := - p <- betree_be_tree_apply_fwd n self key (BetreeMessageInsert value) st; + p <- betree_BeTree_apply n self key (Betree_Message_Insert value) st; let (st0, _) := p in - _ <- betree_be_tree_apply_back n self key (BetreeMessageInsert value) st; + _ <- betree_BeTree_apply_back n self key (Betree_Message_Insert value) st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) -Definition betree_be_tree_insert_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (value : u64) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_insert_back + (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : + result betree_BeTree_t := - betree_be_tree_apply_back n self key (BetreeMessageInsert value) st + betree_BeTree_apply_back n self key (Betree_Message_Insert value) st . (** [betree_main::betree::BeTree::{6}::delete]: forward function *) -Definition betree_be_tree_delete_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : +Definition betree_BeTree_delete + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * unit) := - p <- betree_be_tree_apply_fwd n self key BetreeMessageDelete st; + p <- betree_BeTree_apply n self key Betree_Message_Delete st; let (st0, _) := p in - _ <- betree_be_tree_apply_back n self key BetreeMessageDelete st; + _ <- betree_BeTree_apply_back n self key Betree_Message_Delete st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) -Definition betree_be_tree_delete_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_delete_back + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : + result betree_BeTree_t := - betree_be_tree_apply_back n self key BetreeMessageDelete st + betree_BeTree_apply_back n self key Betree_Message_Delete st . (** [betree_main::betree::BeTree::{6}::upsert]: forward function *) -Definition betree_be_tree_upsert_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) - (upd : Betree_upsert_fun_state_t) (st : state) : +Definition betree_BeTree_upsert + (n : nat) (self : betree_BeTree_t) (key : u64) + (upd : betree_UpsertFunState_t) (st : state) : result (state * unit) := - p <- betree_be_tree_apply_fwd n self key (BetreeMessageUpsert upd) st; + p <- betree_BeTree_apply n self key (Betree_Message_Upsert upd) st; let (st0, _) := p in - _ <- betree_be_tree_apply_back n self key (BetreeMessageUpsert upd) st; + _ <- betree_BeTree_apply_back n self key (Betree_Message_Upsert upd) st; Return (st0, tt) . (** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) -Definition betree_be_tree_upsert_back - (n : nat) (self : Betree_be_tree_t) (key : u64) - (upd : Betree_upsert_fun_state_t) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_upsert_back + (n : nat) (self : betree_BeTree_t) (key : u64) + (upd : betree_UpsertFunState_t) (st : state) : + result betree_BeTree_t := - betree_be_tree_apply_back n self key (BetreeMessageUpsert upd) st + betree_BeTree_apply_back n self key (Betree_Message_Upsert upd) st . (** [betree_main::betree::BeTree::{6}::lookup]: forward function *) -Definition betree_be_tree_lookup_fwd - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : +Definition betree_BeTree_lookup + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * (option u64)) := - betree_node_lookup_fwd n self.(Betree_be_tree_root) key st + betree_Node_lookup n self.(betree_BeTree_root) key st . (** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) -Definition betree_be_tree_lookup_back - (n : nat) (self : Betree_be_tree_t) (key : u64) (st : state) : - result Betree_be_tree_t +Definition betree_BeTree_lookup_back + (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : + result betree_BeTree_t := - n0 <- betree_node_lookup_back n self.(Betree_be_tree_root) key st; + n0 <- betree_Node_lookup_back n self.(betree_BeTree_root) key st; Return {| - Betree_be_tree_params := self.(Betree_be_tree_params); - Betree_be_tree_node_id_cnt := self.(Betree_be_tree_node_id_cnt); - Betree_be_tree_root := n0 + betree_BeTree_params := self.(betree_BeTree_params); + betree_BeTree_node_id_cnt := self.(betree_BeTree_node_id_cnt); + betree_BeTree_root := n0 |} . (** [betree_main::main]: forward function *) -Definition main_fwd : result unit := +Definition main : result unit := Return tt. (** Unit test for [betree_main::main] *) -Check (main_fwd )%return. +Check (main )%return. End BetreeMain_Funs . diff --git a/tests/coq/betree/BetreeMain_Opaque.v b/tests/coq/betree/BetreeMain_Opaque.v index ecd81b9d..eade90de 100644 --- a/tests/coq/betree/BetreeMain_Opaque.v +++ b/tests/coq/betree/BetreeMain_Opaque.v @@ -11,29 +11,29 @@ Import BetreeMain_Types. Module BetreeMain_Opaque. (** [betree_main::betree_utils::load_internal_node]: forward function *) -Axiom betree_utils_load_internal_node_fwd - : u64 -> state -> result (state * (Betree_list_t (u64 * Betree_message_t))) +Axiom betree_utils_load_internal_node + : u64 -> state -> result (state * (betree_List_t (u64 * betree_Message_t))) . (** [betree_main::betree_utils::store_internal_node]: forward function *) -Axiom betree_utils_store_internal_node_fwd +Axiom betree_utils_store_internal_node : - u64 -> Betree_list_t (u64 * Betree_message_t) -> state -> result (state * + u64 -> betree_List_t (u64 * betree_Message_t) -> state -> result (state * unit) . (** [betree_main::betree_utils::load_leaf_node]: forward function *) -Axiom betree_utils_load_leaf_node_fwd - : u64 -> state -> result (state * (Betree_list_t (u64 * u64))) +Axiom betree_utils_load_leaf_node + : u64 -> state -> result (state * (betree_List_t (u64 * u64))) . (** [betree_main::betree_utils::store_leaf_node]: forward function *) -Axiom betree_utils_store_leaf_node_fwd - : u64 -> Betree_list_t (u64 * u64) -> state -> result (state * unit) +Axiom betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) . (** [core::option::Option::{0}::unwrap]: forward function *) -Axiom core_option_option_unwrap_fwd : +Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/betree/BetreeMain_Types.v b/tests/coq/betree/BetreeMain_Types.v index 4a4e75aa..ee26622e 100644 --- a/tests/coq/betree/BetreeMain_Types.v +++ b/tests/coq/betree/BetreeMain_Types.v @@ -9,98 +9,98 @@ Local Open Scope Primitives_scope. Module BetreeMain_Types. (** [betree_main::betree::List] *) -Inductive Betree_list_t (T : Type) := -| BetreeListCons : T -> Betree_list_t T -> Betree_list_t T -| BetreeListNil : Betree_list_t T +Inductive betree_List_t (T : Type) := +| Betree_List_Cons : T -> betree_List_t T -> betree_List_t T +| Betree_List_Nil : betree_List_t T . -Arguments BetreeListCons {T} _ _. -Arguments BetreeListNil {T}. +Arguments Betree_List_Cons {T} _ _. +Arguments Betree_List_Nil {T}. (** [betree_main::betree::UpsertFunState] *) -Inductive Betree_upsert_fun_state_t := -| BetreeUpsertFunStateAdd : u64 -> Betree_upsert_fun_state_t -| BetreeUpsertFunStateSub : u64 -> Betree_upsert_fun_state_t +Inductive betree_UpsertFunState_t := +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t . (** [betree_main::betree::Message] *) -Inductive Betree_message_t := -| BetreeMessageInsert : u64 -> Betree_message_t -| BetreeMessageDelete : Betree_message_t -| BetreeMessageUpsert : Betree_upsert_fun_state_t -> Betree_message_t +Inductive betree_Message_t := +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t . (** [betree_main::betree::Leaf] *) -Record Betree_leaf_t := -mkBetree_leaf_t { - Betree_leaf_id : u64; Betree_leaf_size : u64; +Record betree_Leaf_t := +mkbetree_Leaf_t { + betree_Leaf_id : u64; betree_Leaf_size : u64; } . (** [betree_main::betree::Internal] *) -Inductive Betree_internal_t := -| mkBetree_internal_t : +Inductive betree_Internal_t := +| mkbetree_Internal_t : u64 -> u64 -> - Betree_node_t -> - Betree_node_t -> - Betree_internal_t + betree_Node_t -> + betree_Node_t -> + betree_Internal_t (** [betree_main::betree::Node] *) -with Betree_node_t := -| BetreeNodeInternal : Betree_internal_t -> Betree_node_t -| BetreeNodeLeaf : Betree_leaf_t -> Betree_node_t +with betree_Node_t := +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t . -Definition Betree_internal_id (x : Betree_internal_t) := - match x with | mkBetree_internal_t x0 _ _ _ => x0 end +Definition betree_Internal_id (x : betree_Internal_t) := + match x with | mkbetree_Internal_t x0 _ _ _ => x0 end . -Notation "x1 .(Betree_internal_id)" := (Betree_internal_id x1) (at level 9). +Notation "x1 .(betree_Internal_id)" := (betree_Internal_id x1) (at level 9). -Definition Betree_internal_pivot (x : Betree_internal_t) := - match x with | mkBetree_internal_t _ x0 _ _ => x0 end +Definition betree_Internal_pivot (x : betree_Internal_t) := + match x with | mkbetree_Internal_t _ x0 _ _ => x0 end . -Notation "x1 .(Betree_internal_pivot)" := (Betree_internal_pivot x1) +Notation "x1 .(betree_Internal_pivot)" := (betree_Internal_pivot x1) (at level 9) . -Definition Betree_internal_left (x : Betree_internal_t) := - match x with | mkBetree_internal_t _ _ x0 _ => x0 end +Definition betree_Internal_left (x : betree_Internal_t) := + match x with | mkbetree_Internal_t _ _ x0 _ => x0 end . -Notation "x1 .(Betree_internal_left)" := (Betree_internal_left x1) (at level 9) +Notation "x1 .(betree_Internal_left)" := (betree_Internal_left x1) (at level 9) . -Definition Betree_internal_right (x : Betree_internal_t) := - match x with | mkBetree_internal_t _ _ _ x0 => x0 end +Definition betree_Internal_right (x : betree_Internal_t) := + match x with | mkbetree_Internal_t _ _ _ x0 => x0 end . -Notation "x1 .(Betree_internal_right)" := (Betree_internal_right x1) +Notation "x1 .(betree_Internal_right)" := (betree_Internal_right x1) (at level 9) . (** [betree_main::betree::Params] *) -Record Betree_params_t := -mkBetree_params_t { - Betree_params_min_flush_size : u64; Betree_params_split_size : u64; +Record betree_Params_t := +mkbetree_Params_t { + betree_Params_min_flush_size : u64; betree_Params_split_size : u64; } . (** [betree_main::betree::NodeIdCounter] *) -Record Betree_node_id_counter_t := -mkBetree_node_id_counter_t { - Betree_node_id_counter_next_node_id : u64; +Record betree_NodeIdCounter_t := +mkbetree_NodeIdCounter_t { + betree_NodeIdCounter_next_node_id : u64; } . (** [betree_main::betree::BeTree] *) -Record Betree_be_tree_t := -mkBetree_be_tree_t { - Betree_be_tree_params : Betree_params_t; - Betree_be_tree_node_id_cnt : Betree_node_id_counter_t; - Betree_be_tree_root : Betree_node_t; +Record betree_BeTree_t := +mkbetree_BeTree_t { + betree_BeTree_params : betree_Params_t; + betree_BeTree_node_id_cnt : betree_NodeIdCounter_t; + betree_BeTree_root : betree_Node_t; } . diff --git a/tests/coq/betree/Primitives.v b/tests/coq/betree/Primitives.v index 8d6c9c8d..85e38f01 100644 --- a/tests/coq/betree/Primitives.v +++ b/tests/coq/betree/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -408,12 +410,75 @@ Definition core_i64_max := i64_max %i64. Definition core_i128_max := i64_max %i128. Axiom core_isize_max : isize. (** TODO *) -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -433,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -488,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index 054880d4..3ca52a9f 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -11,98 +11,101 @@ Import Hashmap_Types. Module Hashmap_Funs. (** [hashmap::hash_key]: forward function *) -Definition hash_key_fwd (k : usize) : result usize := +Definition hash_key (k : usize) : result usize := Return k. (** [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -Fixpoint hash_map_allocate_slots_loop_fwd - (T : Type) (n : nat) (slots : vec (List_t T)) (n0 : usize) : - result (vec (List_t T)) +Fixpoint hashMap_allocate_slots_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : + result (alloc_vec_Vec (List_t T)) := match n with | O => Fail_ OutOfFuel | S n1 => if n0 s> 0%usize then ( - slots0 <- vec_push_back (List_t T) slots ListNil; + slots0 <- alloc_vec_Vec_push (List_t T) slots List_Nil; n2 <- usize_sub n0 1%usize; - hash_map_allocate_slots_loop_fwd T n1 slots0 n2) + hashMap_allocate_slots_loop T n1 slots0 n2) else Return slots end . (** [hashmap::HashMap::{0}::allocate_slots]: forward function *) -Definition hash_map_allocate_slots_fwd - (T : Type) (n : nat) (slots : vec (List_t T)) (n0 : usize) : - result (vec (List_t T)) +Definition hashMap_allocate_slots + (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : + result (alloc_vec_Vec (List_t T)) := - hash_map_allocate_slots_loop_fwd T n slots n0 + hashMap_allocate_slots_loop T n slots n0 . (** [hashmap::HashMap::{0}::new_with_capacity]: forward function *) -Definition hash_map_new_with_capacity_fwd +Definition hashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (Hash_map_t T) + result (HashMap_t T) := - let v := vec_new (List_t T) in - slots <- hash_map_allocate_slots_fwd T n v capacity; + let v := alloc_vec_Vec_new (List_t T) in + slots <- hashMap_allocate_slots T n v capacity; i <- usize_mul capacity max_load_dividend; i0 <- usize_div i max_load_divisor; Return {| - Hash_map_num_entries := 0%usize; - Hash_map_max_load_factor := (max_load_dividend, max_load_divisor); - Hash_map_max_load := i0; - Hash_map_slots := slots + hashMap_num_entries := 0%usize; + hashMap_max_load_factor := (max_load_dividend, max_load_divisor); + hashMap_max_load := i0; + hashMap_slots := slots |} . (** [hashmap::HashMap::{0}::new]: forward function *) -Definition hash_map_new_fwd (T : Type) (n : nat) : result (Hash_map_t T) := - hash_map_new_with_capacity_fwd T n 32%usize 4%usize 5%usize +Definition hashMap_new (T : Type) (n : nat) : result (HashMap_t T) := + hashMap_new_with_capacity T n 32%usize 4%usize 5%usize . (** [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hash_map_clear_loop_fwd_back - (T : Type) (n : nat) (slots : vec (List_t T)) (i : usize) : - result (vec (List_t T)) +Fixpoint hashMap_clear_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (i : usize) : + result (alloc_vec_Vec (List_t T)) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (List_t T) slots in + let i0 := alloc_vec_Vec_len (List_t T) slots in if i s< i0 then ( i1 <- usize_add i 1%usize; - slots0 <- vec_index_mut_back (List_t T) slots i ListNil; - hash_map_clear_loop_fwd_back T n0 slots0 i1) + slots0 <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + slots i List_Nil; + hashMap_clear_loop T n0 slots0 i1) else Return slots end . (** [hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_clear_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) : result (Hash_map_t T) := - v <- hash_map_clear_loop_fwd_back T n self.(Hash_map_slots) 0%usize; +Definition hashMap_clear + (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := + v <- hashMap_clear_loop T n self.(hashMap_slots) 0%usize; Return {| - Hash_map_num_entries := 0%usize; - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := 0%usize; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} . (** [hashmap::HashMap::{0}::len]: forward function *) -Definition hash_map_len_fwd (T : Type) (self : Hash_map_t T) : result usize := - Return self.(Hash_map_num_entries) +Definition hashMap_len (T : Type) (self : HashMap_t T) : result usize := + Return self.(hashMap_num_entries) . (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -Fixpoint hash_map_insert_in_list_loop_fwd +Fixpoint hashMap_insert_in_list_loop (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool := @@ -110,25 +113,25 @@ Fixpoint hash_map_insert_in_list_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key then Return false - else hash_map_insert_in_list_loop_fwd T n0 key value tl - | ListNil => Return true + else hashMap_insert_in_list_loop T n0 key value tl + | List_Nil => Return true end end . (** [hashmap::HashMap::{0}::insert_in_list]: forward function *) -Definition hash_map_insert_in_list_fwd +Definition hashMap_insert_in_list (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool := - hash_map_insert_in_list_loop_fwd T n key value ls + hashMap_insert_in_list_loop T n key value ls . (** [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -Fixpoint hash_map_insert_in_list_loop_back +Fixpoint hashMap_insert_in_list_loop_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) := @@ -136,255 +139,275 @@ Fixpoint hash_map_insert_in_list_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key - then Return (ListCons ckey value tl) + then Return (List_Cons ckey value tl) else ( - tl0 <- hash_map_insert_in_list_loop_back T n0 key value tl; - Return (ListCons ckey cvalue tl0)) - | ListNil => let l := ListNil in Return (ListCons key value l) + tl0 <- hashMap_insert_in_list_loop_back T n0 key value tl; + Return (List_Cons ckey cvalue tl0)) + | List_Nil => let l := List_Nil in Return (List_Cons key value l) end end . (** [hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -Definition hash_map_insert_in_list_back +Definition hashMap_insert_in_list_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) := - hash_map_insert_in_list_loop_back T n key value ls + hashMap_insert_in_list_loop_back T n key value ls . (** [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_insert_no_resize_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) (value : T) : - result (Hash_map_t T) +Definition hashMap_insert_no_resize + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : + result (HashMap_t T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - inserted <- hash_map_insert_in_list_fwd T n key value l; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + inserted <- hashMap_insert_in_list T n key value l; if inserted then ( - i0 <- usize_add self.(Hash_map_num_entries) 1%usize; - l0 <- hash_map_insert_in_list_back T n key value l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + i0 <- usize_add self.(hashMap_num_entries) 1%usize; + l0 <- hashMap_insert_in_list_back T n key value l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := i0; - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := i0; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |}) else ( - l0 <- hash_map_insert_in_list_back T n key value l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + l0 <- hashMap_insert_in_list_back T n key value l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |}) . (** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hash_map_move_elements_from_list_loop_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (ls : List_t T) : - result (Hash_map_t T) +Fixpoint hashMap_move_elements_from_list_loop + (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : + result (HashMap_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons k v tl => - ntable0 <- hash_map_insert_no_resize_fwd_back T n0 ntable k v; - hash_map_move_elements_from_list_loop_fwd_back T n0 ntable0 tl - | ListNil => Return ntable + | List_Cons k v tl => + ntable0 <- hashMap_insert_no_resize T n0 ntable k v; + hashMap_move_elements_from_list_loop T n0 ntable0 tl + | List_Nil => Return ntable end end . (** [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_move_elements_from_list_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (ls : List_t T) : - result (Hash_map_t T) +Definition hashMap_move_elements_from_list + (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : + result (HashMap_t T) := - hash_map_move_elements_from_list_loop_fwd_back T n ntable ls + hashMap_move_elements_from_list_loop T n ntable ls . (** [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hash_map_move_elements_loop_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (slots : vec (List_t T)) - (i : usize) : - result ((Hash_map_t T) * (vec (List_t T))) +Fixpoint hashMap_move_elements_loop + (T : Type) (n : nat) (ntable : HashMap_t T) + (slots : alloc_vec_Vec (List_t T)) (i : usize) : + result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (List_t T) slots in + let i0 := alloc_vec_Vec_len (List_t T) slots in if i s< i0 then ( - l <- vec_index_mut_fwd (List_t T) slots i; - let ls := mem_replace_fwd (List_t T) l ListNil in - ntable0 <- hash_map_move_elements_from_list_fwd_back T n0 ntable ls; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + slots i; + let ls := core_mem_replace (List_t T) l List_Nil in + ntable0 <- hashMap_move_elements_from_list T n0 ntable ls; i1 <- usize_add i 1%usize; - let l0 := mem_replace_back (List_t T) l ListNil in - slots0 <- vec_index_mut_back (List_t T) slots i l0; - hash_map_move_elements_loop_fwd_back T n0 ntable0 slots0 i1) + let l0 := core_mem_replace_back (List_t T) l List_Nil in + slots0 <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + slots i l0; + hashMap_move_elements_loop T n0 ntable0 slots0 i1) else Return (ntable, slots) end . (** [hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_move_elements_fwd_back - (T : Type) (n : nat) (ntable : Hash_map_t T) (slots : vec (List_t T)) - (i : usize) : - result ((Hash_map_t T) * (vec (List_t T))) +Definition hashMap_move_elements + (T : Type) (n : nat) (ntable : HashMap_t T) + (slots : alloc_vec_Vec (List_t T)) (i : usize) : + result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := - hash_map_move_elements_loop_fwd_back T n ntable slots i + hashMap_move_elements_loop T n ntable slots i . (** [hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_try_resize_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) : result (Hash_map_t T) := +Definition hashMap_try_resize + (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := max_usize <- scalar_cast U32 Usize core_u32_max; - let capacity := vec_len (List_t T) self.(Hash_map_slots) in + let capacity := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in n1 <- usize_div max_usize 2%usize; - let (i, i0) := self.(Hash_map_max_load_factor) in + let (i, i0) := self.(hashMap_max_load_factor) in i1 <- usize_div n1 i; if capacity s<= i1 then ( i2 <- usize_mul capacity 2%usize; - ntable <- hash_map_new_with_capacity_fwd T n i2 i i0; - p <- - hash_map_move_elements_fwd_back T n ntable self.(Hash_map_slots) 0%usize; + ntable <- hashMap_new_with_capacity T n i2 i i0; + p <- hashMap_move_elements T n ntable self.(hashMap_slots) 0%usize; let (ntable0, _) := p in Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := (i, i0); - Hash_map_max_load := ntable0.(Hash_map_max_load); - Hash_map_slots := ntable0.(Hash_map_slots) + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := (i, i0); + hashMap_max_load := ntable0.(hashMap_max_load); + hashMap_slots := ntable0.(hashMap_slots) |}) else Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := (i, i0); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := self.(Hash_map_slots) + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := (i, i0); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := self.(hashMap_slots) |} . (** [hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hash_map_insert_fwd_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) (value : T) : - result (Hash_map_t T) +Definition hashMap_insert + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : + result (HashMap_t T) := - self0 <- hash_map_insert_no_resize_fwd_back T n self key value; - i <- hash_map_len_fwd T self0; - if i s> self0.(Hash_map_max_load) - then hash_map_try_resize_fwd_back T n self0 + self0 <- hashMap_insert_no_resize T n self key value; + i <- hashMap_len T self0; + if i s> self0.(hashMap_max_load) + then hashMap_try_resize T n self0 else Return self0 . (** [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -Fixpoint hash_map_contains_key_in_list_loop_fwd +Fixpoint hashMap_contains_key_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey t tl => + | List_Cons ckey t tl => if ckey s= key then Return true - else hash_map_contains_key_in_list_loop_fwd T n0 key tl - | ListNil => Return false + else hashMap_contains_key_in_list_loop T n0 key tl + | List_Nil => Return false end end . (** [hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -Definition hash_map_contains_key_in_list_fwd +Definition hashMap_contains_key_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := - hash_map_contains_key_in_list_loop_fwd T n key ls + hashMap_contains_key_in_list_loop T n key ls . (** [hashmap::HashMap::{0}::contains_key]: forward function *) -Definition hash_map_contains_key_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : result bool := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_contains_key + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result bool := + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (List_t T) self.(Hash_map_slots) hash_mod; - hash_map_contains_key_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + hashMap_contains_key_in_list T n key l . (** [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -Fixpoint hash_map_get_in_list_loop_fwd +Fixpoint hashMap_get_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hash_map_get_in_list_loop_fwd T n0 key tl - | ListNil => Fail_ Failure + else hashMap_get_in_list_loop T n0 key tl + | List_Nil => Fail_ Failure end end . (** [hashmap::HashMap::{0}::get_in_list]: forward function *) -Definition hash_map_get_in_list_fwd +Definition hashMap_get_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := - hash_map_get_in_list_loop_fwd T n key ls + hashMap_get_in_list_loop T n key ls . (** [hashmap::HashMap::{0}::get]: forward function *) -Definition hash_map_get_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : result T := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_get + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (List_t T) self.(Hash_map_slots) hash_mod; - hash_map_get_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + hashMap_get_in_list T n key l . (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -Fixpoint hash_map_get_mut_in_list_loop_fwd +Fixpoint hashMap_get_mut_in_list_loop (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hash_map_get_mut_in_list_loop_fwd T n0 tl key - | ListNil => Fail_ Failure + else hashMap_get_mut_in_list_loop T n0 tl key + | List_Nil => Fail_ Failure end end . (** [hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -Definition hash_map_get_mut_in_list_fwd +Definition hashMap_get_mut_in_list (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := - hash_map_get_mut_in_list_loop_fwd T n ls key + hashMap_get_mut_in_list_loop T n ls key . (** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -Fixpoint hash_map_get_mut_in_list_loop_back +Fixpoint hashMap_get_mut_in_list_loop_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) := @@ -392,196 +415,219 @@ Fixpoint hash_map_get_mut_in_list_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey cvalue tl => + | List_Cons ckey cvalue tl => if ckey s= key - then Return (ListCons ckey ret tl) + then Return (List_Cons ckey ret tl) else ( - tl0 <- hash_map_get_mut_in_list_loop_back T n0 tl key ret; - Return (ListCons ckey cvalue tl0)) - | ListNil => Fail_ Failure + tl0 <- hashMap_get_mut_in_list_loop_back T n0 tl key ret; + Return (List_Cons ckey cvalue tl0)) + | List_Nil => Fail_ Failure end end . (** [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -Definition hash_map_get_mut_in_list_back +Definition hashMap_get_mut_in_list_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) := - hash_map_get_mut_in_list_loop_back T n ls key ret + hashMap_get_mut_in_list_loop_back T n ls key ret . (** [hashmap::HashMap::{0}::get_mut]: forward function *) -Definition hash_map_get_mut_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : result T := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in +Definition hashMap_get_mut + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - hash_map_get_mut_in_list_fwd T n l key + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + hashMap_get_mut_in_list T n l key . (** [hashmap::HashMap::{0}::get_mut]: backward function 0 *) -Definition hash_map_get_mut_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) (ret : T) : - result (Hash_map_t T) +Definition hashMap_get_mut_back + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (ret : T) : + result (HashMap_t T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - l0 <- hash_map_get_mut_in_list_back T n l key ret; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + l0 <- hashMap_get_mut_in_list_back T n l key ret; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} . (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -Fixpoint hash_map_remove_from_list_loop_fwd +Fixpoint hashMap_remove_from_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey t tl => + | List_Cons ckey t tl => if ckey s= key then - let mv_ls := mem_replace_fwd (List_t T) (ListCons ckey t tl) ListNil in + let mv_ls := core_mem_replace (List_t T) (List_Cons ckey t tl) List_Nil + in match mv_ls with - | ListCons i cvalue tl0 => Return (Some cvalue) - | ListNil => Fail_ Failure + | List_Cons i cvalue tl0 => Return (Some cvalue) + | List_Nil => Fail_ Failure end - else hash_map_remove_from_list_loop_fwd T n0 key tl - | ListNil => Return None + else hashMap_remove_from_list_loop T n0 key tl + | List_Nil => Return None end end . (** [hashmap::HashMap::{0}::remove_from_list]: forward function *) -Definition hash_map_remove_from_list_fwd +Definition hashMap_remove_from_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := - hash_map_remove_from_list_loop_fwd T n key ls + hashMap_remove_from_list_loop T n key ls . (** [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -Fixpoint hash_map_remove_from_list_loop_back +Fixpoint hashMap_remove_from_list_loop_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons ckey t tl => + | List_Cons ckey t tl => if ckey s= key then - let mv_ls := mem_replace_fwd (List_t T) (ListCons ckey t tl) ListNil in + let mv_ls := core_mem_replace (List_t T) (List_Cons ckey t tl) List_Nil + in match mv_ls with - | ListCons i cvalue tl0 => Return tl0 - | ListNil => Fail_ Failure + | List_Cons i cvalue tl0 => Return tl0 + | List_Nil => Fail_ Failure end else ( - tl0 <- hash_map_remove_from_list_loop_back T n0 key tl; - Return (ListCons ckey t tl0)) - | ListNil => Return ListNil + tl0 <- hashMap_remove_from_list_loop_back T n0 key tl; + Return (List_Cons ckey t tl0)) + | List_Nil => Return List_Nil end end . (** [hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -Definition hash_map_remove_from_list_back +Definition hashMap_remove_from_list_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := - hash_map_remove_from_list_loop_back T n key ls + hashMap_remove_from_list_loop_back T n key ls . (** [hashmap::HashMap::{0}::remove]: forward function *) -Definition hash_map_remove_fwd - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : +Definition hashMap_remove + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result (option T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - x <- hash_map_remove_from_list_fwd T n key l; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + x <- hashMap_remove_from_list T n key l; match x with | None => Return None | Some x0 => - _ <- usize_sub self.(Hash_map_num_entries) 1%usize; Return (Some x0) + _ <- usize_sub self.(hashMap_num_entries) 1%usize; Return (Some x0) end . (** [hashmap::HashMap::{0}::remove]: backward function 0 *) -Definition hash_map_remove_back - (T : Type) (n : nat) (self : Hash_map_t T) (key : usize) : - result (Hash_map_t T) +Definition hashMap_remove_back + (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : + result (HashMap_t T) := - hash <- hash_key_fwd key; - let i := vec_len (List_t T) self.(Hash_map_slots) in + hash <- hash_key key; + let i := alloc_vec_Vec_len (List_t T) self.(hashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_mut_fwd (List_t T) self.(Hash_map_slots) hash_mod; - x <- hash_map_remove_from_list_fwd T n key l; + l <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod; + x <- hashMap_remove_from_list T n key l; match x with | None => - l0 <- hash_map_remove_from_list_back T n key l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + l0 <- hashMap_remove_from_list_back T n key l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := self.(Hash_map_num_entries); - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := self.(hashMap_num_entries); + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} | Some x0 => - i0 <- usize_sub self.(Hash_map_num_entries) 1%usize; - l0 <- hash_map_remove_from_list_back T n key l; - v <- vec_index_mut_back (List_t T) self.(Hash_map_slots) hash_mod l0; + i0 <- usize_sub self.(hashMap_num_entries) 1%usize; + l0 <- hashMap_remove_from_list_back T n key l; + v <- + alloc_vec_Vec_index_mut_back (List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + self.(hashMap_slots) hash_mod l0; Return {| - Hash_map_num_entries := i0; - Hash_map_max_load_factor := self.(Hash_map_max_load_factor); - Hash_map_max_load := self.(Hash_map_max_load); - Hash_map_slots := v + hashMap_num_entries := i0; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := v |} end . (** [hashmap::test1]: forward function *) -Definition test1_fwd (n : nat) : result unit := - hm <- hash_map_new_fwd u64 n; - hm0 <- hash_map_insert_fwd_back u64 n hm 0%usize 42%u64; - hm1 <- hash_map_insert_fwd_back u64 n hm0 128%usize 18%u64; - hm2 <- hash_map_insert_fwd_back u64 n hm1 1024%usize 138%u64; - hm3 <- hash_map_insert_fwd_back u64 n hm2 1056%usize 256%u64; - i <- hash_map_get_fwd u64 n hm3 128%usize; +Definition test1 (n : nat) : result unit := + hm <- hashMap_new u64 n; + hm0 <- hashMap_insert u64 n hm 0%usize 42%u64; + hm1 <- hashMap_insert u64 n hm0 128%usize 18%u64; + hm2 <- hashMap_insert u64 n hm1 1024%usize 138%u64; + hm3 <- hashMap_insert u64 n hm2 1056%usize 256%u64; + i <- hashMap_get u64 n hm3 128%usize; if negb (i s= 18%u64) then Fail_ Failure else ( - hm4 <- hash_map_get_mut_back u64 n hm3 1024%usize 56%u64; - i0 <- hash_map_get_fwd u64 n hm4 1024%usize; + hm4 <- hashMap_get_mut_back u64 n hm3 1024%usize 56%u64; + i0 <- hashMap_get u64 n hm4 1024%usize; if negb (i0 s= 56%u64) then Fail_ Failure else ( - x <- hash_map_remove_fwd u64 n hm4 1024%usize; + x <- hashMap_remove u64 n hm4 1024%usize; match x with | None => Fail_ Failure | Some x0 => if negb (x0 s= 56%u64) then Fail_ Failure else ( - hm5 <- hash_map_remove_back u64 n hm4 1024%usize; - i1 <- hash_map_get_fwd u64 n hm5 0%usize; + hm5 <- hashMap_remove_back u64 n hm4 1024%usize; + i1 <- hashMap_get u64 n hm5 0%usize; if negb (i1 s= 42%u64) then Fail_ Failure else ( - i2 <- hash_map_get_fwd u64 n hm5 128%usize; + i2 <- hashMap_get u64 n hm5 128%usize; if negb (i2 s= 18%u64) then Fail_ Failure else ( - i3 <- hash_map_get_fwd u64 n hm5 1056%usize; + i3 <- hashMap_get u64 n hm5 1056%usize; if negb (i3 s= 256%u64) then Fail_ Failure else Return tt))) end)) . diff --git a/tests/coq/hashmap/Hashmap_Types.v b/tests/coq/hashmap/Hashmap_Types.v index dbde6be9..63d30eeb 100644 --- a/tests/coq/hashmap/Hashmap_Types.v +++ b/tests/coq/hashmap/Hashmap_Types.v @@ -10,27 +10,27 @@ Module Hashmap_Types. (** [hashmap::List] *) Inductive List_t (T : Type) := -| ListCons : usize -> T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : usize -> T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _ _. -Arguments ListNil {T}. +Arguments List_Cons {T} _ _ _. +Arguments List_Nil {T}. (** [hashmap::HashMap] *) -Record Hash_map_t (T : Type) := -mkHash_map_t { - Hash_map_num_entries : usize; - Hash_map_max_load_factor : (usize * usize); - Hash_map_max_load : usize; - Hash_map_slots : vec (List_t T); +Record HashMap_t (T : Type) := +mkHashMap_t { + hashMap_num_entries : usize; + hashMap_max_load_factor : (usize * usize); + hashMap_max_load : usize; + hashMap_slots : alloc_vec_Vec (List_t T); } . -Arguments mkHash_map_t {T} _ _ _ _. -Arguments Hash_map_num_entries {T}. -Arguments Hash_map_max_load_factor {T}. -Arguments Hash_map_max_load {T}. -Arguments Hash_map_slots {T}. +Arguments mkHashMap_t {T} _ _ _ _. +Arguments hashMap_num_entries {T}. +Arguments hashMap_max_load_factor {T}. +Arguments hashMap_max_load {T}. +Arguments hashMap_slots {T}. End Hashmap_Types . diff --git a/tests/coq/hashmap/Primitives.v b/tests/coq/hashmap/Primitives.v index 8d6c9c8d..85e38f01 100644 --- a/tests/coq/hashmap/Primitives.v +++ b/tests/coq/hashmap/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -408,12 +410,75 @@ Definition core_i64_max := i64_max %i64. Definition core_i128_max := i64_max %i128. Axiom core_isize_max : isize. (** TODO *) -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -433,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -488,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index a85adbf2..eac78186 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -13,652 +13,668 @@ Import HashmapMain_Opaque. Module HashmapMain_Funs. (** [hashmap_main::hashmap::hash_key]: forward function *) -Definition hashmap_hash_key_fwd (k : usize) : result usize := +Definition hashmap_hash_key (k : usize) : result usize := Return k. (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) -Fixpoint hashmap_hash_map_allocate_slots_loop_fwd - (T : Type) (n : nat) (slots : vec (Hashmap_list_t T)) (n0 : usize) : - result (vec (Hashmap_list_t T)) +Fixpoint hashmap_HashMap_allocate_slots_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) + : + result (alloc_vec_Vec (hashmap_List_t T)) := match n with | O => Fail_ OutOfFuel | S n1 => if n0 s> 0%usize then ( - slots0 <- vec_push_back (Hashmap_list_t T) slots HashmapListNil; + slots0 <- alloc_vec_Vec_push (hashmap_List_t T) slots Hashmap_List_Nil; n2 <- usize_sub n0 1%usize; - hashmap_hash_map_allocate_slots_loop_fwd T n1 slots0 n2) + hashmap_HashMap_allocate_slots_loop T n1 slots0 n2) else Return slots end . (** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function *) -Definition hashmap_hash_map_allocate_slots_fwd - (T : Type) (n : nat) (slots : vec (Hashmap_list_t T)) (n0 : usize) : - result (vec (Hashmap_list_t T)) +Definition hashmap_HashMap_allocate_slots + (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) + : + result (alloc_vec_Vec (hashmap_List_t T)) := - hashmap_hash_map_allocate_slots_loop_fwd T n slots n0 + hashmap_HashMap_allocate_slots_loop T n slots n0 . (** [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function *) -Definition hashmap_hash_map_new_with_capacity_fwd +Definition hashmap_HashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : - result (Hashmap_hash_map_t T) + result (hashmap_HashMap_t T) := - let v := vec_new (Hashmap_list_t T) in - slots <- hashmap_hash_map_allocate_slots_fwd T n v capacity; + let v := alloc_vec_Vec_new (hashmap_List_t T) in + slots <- hashmap_HashMap_allocate_slots T n v capacity; i <- usize_mul capacity max_load_dividend; i0 <- usize_div i max_load_divisor; Return {| - Hashmap_hash_map_num_entries := 0%usize; - Hashmap_hash_map_max_load_factor := (max_load_dividend, max_load_divisor); - Hashmap_hash_map_max_load := i0; - Hashmap_hash_map_slots := slots + hashmap_HashMap_num_entries := 0%usize; + hashmap_HashMap_max_load_factor := (max_load_dividend, max_load_divisor); + hashmap_HashMap_max_load := i0; + hashmap_HashMap_slots := slots |} . (** [hashmap_main::hashmap::HashMap::{0}::new]: forward function *) -Definition hashmap_hash_map_new_fwd - (T : Type) (n : nat) : result (Hashmap_hash_map_t T) := - hashmap_hash_map_new_with_capacity_fwd T n 32%usize 4%usize 5%usize +Definition hashmap_HashMap_new + (T : Type) (n : nat) : result (hashmap_HashMap_t T) := + hashmap_HashMap_new_with_capacity T n 32%usize 4%usize 5%usize . (** [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hashmap_hash_map_clear_loop_fwd_back - (T : Type) (n : nat) (slots : vec (Hashmap_list_t T)) (i : usize) : - result (vec (Hashmap_list_t T)) +Fixpoint hashmap_HashMap_clear_loop + (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : + result (alloc_vec_Vec (hashmap_List_t T)) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (Hashmap_list_t T) slots in + let i0 := alloc_vec_Vec_len (hashmap_List_t T) slots in if i s< i0 then ( i1 <- usize_add i 1%usize; - slots0 <- vec_index_mut_back (Hashmap_list_t T) slots i HashmapListNil; - hashmap_hash_map_clear_loop_fwd_back T n0 slots0 i1) + slots0 <- + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) slots i Hashmap_List_Nil; + hashmap_HashMap_clear_loop T n0 slots0 i1) else Return slots end . (** [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_clear_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_clear + (T : Type) (n : nat) (self : hashmap_HashMap_t T) : + result (hashmap_HashMap_t T) := - v <- - hashmap_hash_map_clear_loop_fwd_back T n self.(Hashmap_hash_map_slots) - 0%usize; + v <- hashmap_HashMap_clear_loop T n self.(hashmap_HashMap_slots) 0%usize; Return {| - Hashmap_hash_map_num_entries := 0%usize; - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := 0%usize; + hashmap_HashMap_max_load_factor := self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} . (** [hashmap_main::hashmap::HashMap::{0}::len]: forward function *) -Definition hashmap_hash_map_len_fwd - (T : Type) (self : Hashmap_hash_map_t T) : result usize := - Return self.(Hashmap_hash_map_num_entries) +Definition hashmap_HashMap_len + (T : Type) (self : hashmap_HashMap_t T) : result usize := + Return self.(hashmap_HashMap_num_entries) . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_insert_in_list_loop_fwd - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : +Fixpoint hashmap_HashMap_insert_in_list_loop + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key then Return false - else hashmap_hash_map_insert_in_list_loop_fwd T n0 key value tl - | HashmapListNil => Return true + else hashmap_HashMap_insert_in_list_loop T n0 key value tl + | Hashmap_List_Nil => Return true end end . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function *) -Definition hashmap_hash_map_insert_in_list_fwd - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : +Definition hashmap_HashMap_insert_in_list + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool := - hashmap_hash_map_insert_in_list_loop_fwd T n key value ls + hashmap_HashMap_insert_in_list_loop T n key value ls . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) -Fixpoint hashmap_hash_map_insert_in_list_loop_back - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Fixpoint hashmap_HashMap_insert_in_list_loop_back + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key - then Return (HashmapListCons ckey value tl) + then Return (Hashmap_List_Cons ckey value tl) else ( - tl0 <- hashmap_hash_map_insert_in_list_loop_back T n0 key value tl; - Return (HashmapListCons ckey cvalue tl0)) - | HashmapListNil => - let l := HashmapListNil in Return (HashmapListCons key value l) + tl0 <- hashmap_HashMap_insert_in_list_loop_back T n0 key value tl; + Return (Hashmap_List_Cons ckey cvalue tl0)) + | Hashmap_List_Nil => + let l := Hashmap_List_Nil in Return (Hashmap_List_Cons key value l) end end . (** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) -Definition hashmap_hash_map_insert_in_list_back - (T : Type) (n : nat) (key : usize) (value : T) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Definition hashmap_HashMap_insert_in_list_back + (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := - hashmap_hash_map_insert_in_list_loop_back T n key value ls + hashmap_HashMap_insert_in_list_loop_back T n key value ls . (** [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_insert_no_resize_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) (value : T) - : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_insert_no_resize + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : + result (hashmap_HashMap_t T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - inserted <- hashmap_hash_map_insert_in_list_fwd T n key value l; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + inserted <- hashmap_HashMap_insert_in_list T n key value l; if inserted then ( - i0 <- usize_add self.(Hashmap_hash_map_num_entries) 1%usize; - l0 <- hashmap_hash_map_insert_in_list_back T n key value l; + i0 <- usize_add self.(hashmap_HashMap_num_entries) 1%usize; + l0 <- hashmap_HashMap_insert_in_list_back T n key value l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := i0; - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := i0; + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |}) else ( - l0 <- hashmap_hash_map_insert_in_list_back T n key value l; + l0 <- hashmap_HashMap_insert_in_list_back T n key value l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |}) . (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hashmap_hash_map_move_elements_from_list_loop_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) (ls : Hashmap_list_t T) - : - result (Hashmap_hash_map_t T) +Fixpoint hashmap_HashMap_move_elements_from_list_loop + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : + result (hashmap_HashMap_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons k v tl => - ntable0 <- hashmap_hash_map_insert_no_resize_fwd_back T n0 ntable k v; - hashmap_hash_map_move_elements_from_list_loop_fwd_back T n0 ntable0 tl - | HashmapListNil => Return ntable + | Hashmap_List_Cons k v tl => + ntable0 <- hashmap_HashMap_insert_no_resize T n0 ntable k v; + hashmap_HashMap_move_elements_from_list_loop T n0 ntable0 tl + | Hashmap_List_Nil => Return ntable end end . (** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_move_elements_from_list_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) (ls : Hashmap_list_t T) - : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_move_elements_from_list + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : + result (hashmap_HashMap_t T) := - hashmap_hash_map_move_elements_from_list_loop_fwd_back T n ntable ls + hashmap_HashMap_move_elements_from_list_loop T n ntable ls . (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint hashmap_hash_map_move_elements_loop_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) - (slots : vec (Hashmap_list_t T)) (i : usize) : - result ((Hashmap_hash_map_t T) * (vec (Hashmap_list_t T))) +Fixpoint hashmap_HashMap_move_elements_loop + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) + (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : + result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len (Hashmap_list_t T) slots in + let i0 := alloc_vec_Vec_len (hashmap_List_t T) slots in if i s< i0 then ( - l <- vec_index_mut_fwd (Hashmap_list_t T) slots i; - let ls := mem_replace_fwd (Hashmap_list_t T) l HashmapListNil in - ntable0 <- - hashmap_hash_map_move_elements_from_list_fwd_back T n0 ntable ls; + l <- + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) slots i; + let ls := core_mem_replace (hashmap_List_t T) l Hashmap_List_Nil in + ntable0 <- hashmap_HashMap_move_elements_from_list T n0 ntable ls; i1 <- usize_add i 1%usize; - let l0 := mem_replace_back (Hashmap_list_t T) l HashmapListNil in - slots0 <- vec_index_mut_back (Hashmap_list_t T) slots i l0; - hashmap_hash_map_move_elements_loop_fwd_back T n0 ntable0 slots0 i1) + let l0 := core_mem_replace_back (hashmap_List_t T) l Hashmap_List_Nil in + slots0 <- + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) slots i l0; + hashmap_HashMap_move_elements_loop T n0 ntable0 slots0 i1) else Return (ntable, slots) end . (** [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_move_elements_fwd_back - (T : Type) (n : nat) (ntable : Hashmap_hash_map_t T) - (slots : vec (Hashmap_list_t T)) (i : usize) : - result ((Hashmap_hash_map_t T) * (vec (Hashmap_list_t T))) +Definition hashmap_HashMap_move_elements + (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) + (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : + result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := - hashmap_hash_map_move_elements_loop_fwd_back T n ntable slots i + hashmap_HashMap_move_elements_loop T n ntable slots i . (** [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_try_resize_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_try_resize + (T : Type) (n : nat) (self : hashmap_HashMap_t T) : + result (hashmap_HashMap_t T) := max_usize <- scalar_cast U32 Usize core_u32_max; - let capacity := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + let capacity := + alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in n1 <- usize_div max_usize 2%usize; - let (i, i0) := self.(Hashmap_hash_map_max_load_factor) in + let (i, i0) := self.(hashmap_HashMap_max_load_factor) in i1 <- usize_div n1 i; if capacity s<= i1 then ( i2 <- usize_mul capacity 2%usize; - ntable <- hashmap_hash_map_new_with_capacity_fwd T n i2 i i0; + ntable <- hashmap_HashMap_new_with_capacity T n i2 i i0; p <- - hashmap_hash_map_move_elements_fwd_back T n ntable - self.(Hashmap_hash_map_slots) 0%usize; + hashmap_HashMap_move_elements T n ntable self.(hashmap_HashMap_slots) + 0%usize; let (ntable0, _) := p in Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := (i, i0); - Hashmap_hash_map_max_load := ntable0.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := ntable0.(Hashmap_hash_map_slots) + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := (i, i0); + hashmap_HashMap_max_load := ntable0.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := ntable0.(hashmap_HashMap_slots) |}) else Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := (i, i0); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := self.(Hashmap_hash_map_slots) + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := (i, i0); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := self.(hashmap_HashMap_slots) |} . (** [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition hashmap_hash_map_insert_fwd_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) (value : T) - : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_insert + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : + result (hashmap_HashMap_t T) := - self0 <- hashmap_hash_map_insert_no_resize_fwd_back T n self key value; - i <- hashmap_hash_map_len_fwd T self0; - if i s> self0.(Hashmap_hash_map_max_load) - then hashmap_hash_map_try_resize_fwd_back T n self0 + self0 <- hashmap_HashMap_insert_no_resize T n self key value; + i <- hashmap_HashMap_len T self0; + if i s> self0.(hashmap_HashMap_max_load) + then hashmap_HashMap_try_resize T n self0 else Return self0 . (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_contains_key_in_list_loop_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result bool := +Fixpoint hashmap_HashMap_contains_key_in_list_loop + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey t tl => + | Hashmap_List_Cons ckey t tl => if ckey s= key then Return true - else hashmap_hash_map_contains_key_in_list_loop_fwd T n0 key tl - | HashmapListNil => Return false + else hashmap_HashMap_contains_key_in_list_loop T n0 key tl + | Hashmap_List_Nil => Return false end end . (** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function *) -Definition hashmap_hash_map_contains_key_in_list_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result bool := - hashmap_hash_map_contains_key_in_list_loop_fwd T n key ls +Definition hashmap_HashMap_contains_key_in_list + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := + hashmap_HashMap_contains_key_in_list_loop T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function *) -Definition hashmap_hash_map_contains_key_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : +Definition hashmap_HashMap_contains_key + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result bool := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - hashmap_hash_map_contains_key_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + hashmap_HashMap_contains_key_in_list T n key l . (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_get_in_list_loop_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result T := +Fixpoint hashmap_HashMap_get_in_list_loop + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hashmap_hash_map_get_in_list_loop_fwd T n0 key tl - | HashmapListNil => Fail_ Failure + else hashmap_HashMap_get_in_list_loop T n0 key tl + | Hashmap_List_Nil => Fail_ Failure end end . (** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function *) -Definition hashmap_hash_map_get_in_list_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : result T := - hashmap_hash_map_get_in_list_loop_fwd T n key ls +Definition hashmap_HashMap_get_in_list + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := + hashmap_HashMap_get_in_list_loop T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::get]: forward function *) -Definition hashmap_hash_map_get_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : - result T - := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in +Definition hashmap_HashMap_get + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; - l <- vec_index_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - hashmap_hash_map_get_in_list_fwd T n key l + l <- + alloc_vec_Vec_index (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + hashmap_HashMap_get_in_list T n key l . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_get_mut_in_list_loop_fwd - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) : result T := +Fixpoint hashmap_HashMap_get_mut_in_list_loop + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key then Return cvalue - else hashmap_hash_map_get_mut_in_list_loop_fwd T n0 tl key - | HashmapListNil => Fail_ Failure + else hashmap_HashMap_get_mut_in_list_loop T n0 tl key + | Hashmap_List_Nil => Fail_ Failure end end . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function *) -Definition hashmap_hash_map_get_mut_in_list_fwd - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) : result T := - hashmap_hash_map_get_mut_in_list_loop_fwd T n ls key +Definition hashmap_HashMap_get_mut_in_list + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := + hashmap_HashMap_get_mut_in_list_loop T n ls key . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) -Fixpoint hashmap_hash_map_get_mut_in_list_loop_back - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) (ret : T) : - result (Hashmap_list_t T) +Fixpoint hashmap_HashMap_get_mut_in_list_loop_back + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : + result (hashmap_List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey cvalue tl => + | Hashmap_List_Cons ckey cvalue tl => if ckey s= key - then Return (HashmapListCons ckey ret tl) + then Return (Hashmap_List_Cons ckey ret tl) else ( - tl0 <- hashmap_hash_map_get_mut_in_list_loop_back T n0 tl key ret; - Return (HashmapListCons ckey cvalue tl0)) - | HashmapListNil => Fail_ Failure + tl0 <- hashmap_HashMap_get_mut_in_list_loop_back T n0 tl key ret; + Return (Hashmap_List_Cons ckey cvalue tl0)) + | Hashmap_List_Nil => Fail_ Failure end end . (** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) -Definition hashmap_hash_map_get_mut_in_list_back - (T : Type) (n : nat) (ls : Hashmap_list_t T) (key : usize) (ret : T) : - result (Hashmap_list_t T) +Definition hashmap_HashMap_get_mut_in_list_back + (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : + result (hashmap_List_t T) := - hashmap_hash_map_get_mut_in_list_loop_back T n ls key ret + hashmap_HashMap_get_mut_in_list_loop_back T n ls key ret . (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function *) -Definition hashmap_hash_map_get_mut_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : - result T - := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in +Definition hashmap_HashMap_get_mut + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - hashmap_hash_map_get_mut_in_list_fwd T n l key + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + hashmap_HashMap_get_mut_in_list T n l key . (** [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 *) -Definition hashmap_hash_map_get_mut_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) (ret : T) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_get_mut_back + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (ret : T) : + result (hashmap_HashMap_t T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - l0 <- hashmap_hash_map_get_mut_in_list_back T n l key ret; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + l0 <- hashmap_HashMap_get_mut_in_list_back T n l key ret; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) -Fixpoint hashmap_hash_map_remove_from_list_loop_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : +Fixpoint hashmap_HashMap_remove_from_list_loop + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey t tl => + | Hashmap_List_Cons ckey t tl => if ckey s= key then let mv_ls := - mem_replace_fwd (Hashmap_list_t T) (HashmapListCons ckey t tl) - HashmapListNil in + core_mem_replace (hashmap_List_t T) (Hashmap_List_Cons ckey t tl) + Hashmap_List_Nil in match mv_ls with - | HashmapListCons i cvalue tl0 => Return (Some cvalue) - | HashmapListNil => Fail_ Failure + | Hashmap_List_Cons i cvalue tl0 => Return (Some cvalue) + | Hashmap_List_Nil => Fail_ Failure end - else hashmap_hash_map_remove_from_list_loop_fwd T n0 key tl - | HashmapListNil => Return None + else hashmap_HashMap_remove_from_list_loop T n0 key tl + | Hashmap_List_Nil => Return None end end . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function *) -Definition hashmap_hash_map_remove_from_list_fwd - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : +Definition hashmap_HashMap_remove_from_list + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) := - hashmap_hash_map_remove_from_list_loop_fwd T n key ls + hashmap_HashMap_remove_from_list_loop T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) -Fixpoint hashmap_hash_map_remove_from_list_loop_back - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Fixpoint hashmap_HashMap_remove_from_list_loop_back + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | HashmapListCons ckey t tl => + | Hashmap_List_Cons ckey t tl => if ckey s= key then let mv_ls := - mem_replace_fwd (Hashmap_list_t T) (HashmapListCons ckey t tl) - HashmapListNil in + core_mem_replace (hashmap_List_t T) (Hashmap_List_Cons ckey t tl) + Hashmap_List_Nil in match mv_ls with - | HashmapListCons i cvalue tl0 => Return tl0 - | HashmapListNil => Fail_ Failure + | Hashmap_List_Cons i cvalue tl0 => Return tl0 + | Hashmap_List_Nil => Fail_ Failure end else ( - tl0 <- hashmap_hash_map_remove_from_list_loop_back T n0 key tl; - Return (HashmapListCons ckey t tl0)) - | HashmapListNil => Return HashmapListNil + tl0 <- hashmap_HashMap_remove_from_list_loop_back T n0 key tl; + Return (Hashmap_List_Cons ckey t tl0)) + | Hashmap_List_Nil => Return Hashmap_List_Nil end end . (** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) -Definition hashmap_hash_map_remove_from_list_back - (T : Type) (n : nat) (key : usize) (ls : Hashmap_list_t T) : - result (Hashmap_list_t T) +Definition hashmap_HashMap_remove_from_list_back + (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : + result (hashmap_List_t T) := - hashmap_hash_map_remove_from_list_loop_back T n key ls + hashmap_HashMap_remove_from_list_loop_back T n key ls . (** [hashmap_main::hashmap::HashMap::{0}::remove]: forward function *) -Definition hashmap_hash_map_remove_fwd - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : +Definition hashmap_HashMap_remove + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result (option T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - x <- hashmap_hash_map_remove_from_list_fwd T n key l; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + x <- hashmap_HashMap_remove_from_list T n key l; match x with | None => Return None | Some x0 => - _ <- usize_sub self.(Hashmap_hash_map_num_entries) 1%usize; - Return (Some x0) + _ <- usize_sub self.(hashmap_HashMap_num_entries) 1%usize; Return (Some x0) end . (** [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 *) -Definition hashmap_hash_map_remove_back - (T : Type) (n : nat) (self : Hashmap_hash_map_t T) (key : usize) : - result (Hashmap_hash_map_t T) +Definition hashmap_HashMap_remove_back + (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : + result (hashmap_HashMap_t T) := - hash <- hashmap_hash_key_fwd key; - let i := vec_len (Hashmap_list_t T) self.(Hashmap_hash_map_slots) in + hash <- hashmap_hash_key key; + let i := alloc_vec_Vec_len (hashmap_List_t T) self.(hashmap_HashMap_slots) in hash_mod <- usize_rem hash i; l <- - vec_index_mut_fwd (Hashmap_list_t T) self.(Hashmap_hash_map_slots) hash_mod; - x <- hashmap_hash_map_remove_from_list_fwd T n key l; + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod; + x <- hashmap_HashMap_remove_from_list T n key l; match x with | None => - l0 <- hashmap_hash_map_remove_from_list_back T n key l; + l0 <- hashmap_HashMap_remove_from_list_back T n key l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := self.(Hashmap_hash_map_num_entries); - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} | Some x0 => - i0 <- usize_sub self.(Hashmap_hash_map_num_entries) 1%usize; - l0 <- hashmap_hash_map_remove_from_list_back T n key l; + i0 <- usize_sub self.(hashmap_HashMap_num_entries) 1%usize; + l0 <- hashmap_HashMap_remove_from_list_back T n key l; v <- - vec_index_mut_back (Hashmap_list_t T) self.(Hashmap_hash_map_slots) - hash_mod l0; + alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t + T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| - Hashmap_hash_map_num_entries := i0; - Hashmap_hash_map_max_load_factor := - self.(Hashmap_hash_map_max_load_factor); - Hashmap_hash_map_max_load := self.(Hashmap_hash_map_max_load); - Hashmap_hash_map_slots := v + hashmap_HashMap_num_entries := i0; + hashmap_HashMap_max_load_factor := + self.(hashmap_HashMap_max_load_factor); + hashmap_HashMap_max_load := self.(hashmap_HashMap_max_load); + hashmap_HashMap_slots := v |} end . (** [hashmap_main::hashmap::test1]: forward function *) -Definition hashmap_test1_fwd (n : nat) : result unit := - hm <- hashmap_hash_map_new_fwd u64 n; - hm0 <- hashmap_hash_map_insert_fwd_back u64 n hm 0%usize 42%u64; - hm1 <- hashmap_hash_map_insert_fwd_back u64 n hm0 128%usize 18%u64; - hm2 <- hashmap_hash_map_insert_fwd_back u64 n hm1 1024%usize 138%u64; - hm3 <- hashmap_hash_map_insert_fwd_back u64 n hm2 1056%usize 256%u64; - i <- hashmap_hash_map_get_fwd u64 n hm3 128%usize; +Definition hashmap_test1 (n : nat) : result unit := + hm <- hashmap_HashMap_new u64 n; + hm0 <- hashmap_HashMap_insert u64 n hm 0%usize 42%u64; + hm1 <- hashmap_HashMap_insert u64 n hm0 128%usize 18%u64; + hm2 <- hashmap_HashMap_insert u64 n hm1 1024%usize 138%u64; + hm3 <- hashmap_HashMap_insert u64 n hm2 1056%usize 256%u64; + i <- hashmap_HashMap_get u64 n hm3 128%usize; if negb (i s= 18%u64) then Fail_ Failure else ( - hm4 <- hashmap_hash_map_get_mut_back u64 n hm3 1024%usize 56%u64; - i0 <- hashmap_hash_map_get_fwd u64 n hm4 1024%usize; + hm4 <- hashmap_HashMap_get_mut_back u64 n hm3 1024%usize 56%u64; + i0 <- hashmap_HashMap_get u64 n hm4 1024%usize; if negb (i0 s= 56%u64) then Fail_ Failure else ( - x <- hashmap_hash_map_remove_fwd u64 n hm4 1024%usize; + x <- hashmap_HashMap_remove u64 n hm4 1024%usize; match x with | None => Fail_ Failure | Some x0 => if negb (x0 s= 56%u64) then Fail_ Failure else ( - hm5 <- hashmap_hash_map_remove_back u64 n hm4 1024%usize; - i1 <- hashmap_hash_map_get_fwd u64 n hm5 0%usize; + hm5 <- hashmap_HashMap_remove_back u64 n hm4 1024%usize; + i1 <- hashmap_HashMap_get u64 n hm5 0%usize; if negb (i1 s= 42%u64) then Fail_ Failure else ( - i2 <- hashmap_hash_map_get_fwd u64 n hm5 128%usize; + i2 <- hashmap_HashMap_get u64 n hm5 128%usize; if negb (i2 s= 18%u64) then Fail_ Failure else ( - i3 <- hashmap_hash_map_get_fwd u64 n hm5 1056%usize; + i3 <- hashmap_HashMap_get u64 n hm5 1056%usize; if negb (i3 s= 256%u64) then Fail_ Failure else Return tt))) end)) . (** [hashmap_main::insert_on_disk]: forward function *) -Definition insert_on_disk_fwd +Definition insert_on_disk (n : nat) (key : usize) (value : u64) (st : state) : result (state * unit) := - p <- hashmap_utils_deserialize_fwd st; + p <- hashmap_utils_deserialize st; let (st0, hm) := p in - hm0 <- hashmap_hash_map_insert_fwd_back u64 n hm key value; - p0 <- hashmap_utils_serialize_fwd hm0 st0; + hm0 <- hashmap_HashMap_insert u64 n hm key value; + p0 <- hashmap_utils_serialize hm0 st0; let (st1, _) := p0 in Return (st1, tt) . (** [hashmap_main::main]: forward function *) -Definition main_fwd : result unit := +Definition main : result unit := Return tt. -(** Unit test for [hashmap_main::main] *) -Check (main_fwd )%return. - End HashmapMain_Funs . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v index 2d17cc29..5e376239 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v @@ -11,13 +11,13 @@ Import HashmapMain_Types. Module HashmapMain_Opaque. (** [hashmap_main::hashmap_utils::deserialize]: forward function *) -Axiom hashmap_utils_deserialize_fwd - : state -> result (state * (Hashmap_hash_map_t u64)) +Axiom hashmap_utils_deserialize + : state -> result (state * (hashmap_HashMap_t u64)) . (** [hashmap_main::hashmap_utils::serialize]: forward function *) -Axiom hashmap_utils_serialize_fwd - : Hashmap_hash_map_t u64 -> state -> result (state * unit) +Axiom hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state * unit) . End HashmapMain_Opaque . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Types.v b/tests/coq/hashmap_on_disk/HashmapMain_Types.v index 36aaaf25..466119f8 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Types.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Types.v @@ -9,29 +9,29 @@ Local Open Scope Primitives_scope. Module HashmapMain_Types. (** [hashmap_main::hashmap::List] *) -Inductive Hashmap_list_t (T : Type) := -| HashmapListCons : usize -> T -> Hashmap_list_t T -> Hashmap_list_t T -| HashmapListNil : Hashmap_list_t T +Inductive hashmap_List_t (T : Type) := +| Hashmap_List_Cons : usize -> T -> hashmap_List_t T -> hashmap_List_t T +| Hashmap_List_Nil : hashmap_List_t T . -Arguments HashmapListCons {T} _ _ _. -Arguments HashmapListNil {T}. +Arguments Hashmap_List_Cons {T} _ _ _. +Arguments Hashmap_List_Nil {T}. (** [hashmap_main::hashmap::HashMap] *) -Record Hashmap_hash_map_t (T : Type) := -mkHashmap_hash_map_t { - Hashmap_hash_map_num_entries : usize; - Hashmap_hash_map_max_load_factor : (usize * usize); - Hashmap_hash_map_max_load : usize; - Hashmap_hash_map_slots : vec (Hashmap_list_t T); +Record hashmap_HashMap_t (T : Type) := +mkhashmap_HashMap_t { + hashmap_HashMap_num_entries : usize; + hashmap_HashMap_max_load_factor : (usize * usize); + hashmap_HashMap_max_load : usize; + hashmap_HashMap_slots : alloc_vec_Vec (hashmap_List_t T); } . -Arguments mkHashmap_hash_map_t {T} _ _ _ _. -Arguments Hashmap_hash_map_num_entries {T}. -Arguments Hashmap_hash_map_max_load_factor {T}. -Arguments Hashmap_hash_map_max_load {T}. -Arguments Hashmap_hash_map_slots {T}. +Arguments mkhashmap_HashMap_t {T} _ _ _ _. +Arguments hashmap_HashMap_num_entries {T}. +Arguments hashmap_HashMap_max_load_factor {T}. +Arguments hashmap_HashMap_max_load {T}. +Arguments hashmap_HashMap_slots {T}. (** The state type used in the state-error monad *) Axiom state : Type. diff --git a/tests/coq/hashmap_on_disk/Primitives.v b/tests/coq/hashmap_on_disk/Primitives.v index 8d6c9c8d..85e38f01 100644 --- a/tests/coq/hashmap_on_disk/Primitives.v +++ b/tests/coq/hashmap_on_disk/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -408,12 +410,75 @@ Definition core_i64_max := i64_max %i64. Definition core_i128_max := i64_max %i128. Axiom core_isize_max : isize. (** TODO *) -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -433,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -488,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index 5dd78a09..7cb1a642 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -21,36 +21,35 @@ Definition x2_body : result u32 := Return 3%u32. Definition x2_c : u32 := x2_body%global. (** [constants::incr]: forward function *) -Definition incr_fwd (n : u32) : result u32 := +Definition incr (n : u32) : result u32 := u32_add n 1%u32. (** [constants::X3] *) -Definition x3_body : result u32 := incr_fwd 32%u32. +Definition x3_body : result u32 := incr 32%u32. Definition x3_c : u32 := x3_body%global. (** [constants::mk_pair0]: forward function *) -Definition mk_pair0_fwd (x : u32) (y : u32) : result (u32 * u32) := - Return (x, y) -. +Definition mk_pair0 (x : u32) (y : u32) : result (u32 * u32) := + Return (x, y). (** [constants::Pair] *) -Record Pair_t (T1 T2 : Type) := mkPair_t { Pair_x : T1; Pair_y : T2; }. +Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. Arguments mkPair_t {T1} {T2} _ _. -Arguments Pair_x {T1} {T2}. -Arguments Pair_y {T1} {T2}. +Arguments pair_x {T1} {T2}. +Arguments pair_y {T1} {T2}. (** [constants::mk_pair1]: forward function *) -Definition mk_pair1_fwd (x : u32) (y : u32) : result (Pair_t u32 u32) := - Return {| Pair_x := x; Pair_y := y |} +Definition mk_pair1 (x : u32) (y : u32) : result (Pair_t u32 u32) := + Return {| pair_x := x; pair_y := y |} . (** [constants::P0] *) -Definition p0_body : result (u32 * u32) := mk_pair0_fwd 0%u32 1%u32. +Definition p0_body : result (u32 * u32) := mk_pair0 0%u32 1%u32. Definition p0_c : (u32 * u32) := p0_body%global. (** [constants::P1] *) -Definition p1_body : result (Pair_t u32 u32) := mk_pair1_fwd 0%u32 1%u32. +Definition p1_body : result (Pair_t u32 u32) := mk_pair1 0%u32 1%u32. Definition p1_c : Pair_t u32 u32 := p1_body%global. (** [constants::P2] *) @@ -59,31 +58,31 @@ Definition p2_c : (u32 * u32) := p2_body%global. (** [constants::P3] *) Definition p3_body : result (Pair_t u32 u32) := - Return {| Pair_x := 0%u32; Pair_y := 1%u32 |} + Return {| pair_x := 0%u32; pair_y := 1%u32 |} . Definition p3_c : Pair_t u32 u32 := p3_body%global. (** [constants::Wrap] *) -Record Wrap_t (T : Type) := mkWrap_t { Wrap_val : T; }. +Record Wrap_t (T : Type) := mkWrap_t { wrap_value : T; }. Arguments mkWrap_t {T} _. -Arguments Wrap_val {T}. +Arguments wrap_value {T}. (** [constants::Wrap::{0}::new]: forward function *) -Definition wrap_new_fwd (T : Type) (val : T) : result (Wrap_t T) := - Return {| Wrap_val := val |} +Definition wrap_new (T : Type) (value : T) : result (Wrap_t T) := + Return {| wrap_value := value |} . (** [constants::Y] *) -Definition y_body : result (Wrap_t i32) := wrap_new_fwd i32 2%i32. +Definition y_body : result (Wrap_t i32) := wrap_new i32 2%i32. Definition y_c : Wrap_t i32 := y_body%global. (** [constants::unwrap_y]: forward function *) -Definition unwrap_y_fwd : result i32 := - Return y_c.(Wrap_val). +Definition unwrap_y : result i32 := + Return y_c.(wrap_value). (** [constants::YVAL] *) -Definition yval_body : result i32 := unwrap_y_fwd. +Definition yval_body : result i32 := unwrap_y. Definition yval_c : i32 := yval_body%global. (** [constants::get_z1::Z1] *) @@ -91,11 +90,11 @@ Definition get_z1_z1_body : result i32 := Return 3%i32. Definition get_z1_z1_c : i32 := get_z1_z1_body%global. (** [constants::get_z1]: forward function *) -Definition get_z1_fwd : result i32 := +Definition get_z1 : result i32 := Return get_z1_z1_c. (** [constants::add]: forward function *) -Definition add_fwd (a : i32) (b : i32) : result i32 := +Definition add (a : i32) (b : i32) : result i32 := i32_add a b. (** [constants::Q1] *) @@ -107,20 +106,19 @@ Definition q2_body : result i32 := Return q1_c. Definition q2_c : i32 := q2_body%global. (** [constants::Q3] *) -Definition q3_body : result i32 := add_fwd q2_c 3%i32. +Definition q3_body : result i32 := add q2_c 3%i32. Definition q3_c : i32 := q3_body%global. (** [constants::get_z2]: forward function *) -Definition get_z2_fwd : result i32 := - i <- get_z1_fwd; i0 <- add_fwd i q3_c; add_fwd q1_c i0 -. +Definition get_z2 : result i32 := + i <- get_z1; i0 <- add i q3_c; add q1_c i0. (** [constants::S1] *) Definition s1_body : result u32 := Return 6%u32. Definition s1_c : u32 := s1_body%global. (** [constants::S2] *) -Definition s2_body : result u32 := incr_fwd s1_c. +Definition s2_body : result u32 := incr s1_c. Definition s2_c : u32 := s2_body%global. (** [constants::S3] *) @@ -128,7 +126,7 @@ Definition s3_body : result (Pair_t u32 u32) := Return p3_c. Definition s3_c : Pair_t u32 u32 := s3_body%global. (** [constants::S4] *) -Definition s4_body : result (Pair_t u32 u32) := mk_pair1_fwd 7%u32 8%u32. +Definition s4_body : result (Pair_t u32 u32) := mk_pair1 7%u32 8%u32. Definition s4_c : Pair_t u32 u32 := s4_body%global. End Constants . diff --git a/tests/coq/misc/External_Funs.v b/tests/coq/misc/External_Funs.v index 28370b2b..018ce13c 100644 --- a/tests/coq/misc/External_Funs.v +++ b/tests/coq/misc/External_Funs.v @@ -13,9 +13,9 @@ Import External_Opaque. Module External_Funs. (** [external::swap]: forward function *) -Definition swap_fwd +Definition swap (T : Type) (x : T) (y : T) (st : state) : result (state * unit) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st0, _) := p in p0 <- core_mem_swap_back0 T x y st st0; let (st1, _) := p0 in @@ -29,7 +29,7 @@ Definition swap_back (T : Type) (x : T) (y : T) (st : state) (st0 : state) : result (state * (T * T)) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st1, _) := p in p0 <- core_mem_swap_back0 T x y st st1; let (st2, x0) := p0 in @@ -39,25 +39,27 @@ Definition swap_back . (** [external::test_new_non_zero_u32]: forward function *) -Definition test_new_non_zero_u32_fwd - (x : u32) (st : state) : result (state * Core_num_nonzero_non_zero_u32_t) := - p <- core_num_nonzero_non_zero_u32_new_fwd x st; - let (st0, opt) := p in - core_option_option_unwrap_fwd Core_num_nonzero_non_zero_u32_t opt st0 +Definition test_new_non_zero_u32 + (x : u32) (st : state) : result (state * core_num_nonzero_NonZeroU32_t) := + p <- core_num_nonzero_NonZeroU32_new x st; + let (st0, o) := p in + core_option_Option_unwrap core_num_nonzero_NonZeroU32_t o st0 . (** [external::test_vec]: forward function *) -Definition test_vec_fwd : result unit := - let v := vec_new u32 in _ <- vec_push_back u32 v 0%u32; Return tt +Definition test_vec : result unit := + let v := alloc_vec_Vec_new u32 in + _ <- alloc_vec_Vec_push u32 v 0%u32; + Return tt . (** Unit test for [external::test_vec] *) -Check (test_vec_fwd )%return. +Check (test_vec )%return. (** [external::custom_swap]: forward function *) -Definition custom_swap_fwd +Definition custom_swap (T : Type) (x : T) (y : T) (st : state) : result (state * T) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st0, _) := p in p0 <- core_mem_swap_back0 T x y st st0; let (st1, x0) := p0 in @@ -71,7 +73,7 @@ Definition custom_swap_back (T : Type) (x : T) (y : T) (st : state) (ret : T) (st0 : state) : result (state * (T * T)) := - p <- core_mem_swap_fwd T x y st; + p <- core_mem_swap T x y st; let (st1, _) := p in p0 <- core_mem_swap_back0 T x y st st1; let (st2, _) := p0 in @@ -81,9 +83,9 @@ Definition custom_swap_back . (** [external::test_custom_swap]: forward function *) -Definition test_custom_swap_fwd +Definition test_custom_swap (x : u32) (y : u32) (st : state) : result (state * unit) := - p <- custom_swap_fwd u32 x y st; let (st0, _) := p in Return (st0, tt) + p <- custom_swap u32 x y st; let (st0, _) := p in Return (st0, tt) . (** [external::test_custom_swap]: backward function 0 *) @@ -95,9 +97,8 @@ Definition test_custom_swap_back . (** [external::test_swap_non_zero]: forward function *) -Definition test_swap_non_zero_fwd - (x : u32) (st : state) : result (state * u32) := - p <- swap_fwd u32 x 0%u32 st; +Definition test_swap_non_zero (x : u32) (st : state) : result (state * u32) := + p <- swap u32 x 0%u32 st; let (st0, _) := p in p0 <- swap_back u32 x 0%u32 st st0; let (st1, p1) := p0 in diff --git a/tests/coq/misc/External_Opaque.v b/tests/coq/misc/External_Opaque.v index d2ee42d4..80be37e7 100644 --- a/tests/coq/misc/External_Opaque.v +++ b/tests/coq/misc/External_Opaque.v @@ -11,7 +11,7 @@ Import External_Types. Module External_Opaque. (** [core::mem::swap]: forward function *) -Axiom core_mem_swap_fwd : +Axiom core_mem_swap : forall(T : Type), T -> T -> state -> result (state * unit) . @@ -26,12 +26,12 @@ Axiom core_mem_swap_back1 : . (** [core::num::nonzero::NonZeroU32::{14}::new]: forward function *) -Axiom core_num_nonzero_non_zero_u32_new_fwd - : u32 -> state -> result (state * (option Core_num_nonzero_non_zero_u32_t)) +Axiom core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) . (** [core::option::Option::{0}::unwrap]: forward function *) -Axiom core_option_option_unwrap_fwd : +Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/misc/External_Types.v b/tests/coq/misc/External_Types.v index 1883fa6c..9e49ca41 100644 --- a/tests/coq/misc/External_Types.v +++ b/tests/coq/misc/External_Types.v @@ -9,7 +9,7 @@ Local Open Scope Primitives_scope. Module External_Types. (** [core::num::nonzero::NonZeroU32] *) -Axiom Core_num_nonzero_non_zero_u32_t : Type. +Axiom core_num_nonzero_NonZeroU32_t : Type. (** The state type used in the state-error monad *) Axiom state : Type. diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index 82e57576..180a1d68 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -9,23 +9,23 @@ Local Open Scope Primitives_scope. Module Loops. (** [loops::sum]: loop 0: forward function *) -Fixpoint sum_loop_fwd (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := +Fixpoint sum_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := match n with | O => Fail_ OutOfFuel | S n0 => if i s< max - then (s0 <- u32_add s i; i0 <- u32_add i 1%u32; sum_loop_fwd n0 max i0 s0) + then (s0 <- u32_add s i; i0 <- u32_add i 1%u32; sum_loop n0 max i0 s0) else u32_mul s 2%u32 end . (** [loops::sum]: forward function *) -Definition sum_fwd (n : nat) (max : u32) : result u32 := - sum_loop_fwd n max 0%u32 0%u32 +Definition sum (n : nat) (max : u32) : result u32 := + sum_loop n max 0%u32 0%u32 . (** [loops::sum_with_mut_borrows]: loop 0: forward function *) -Fixpoint sum_with_mut_borrows_loop_fwd +Fixpoint sum_with_mut_borrows_loop (n : nat) (max : u32) (mi : u32) (ms : u32) : result u32 := match n with | O => Fail_ OutOfFuel @@ -34,18 +34,18 @@ Fixpoint sum_with_mut_borrows_loop_fwd then ( ms0 <- u32_add ms mi; mi0 <- u32_add mi 1%u32; - sum_with_mut_borrows_loop_fwd n0 max mi0 ms0) + sum_with_mut_borrows_loop n0 max mi0 ms0) else u32_mul ms 2%u32 end . (** [loops::sum_with_mut_borrows]: forward function *) -Definition sum_with_mut_borrows_fwd (n : nat) (max : u32) : result u32 := - sum_with_mut_borrows_loop_fwd n max 0%u32 0%u32 +Definition sum_with_mut_borrows (n : nat) (max : u32) : result u32 := + sum_with_mut_borrows_loop n max 0%u32 0%u32 . (** [loops::sum_with_shared_borrows]: loop 0: forward function *) -Fixpoint sum_with_shared_borrows_loop_fwd +Fixpoint sum_with_shared_borrows_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := match n with | O => Fail_ OutOfFuel @@ -54,87 +54,88 @@ Fixpoint sum_with_shared_borrows_loop_fwd then ( i0 <- u32_add i 1%u32; s0 <- u32_add s i0; - sum_with_shared_borrows_loop_fwd n0 max i0 s0) + sum_with_shared_borrows_loop n0 max i0 s0) else u32_mul s 2%u32 end . (** [loops::sum_with_shared_borrows]: forward function *) -Definition sum_with_shared_borrows_fwd (n : nat) (max : u32) : result u32 := - sum_with_shared_borrows_loop_fwd n max 0%u32 0%u32 +Definition sum_with_shared_borrows (n : nat) (max : u32) : result u32 := + sum_with_shared_borrows_loop n max 0%u32 0%u32 . (** [loops::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Fixpoint clear_loop_fwd_back - (n : nat) (v : vec u32) (i : usize) : result (vec u32) := +Fixpoint clear_loop + (n : nat) (v : alloc_vec_Vec u32) (i : usize) : result (alloc_vec_Vec u32) := match n with | O => Fail_ OutOfFuel | S n0 => - let i0 := vec_len u32 v in + let i0 := alloc_vec_Vec_len u32 v in if i s< i0 then ( i1 <- usize_add i 1%usize; - v0 <- vec_index_mut_back u32 v i 0%u32; - clear_loop_fwd_back n0 v0 i1) + v0 <- + alloc_vec_Vec_index_mut_back u32 usize + (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0%u32; + clear_loop n0 v0 i1) else Return v end . (** [loops::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition clear_fwd_back (n : nat) (v : vec u32) : result (vec u32) := - clear_loop_fwd_back n v 0%usize +Definition clear + (n : nat) (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) := + clear_loop n v 0%usize . (** [loops::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons {T} _ _. +Arguments List_Nil {T}. (** [loops::list_mem]: loop 0: forward function *) -Fixpoint list_mem_loop_fwd - (n : nat) (x : u32) (ls : List_t u32) : result bool := +Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => - if y s= x then Return true else list_mem_loop_fwd n0 x tl - | ListNil => Return false + | List_Cons y tl => if y s= x then Return true else list_mem_loop n0 x tl + | List_Nil => Return false end end . (** [loops::list_mem]: forward function *) -Definition list_mem_fwd (n : nat) (x : u32) (ls : List_t u32) : result bool := - list_mem_loop_fwd n x ls +Definition list_mem (n : nat) (x : u32) (ls : List_t u32) : result bool := + list_mem_loop n x ls . (** [loops::list_nth_mut_loop]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_loop_fwd +Fixpoint list_nth_mut_loop_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_mut_loop_loop_fwd T n0 tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut_loop_loop T n0 tl i0) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop]: forward function *) -Definition list_nth_mut_loop_fwd +Definition list_nth_mut_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - list_nth_mut_loop_loop_fwd T n ls i + list_nth_mut_loop_loop T n ls i . (** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) @@ -146,14 +147,14 @@ Fixpoint list_nth_mut_loop_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_loop_loop_back T n0 tl i0 ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end end . @@ -167,46 +168,50 @@ Definition list_nth_mut_loop_back . (** [loops::list_nth_shared_loop]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_loop_fwd +Fixpoint list_nth_shared_loop_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_shared_loop_loop_fwd T n0 tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_shared_loop_loop T n0 tl i0) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop]: forward function *) -Definition list_nth_shared_loop_fwd +Definition list_nth_shared_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - list_nth_shared_loop_loop_fwd T n ls i + list_nth_shared_loop_loop T n ls i . (** [loops::get_elem_mut]: loop 0: forward function *) -Fixpoint get_elem_mut_loop_fwd +Fixpoint get_elem_mut_loop (n : nat) (x : usize) (ls : List_t usize) : result usize := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => - if y s= x then Return y else get_elem_mut_loop_fwd n0 x tl - | ListNil => Fail_ Failure + | List_Cons y tl => if y s= x then Return y else get_elem_mut_loop n0 x tl + | List_Nil => Fail_ Failure end end . (** [loops::get_elem_mut]: forward function *) -Definition get_elem_mut_fwd - (n : nat) (slots : vec (List_t usize)) (x : usize) : result usize := - l <- vec_index_mut_fwd (List_t usize) slots 0%usize; - get_elem_mut_loop_fwd n x l +Definition get_elem_mut + (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : + result usize + := + l <- + alloc_vec_Vec_index_mut (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) + slots 0%usize; + get_elem_mut_loop n x l . (** [loops::get_elem_mut]: loop 0: backward function 0 *) @@ -218,50 +223,60 @@ Fixpoint get_elem_mut_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => + | List_Cons y tl => if y s= x - then Return (ListCons ret tl) - else (tl0 <- get_elem_mut_loop_back n0 x tl ret; Return (ListCons y tl0)) - | ListNil => Fail_ Failure + then Return (List_Cons ret tl) + else ( + tl0 <- get_elem_mut_loop_back n0 x tl ret; Return (List_Cons y tl0)) + | List_Nil => Fail_ Failure end end . (** [loops::get_elem_mut]: backward function 0 *) Definition get_elem_mut_back - (n : nat) (slots : vec (List_t usize)) (x : usize) (ret : usize) : - result (vec (List_t usize)) + (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) (ret : usize) : + result (alloc_vec_Vec (List_t usize)) := - l <- vec_index_mut_fwd (List_t usize) slots 0%usize; + l <- + alloc_vec_Vec_index_mut (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) + slots 0%usize; l0 <- get_elem_mut_loop_back n x l ret; - vec_index_mut_back (List_t usize) slots 0%usize l0 + alloc_vec_Vec_index_mut_back (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) slots + 0%usize l0 . (** [loops::get_elem_shared]: loop 0: forward function *) -Fixpoint get_elem_shared_loop_fwd +Fixpoint get_elem_shared_loop (n : nat) (x : usize) (ls : List_t usize) : result usize := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons y tl => - if y s= x then Return y else get_elem_shared_loop_fwd n0 x tl - | ListNil => Fail_ Failure + | List_Cons y tl => + if y s= x then Return y else get_elem_shared_loop n0 x tl + | List_Nil => Fail_ Failure end end . (** [loops::get_elem_shared]: forward function *) -Definition get_elem_shared_fwd - (n : nat) (slots : vec (List_t usize)) (x : usize) : result usize := - l <- vec_index_fwd (List_t usize) slots 0%usize; - get_elem_shared_loop_fwd n x l +Definition get_elem_shared + (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : + result usize + := + l <- + alloc_vec_Vec_index (List_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) + slots 0%usize; + get_elem_shared_loop n x l . (** [loops::id_mut]: forward function *) -Definition id_mut_fwd (T : Type) (ls : List_t T) : result (List_t T) := - Return ls -. +Definition id_mut (T : Type) (ls : List_t T) : result (List_t T) := + Return ls. (** [loops::id_mut]: backward function 0 *) Definition id_mut_back @@ -270,31 +285,30 @@ Definition id_mut_back . (** [loops::id_shared]: forward function *) -Definition id_shared_fwd (T : Type) (ls : List_t T) : result (List_t T) := +Definition id_shared (T : Type) (ls : List_t T) : result (List_t T) := Return ls . (** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_with_id_loop_fwd +Fixpoint list_nth_mut_loop_with_id_loop (T : Type) (n : nat) (i : u32) (ls : List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else ( - i0 <- u32_sub i 1%u32; list_nth_mut_loop_with_id_loop_fwd T n0 i0 tl) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut_loop_with_id_loop T n0 i0 tl) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop_with_id]: forward function *) -Definition list_nth_mut_loop_with_id_fwd +Definition list_nth_mut_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - ls0 <- id_mut_fwd T ls; list_nth_mut_loop_with_id_loop_fwd T n i ls0 + ls0 <- id_mut T ls; list_nth_mut_loop_with_id_loop T n i ls0 . (** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) @@ -306,14 +320,14 @@ Fixpoint list_nth_mut_loop_with_id_loop_back | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_loop_with_id_loop_back T n0 i0 tl ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end end . @@ -323,36 +337,36 @@ Definition list_nth_mut_loop_with_id_back (T : Type) (n : nat) (ls : List_t T) (i : u32) (ret : T) : result (List_t T) := - ls0 <- id_mut_fwd T ls; + ls0 <- id_mut T ls; l <- list_nth_mut_loop_with_id_loop_back T n i ls0 ret; id_mut_back T ls l . (** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_with_id_loop_fwd +Fixpoint list_nth_shared_loop_with_id_loop (T : Type) (n : nat) (i : u32) (ls : List_t T) : result T := match n with | O => Fail_ OutOfFuel | S n0 => match ls with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x else ( - i0 <- u32_sub i 1%u32; list_nth_shared_loop_with_id_loop_fwd T n0 i0 tl) - | ListNil => Fail_ Failure + i0 <- u32_sub i 1%u32; list_nth_shared_loop_with_id_loop T n0 i0 tl) + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop_with_id]: forward function *) -Definition list_nth_shared_loop_with_id_fwd +Definition list_nth_shared_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - ls0 <- id_shared_fwd T ls; list_nth_shared_loop_with_id_loop_fwd T n i ls0 + ls0 <- id_shared T ls; list_nth_shared_loop_with_id_loop T n i ls0 . (** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_pair_loop_fwd +Fixpoint list_nth_mut_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -360,27 +374,26 @@ Fixpoint list_nth_mut_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( - i0 <- u32_sub i 1%u32; - list_nth_mut_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + i0 <- u32_sub i 1%u32; list_nth_mut_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop_pair]: forward function *) -Definition list_nth_mut_loop_pair_fwd +Definition list_nth_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_mut_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) @@ -392,18 +405,18 @@ Fixpoint list_nth_mut_loop_pair_loop_back'a | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else ( i0 <- u32_sub i 1%u32; tl00 <- list_nth_mut_loop_pair_loop_back'a T n0 tl0 tl1 i0 ret; - Return (ListCons x0 tl00)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -425,18 +438,18 @@ Fixpoint list_nth_mut_loop_pair_loop_back'b | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else ( i0 <- u32_sub i 1%u32; tl10 <- list_nth_mut_loop_pair_loop_back'b T n0 tl0 tl1 i0 ret; - Return (ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -450,7 +463,7 @@ Definition list_nth_mut_loop_pair_back'b . (** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_pair_loop_fwd +Fixpoint list_nth_shared_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -458,31 +471,30 @@ Fixpoint list_nth_shared_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( - i0 <- u32_sub i 1%u32; - list_nth_shared_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + i0 <- u32_sub i 1%u32; list_nth_shared_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop_pair]: forward function *) -Definition list_nth_shared_loop_pair_fwd +Definition list_nth_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_shared_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_mut_loop_pair_merge_loop_fwd +Fixpoint list_nth_mut_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -490,27 +502,27 @@ Fixpoint list_nth_mut_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_mut_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_mut_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_loop_pair_merge]: forward function *) -Definition list_nth_mut_loop_pair_merge_fwd +Definition list_nth_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_mut_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) @@ -523,19 +535,19 @@ Fixpoint list_nth_mut_loop_pair_merge_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then let (t, t0) := ret in Return (ListCons t tl0, ListCons t0 tl1) + then let (t, t0) := ret in Return (List_Cons t tl0, List_Cons t0 tl1) else ( i0 <- u32_sub i 1%u32; p <- list_nth_mut_loop_pair_merge_loop_back T n0 tl0 tl1 i0 ret; let (tl00, tl10) := p in - Return (ListCons x0 tl00, ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00, List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -550,7 +562,7 @@ Definition list_nth_mut_loop_pair_merge_back . (** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_shared_loop_pair_merge_loop_fwd +Fixpoint list_nth_shared_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -558,31 +570,31 @@ Fixpoint list_nth_shared_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_shared_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_shared_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_loop_pair_merge]: forward function *) -Definition list_nth_shared_loop_pair_merge_fwd +Definition list_nth_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_shared_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_mut_shared_loop_pair_loop_fwd +Fixpoint list_nth_mut_shared_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -590,27 +602,27 @@ Fixpoint list_nth_mut_shared_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_mut_shared_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_mut_shared_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_shared_loop_pair]: forward function *) -Definition list_nth_mut_shared_loop_pair_fwd +Definition list_nth_mut_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_shared_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_mut_shared_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) @@ -622,18 +634,18 @@ Fixpoint list_nth_mut_shared_loop_pair_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else ( i0 <- u32_sub i 1%u32; tl00 <- list_nth_mut_shared_loop_pair_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x0 tl00)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -647,7 +659,7 @@ Definition list_nth_mut_shared_loop_pair_back . (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_mut_shared_loop_pair_merge_loop_fwd +Fixpoint list_nth_mut_shared_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -655,27 +667,27 @@ Fixpoint list_nth_mut_shared_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_mut_shared_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_mut_shared_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) -Definition list_nth_mut_shared_loop_pair_merge_fwd +Definition list_nth_mut_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_mut_shared_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_mut_shared_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) @@ -687,19 +699,19 @@ Fixpoint list_nth_mut_shared_loop_pair_merge_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl0) + then Return (List_Cons ret tl0) else ( i0 <- u32_sub i 1%u32; tl00 <- list_nth_mut_shared_loop_pair_merge_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x0 tl00)) - | ListNil => Fail_ Failure + Return (List_Cons x0 tl00)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -713,7 +725,7 @@ Definition list_nth_mut_shared_loop_pair_merge_back . (** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) -Fixpoint list_nth_shared_mut_loop_pair_loop_fwd +Fixpoint list_nth_shared_mut_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -721,27 +733,27 @@ Fixpoint list_nth_shared_mut_loop_pair_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_shared_mut_loop_pair_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_shared_mut_loop_pair_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_mut_loop_pair]: forward function *) -Definition list_nth_shared_mut_loop_pair_fwd +Definition list_nth_shared_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_mut_loop_pair_loop_fwd T n ls0 ls1 i + list_nth_shared_mut_loop_pair_loop T n ls0 ls1 i . (** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) @@ -753,18 +765,18 @@ Fixpoint list_nth_shared_mut_loop_pair_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else ( i0 <- u32_sub i 1%u32; tl10 <- list_nth_shared_mut_loop_pair_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . @@ -778,7 +790,7 @@ Definition list_nth_shared_mut_loop_pair_back . (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) -Fixpoint list_nth_shared_mut_loop_pair_merge_loop_fwd +Fixpoint list_nth_shared_mut_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := @@ -786,27 +798,27 @@ Fixpoint list_nth_shared_mut_loop_pair_merge_loop_fwd | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 then Return (x0, x1) else ( i0 <- u32_sub i 1%u32; - list_nth_shared_mut_loop_pair_merge_loop_fwd T n0 tl0 tl1 i0) - | ListNil => Fail_ Failure + list_nth_shared_mut_loop_pair_merge_loop T n0 tl0 tl1 i0) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . (** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) -Definition list_nth_shared_mut_loop_pair_merge_fwd +Definition list_nth_shared_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - list_nth_shared_mut_loop_pair_merge_loop_fwd T n ls0 ls1 i + list_nth_shared_mut_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) @@ -818,19 +830,19 @@ Fixpoint list_nth_shared_mut_loop_pair_merge_loop_back | O => Fail_ OutOfFuel | S n0 => match ls0 with - | ListCons x0 tl0 => + | List_Cons x0 tl0 => match ls1 with - | ListCons x1 tl1 => + | List_Cons x1 tl1 => if i s= 0%u32 - then Return (ListCons ret tl1) + then Return (List_Cons ret tl1) else ( i0 <- u32_sub i 1%u32; tl10 <- list_nth_shared_mut_loop_pair_merge_loop_back T n0 tl0 tl1 i0 ret; - Return (ListCons x1 tl10)) - | ListNil => Fail_ Failure + Return (List_Cons x1 tl10)) + | List_Nil => Fail_ Failure end - | ListNil => Fail_ Failure + | List_Nil => Fail_ Failure end end . diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index c1c24e00..47cdc3af 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -9,113 +9,113 @@ Local Open Scope Primitives_scope. Module NoNestedBorrows. (** [no_nested_borrows::Pair] *) -Record Pair_t (T1 T2 : Type) := mkPair_t { Pair_x : T1; Pair_y : T2; }. +Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. Arguments mkPair_t {T1} {T2} _ _. -Arguments Pair_x {T1} {T2}. -Arguments Pair_y {T1} {T2}. +Arguments pair_x {T1} {T2}. +Arguments pair_y {T1} {T2}. (** [no_nested_borrows::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons {T} _ _. +Arguments List_Nil {T}. (** [no_nested_borrows::One] *) -Inductive One_t (T1 : Type) := | OneOne : T1 -> One_t T1. +Inductive One_t (T1 : Type) := | One_One : T1 -> One_t T1. -Arguments OneOne {T1} _. +Arguments One_One {T1} _. (** [no_nested_borrows::EmptyEnum] *) -Inductive Empty_enum_t := | EmptyEnumEmpty : Empty_enum_t. +Inductive EmptyEnum_t := | EmptyEnum_Empty : EmptyEnum_t. (** [no_nested_borrows::Enum] *) -Inductive Enum_t := | EnumVariant1 : Enum_t | EnumVariant2 : Enum_t. +Inductive Enum_t := | Enum_Variant1 : Enum_t | Enum_Variant2 : Enum_t. (** [no_nested_borrows::EmptyStruct] *) -Record Empty_struct_t := mkEmpty_struct_t { }. +Record EmptyStruct_t := mkEmptyStruct_t { }. (** [no_nested_borrows::Sum] *) Inductive Sum_t (T1 T2 : Type) := -| SumLeft : T1 -> Sum_t T1 T2 -| SumRight : T2 -> Sum_t T1 T2 +| Sum_Left : T1 -> Sum_t T1 T2 +| Sum_Right : T2 -> Sum_t T1 T2 . -Arguments SumLeft {T1} {T2} _. -Arguments SumRight {T1} {T2} _. +Arguments Sum_Left {T1} {T2} _. +Arguments Sum_Right {T1} {T2} _. (** [no_nested_borrows::neg_test]: forward function *) -Definition neg_test_fwd (x : i32) : result i32 := +Definition neg_test (x : i32) : result i32 := i32_neg x. (** [no_nested_borrows::add_test]: forward function *) -Definition add_test_fwd (x : u32) (y : u32) : result u32 := +Definition add_test (x : u32) (y : u32) : result u32 := u32_add x y. (** [no_nested_borrows::subs_test]: forward function *) -Definition subs_test_fwd (x : u32) (y : u32) : result u32 := +Definition subs_test (x : u32) (y : u32) : result u32 := u32_sub x y. (** [no_nested_borrows::div_test]: forward function *) -Definition div_test_fwd (x : u32) (y : u32) : result u32 := +Definition div_test (x : u32) (y : u32) : result u32 := u32_div x y. (** [no_nested_borrows::div_test1]: forward function *) -Definition div_test1_fwd (x : u32) : result u32 := +Definition div_test1 (x : u32) : result u32 := u32_div x 2%u32. (** [no_nested_borrows::rem_test]: forward function *) -Definition rem_test_fwd (x : u32) (y : u32) : result u32 := +Definition rem_test (x : u32) (y : u32) : result u32 := u32_rem x y. (** [no_nested_borrows::cast_test]: forward function *) -Definition cast_test_fwd (x : u32) : result i32 := +Definition cast_test (x : u32) : result i32 := scalar_cast U32 I32 x. (** [no_nested_borrows::test2]: forward function *) -Definition test2_fwd : result unit := +Definition test2 : result unit := _ <- u32_add 23%u32 44%u32; Return tt. (** Unit test for [no_nested_borrows::test2] *) -Check (test2_fwd )%return. +Check (test2 )%return. (** [no_nested_borrows::get_max]: forward function *) -Definition get_max_fwd (x : u32) (y : u32) : result u32 := +Definition get_max (x : u32) (y : u32) : result u32 := if x s>= y then Return x else Return y . (** [no_nested_borrows::test3]: forward function *) -Definition test3_fwd : result unit := - x <- get_max_fwd 4%u32 3%u32; - y <- get_max_fwd 10%u32 11%u32; +Definition test3 : result unit := + x <- get_max 4%u32 3%u32; + y <- get_max 10%u32 11%u32; z <- u32_add x y; if negb (z s= 15%u32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test3] *) -Check (test3_fwd )%return. +Check (test3 )%return. (** [no_nested_borrows::test_neg1]: forward function *) -Definition test_neg1_fwd : result unit := +Definition test_neg1 : result unit := y <- i32_neg 3%i32; if negb (y s= (-3)%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_neg1] *) -Check (test_neg1_fwd )%return. +Check (test_neg1 )%return. (** [no_nested_borrows::refs_test1]: forward function *) -Definition refs_test1_fwd : result unit := +Definition refs_test1 : result unit := if negb (1%i32 s= 1%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::refs_test1] *) -Check (refs_test1_fwd )%return. +Check (refs_test1 )%return. (** [no_nested_borrows::refs_test2]: forward function *) -Definition refs_test2_fwd : result unit := +Definition refs_test2 : result unit := if negb (2%i32 s= 2%i32) then Fail_ Failure else @@ -128,85 +128,83 @@ Definition refs_test2_fwd : result unit := . (** Unit test for [no_nested_borrows::refs_test2] *) -Check (refs_test2_fwd )%return. +Check (refs_test2 )%return. (** [no_nested_borrows::test_list1]: forward function *) -Definition test_list1_fwd : result unit := +Definition test_list1 : result unit := Return tt. (** Unit test for [no_nested_borrows::test_list1] *) -Check (test_list1_fwd )%return. +Check (test_list1 )%return. (** [no_nested_borrows::test_box1]: forward function *) -Definition test_box1_fwd : result unit := +Definition test_box1 : result unit := let b := 1%i32 in let x := b in if negb (x s= 1%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_box1] *) -Check (test_box1_fwd )%return. +Check (test_box1 )%return. (** [no_nested_borrows::copy_int]: forward function *) -Definition copy_int_fwd (x : i32) : result i32 := +Definition copy_int (x : i32) : result i32 := Return x. (** [no_nested_borrows::test_unreachable]: forward function *) -Definition test_unreachable_fwd (b : bool) : result unit := +Definition test_unreachable (b : bool) : result unit := if b then Fail_ Failure else Return tt . (** [no_nested_borrows::test_panic]: forward function *) -Definition test_panic_fwd (b : bool) : result unit := +Definition test_panic (b : bool) : result unit := if b then Fail_ Failure else Return tt . (** [no_nested_borrows::test_copy_int]: forward function *) -Definition test_copy_int_fwd : result unit := - y <- copy_int_fwd 0%i32; - if negb (0%i32 s= y) then Fail_ Failure else Return tt +Definition test_copy_int : result unit := + y <- copy_int 0%i32; if negb (0%i32 s= y) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_copy_int] *) -Check (test_copy_int_fwd )%return. +Check (test_copy_int )%return. (** [no_nested_borrows::is_cons]: forward function *) -Definition is_cons_fwd (T : Type) (l : List_t T) : result bool := - match l with | ListCons t l0 => Return true | ListNil => Return false end +Definition is_cons (T : Type) (l : List_t T) : result bool := + match l with | List_Cons t l0 => Return true | List_Nil => Return false end . (** [no_nested_borrows::test_is_cons]: forward function *) -Definition test_is_cons_fwd : result unit := - let l := ListNil in - b <- is_cons_fwd i32 (ListCons 0%i32 l); +Definition test_is_cons : result unit := + let l := List_Nil in + b <- is_cons i32 (List_Cons 0%i32 l); if negb b then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_is_cons] *) -Check (test_is_cons_fwd )%return. +Check (test_is_cons )%return. (** [no_nested_borrows::split_list]: forward function *) -Definition split_list_fwd - (T : Type) (l : List_t T) : result (T * (List_t T)) := +Definition split_list (T : Type) (l : List_t T) : result (T * (List_t T)) := match l with - | ListCons hd tl => Return (hd, tl) - | ListNil => Fail_ Failure + | List_Cons hd tl => Return (hd, tl) + | List_Nil => Fail_ Failure end . (** [no_nested_borrows::test_split_list]: forward function *) -Definition test_split_list_fwd : result unit := - let l := ListNil in - p <- split_list_fwd i32 (ListCons 0%i32 l); +Definition test_split_list : result unit := + let l := List_Nil in + p <- split_list i32 (List_Cons 0%i32 l); let (hd, _) := p in if negb (hd s= 0%i32) then Fail_ Failure else Return tt . (** Unit test for [no_nested_borrows::test_split_list] *) -Check (test_split_list_fwd )%return. +Check (test_split_list )%return. (** [no_nested_borrows::choose]: forward function *) -Definition choose_fwd (T : Type) (b : bool) (x : T) (y : T) : result T := +Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . @@ -217,8 +215,8 @@ Definition choose_back . (** [no_nested_borrows::choose_test]: forward function *) -Definition choose_test_fwd : result unit := - z <- choose_fwd i32 true 0%i32 0%i32; +Definition choose_test : result unit := + z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; if negb (z0 s= 1%i32) then Fail_ Failure @@ -231,57 +229,56 @@ Definition choose_test_fwd : result unit := . (** Unit test for [no_nested_borrows::choose_test] *) -Check (choose_test_fwd )%return. +Check (choose_test )%return. (** [no_nested_borrows::test_char]: forward function *) -Definition test_char_fwd : result char := - Return (char_of_byte Coq.Init.Byte.x61) -. +Definition test_char : result char := + Return (char_of_byte Coq.Init.Byte.x61). (** [no_nested_borrows::Tree] *) Inductive Tree_t (T : Type) := -| TreeLeaf : T -> Tree_t T -| TreeNode : T -> Node_elem_t T -> Tree_t T -> Tree_t T +| Tree_Leaf : T -> Tree_t T +| Tree_Node : T -> NodeElem_t T -> Tree_t T -> Tree_t T (** [no_nested_borrows::NodeElem] *) -with Node_elem_t (T : Type) := -| NodeElemCons : Tree_t T -> Node_elem_t T -> Node_elem_t T -| NodeElemNil : Node_elem_t T +with NodeElem_t (T : Type) := +| NodeElem_Cons : Tree_t T -> NodeElem_t T -> NodeElem_t T +| NodeElem_Nil : NodeElem_t T . -Arguments TreeLeaf {T} _. -Arguments TreeNode {T} _ _ _. +Arguments Tree_Leaf {T} _. +Arguments Tree_Node {T} _ _ _. -Arguments NodeElemCons {T} _ _. -Arguments NodeElemNil {T}. +Arguments NodeElem_Cons {T} _ _. +Arguments NodeElem_Nil {T}. (** [no_nested_borrows::list_length]: forward function *) -Fixpoint list_length_fwd (T : Type) (l : List_t T) : result u32 := +Fixpoint list_length (T : Type) (l : List_t T) : result u32 := match l with - | ListCons t l1 => i <- list_length_fwd T l1; u32_add 1%u32 i - | ListNil => Return 0%u32 + | List_Cons t l1 => i <- list_length T l1; u32_add 1%u32 i + | List_Nil => Return 0%u32 end . (** [no_nested_borrows::list_nth_shared]: forward function *) -Fixpoint list_nth_shared_fwd (T : Type) (l : List_t T) (i : u32) : result T := +Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_shared_fwd T tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_shared T tl i0) + | List_Nil => Fail_ Failure end . (** [no_nested_borrows::list_nth_mut]: forward function *) -Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := +Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_mut_fwd T tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut T tl i0) + | List_Nil => Fail_ Failure end . @@ -289,73 +286,72 @@ Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_back T tl i0 ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end . (** [no_nested_borrows::list_rev_aux]: forward function *) -Fixpoint list_rev_aux_fwd +Fixpoint list_rev_aux (T : Type) (li : List_t T) (lo : List_t T) : result (List_t T) := match li with - | ListCons hd tl => list_rev_aux_fwd T tl (ListCons hd lo) - | ListNil => Return lo + | List_Cons hd tl => list_rev_aux T tl (List_Cons hd lo) + | List_Nil => Return lo end . (** [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition list_rev_fwd_back (T : Type) (l : List_t T) : result (List_t T) := - let li := mem_replace_fwd (List_t T) l ListNil in - list_rev_aux_fwd T li ListNil +Definition list_rev (T : Type) (l : List_t T) : result (List_t T) := + let li := core_mem_replace (List_t T) l List_Nil in + list_rev_aux T li List_Nil . (** [no_nested_borrows::test_list_functions]: forward function *) -Definition test_list_functions_fwd : result unit := - let l := ListNil in - let l0 := ListCons 2%i32 l in - let l1 := ListCons 1%i32 l0 in - i <- list_length_fwd i32 (ListCons 0%i32 l1); +Definition test_list_functions : result unit := + let l := List_Nil in + let l0 := List_Cons 2%i32 l in + let l1 := List_Cons 1%i32 l0 in + i <- list_length i32 (List_Cons 0%i32 l1); if negb (i s= 3%u32) then Fail_ Failure else ( - i0 <- list_nth_shared_fwd i32 (ListCons 0%i32 l1) 0%u32; + i0 <- list_nth_shared i32 (List_Cons 0%i32 l1) 0%u32; if negb (i0 s= 0%i32) then Fail_ Failure else ( - i1 <- list_nth_shared_fwd i32 (ListCons 0%i32 l1) 1%u32; + i1 <- list_nth_shared i32 (List_Cons 0%i32 l1) 1%u32; if negb (i1 s= 1%i32) then Fail_ Failure else ( - i2 <- list_nth_shared_fwd i32 (ListCons 0%i32 l1) 2%u32; + i2 <- list_nth_shared i32 (List_Cons 0%i32 l1) 2%u32; if negb (i2 s= 2%i32) then Fail_ Failure else ( - ls <- list_nth_mut_back i32 (ListCons 0%i32 l1) 1%u32 3%i32; - i3 <- list_nth_shared_fwd i32 ls 0%u32; + ls <- list_nth_mut_back i32 (List_Cons 0%i32 l1) 1%u32 3%i32; + i3 <- list_nth_shared i32 ls 0%u32; if negb (i3 s= 0%i32) then Fail_ Failure else ( - i4 <- list_nth_shared_fwd i32 ls 1%u32; + i4 <- list_nth_shared i32 ls 1%u32; if negb (i4 s= 3%i32) then Fail_ Failure else ( - i5 <- list_nth_shared_fwd i32 ls 2%u32; + i5 <- list_nth_shared i32 ls 2%u32; if negb (i5 s= 2%i32) then Fail_ Failure else Return tt)))))) . (** Unit test for [no_nested_borrows::test_list_functions] *) -Check (test_list_functions_fwd )%return. +Check (test_list_functions )%return. (** [no_nested_borrows::id_mut_pair1]: forward function *) -Definition id_mut_pair1_fwd - (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := +Definition id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . @@ -366,8 +362,7 @@ Definition id_mut_pair1_back . (** [no_nested_borrows::id_mut_pair2]: forward function *) -Definition id_mut_pair2_fwd - (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := +Definition id_mut_pair2 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . @@ -378,8 +373,7 @@ Definition id_mut_pair2_back . (** [no_nested_borrows::id_mut_pair3]: forward function *) -Definition id_mut_pair3_fwd - (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := +Definition id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . @@ -396,8 +390,7 @@ Definition id_mut_pair3_back'b . (** [no_nested_borrows::id_mut_pair4]: forward function *) -Definition id_mut_pair4_fwd - (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := +Definition id_mut_pair4 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . @@ -414,101 +407,101 @@ Definition id_mut_pair4_back'b . (** [no_nested_borrows::StructWithTuple] *) -Record Struct_with_tuple_t (T1 T2 : Type) := -mkStruct_with_tuple_t { - Struct_with_tuple_p : (T1 * T2); +Record StructWithTuple_t (T1 T2 : Type) := +mkStructWithTuple_t { + structWithTuple_p : (T1 * T2); } . -Arguments mkStruct_with_tuple_t {T1} {T2} _. -Arguments Struct_with_tuple_p {T1} {T2}. +Arguments mkStructWithTuple_t {T1} {T2} _. +Arguments structWithTuple_p {T1} {T2}. (** [no_nested_borrows::new_tuple1]: forward function *) -Definition new_tuple1_fwd : result (Struct_with_tuple_t u32 u32) := - Return {| Struct_with_tuple_p := (1%u32, 2%u32) |} +Definition new_tuple1 : result (StructWithTuple_t u32 u32) := + Return {| structWithTuple_p := (1%u32, 2%u32) |} . (** [no_nested_borrows::new_tuple2]: forward function *) -Definition new_tuple2_fwd : result (Struct_with_tuple_t i16 i16) := - Return {| Struct_with_tuple_p := (1%i16, 2%i16) |} +Definition new_tuple2 : result (StructWithTuple_t i16 i16) := + Return {| structWithTuple_p := (1%i16, 2%i16) |} . (** [no_nested_borrows::new_tuple3]: forward function *) -Definition new_tuple3_fwd : result (Struct_with_tuple_t u64 i64) := - Return {| Struct_with_tuple_p := (1%u64, 2%i64) |} +Definition new_tuple3 : result (StructWithTuple_t u64 i64) := + Return {| structWithTuple_p := (1%u64, 2%i64) |} . (** [no_nested_borrows::StructWithPair] *) -Record Struct_with_pair_t (T1 T2 : Type) := -mkStruct_with_pair_t { - Struct_with_pair_p : Pair_t T1 T2; +Record StructWithPair_t (T1 T2 : Type) := +mkStructWithPair_t { + structWithPair_p : Pair_t T1 T2; } . -Arguments mkStruct_with_pair_t {T1} {T2} _. -Arguments Struct_with_pair_p {T1} {T2}. +Arguments mkStructWithPair_t {T1} {T2} _. +Arguments structWithPair_p {T1} {T2}. (** [no_nested_borrows::new_pair1]: forward function *) -Definition new_pair1_fwd : result (Struct_with_pair_t u32 u32) := - Return {| Struct_with_pair_p := {| Pair_x := 1%u32; Pair_y := 2%u32 |} |} +Definition new_pair1 : result (StructWithPair_t u32 u32) := + Return {| structWithPair_p := {| pair_x := 1%u32; pair_y := 2%u32 |} |} . (** [no_nested_borrows::test_constants]: forward function *) -Definition test_constants_fwd : result unit := - swt <- new_tuple1_fwd; - let (i, _) := swt.(Struct_with_tuple_p) in +Definition test_constants : result unit := + swt <- new_tuple1; + let (i, _) := swt.(structWithTuple_p) in if negb (i s= 1%u32) then Fail_ Failure else ( - swt0 <- new_tuple2_fwd; - let (i0, _) := swt0.(Struct_with_tuple_p) in + swt0 <- new_tuple2; + let (i0, _) := swt0.(structWithTuple_p) in if negb (i0 s= 1%i16) then Fail_ Failure else ( - swt1 <- new_tuple3_fwd; - let (i1, _) := swt1.(Struct_with_tuple_p) in + swt1 <- new_tuple3; + let (i1, _) := swt1.(structWithTuple_p) in if negb (i1 s= 1%u64) then Fail_ Failure else ( - swp <- new_pair1_fwd; - if negb (swp.(Struct_with_pair_p).(Pair_x) s= 1%u32) + swp <- new_pair1; + if negb (swp.(structWithPair_p).(pair_x) s= 1%u32) then Fail_ Failure else Return tt))) . (** Unit test for [no_nested_borrows::test_constants] *) -Check (test_constants_fwd )%return. +Check (test_constants )%return. (** [no_nested_borrows::test_weird_borrows1]: forward function *) -Definition test_weird_borrows1_fwd : result unit := +Definition test_weird_borrows1 : result unit := Return tt. (** Unit test for [no_nested_borrows::test_weird_borrows1] *) -Check (test_weird_borrows1_fwd )%return. +Check (test_weird_borrows1 )%return. (** [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition test_mem_replace_fwd_back (px : u32) : result u32 := - let y := mem_replace_fwd u32 px 1%u32 in +Definition test_mem_replace (px : u32) : result u32 := + let y := core_mem_replace u32 px 1%u32 in if negb (y s= 0%u32) then Fail_ Failure else Return 2%u32 . (** [no_nested_borrows::test_shared_borrow_bool1]: forward function *) -Definition test_shared_borrow_bool1_fwd (b : bool) : result u32 := +Definition test_shared_borrow_bool1 (b : bool) : result u32 := if b then Return 0%u32 else Return 1%u32 . (** [no_nested_borrows::test_shared_borrow_bool2]: forward function *) -Definition test_shared_borrow_bool2_fwd : result u32 := +Definition test_shared_borrow_bool2 : result u32 := Return 0%u32. (** [no_nested_borrows::test_shared_borrow_enum1]: forward function *) -Definition test_shared_borrow_enum1_fwd (l : List_t u32) : result u32 := - match l with | ListCons i l0 => Return 1%u32 | ListNil => Return 0%u32 end +Definition test_shared_borrow_enum1 (l : List_t u32) : result u32 := + match l with | List_Cons i l0 => Return 1%u32 | List_Nil => Return 0%u32 end . (** [no_nested_borrows::test_shared_borrow_enum2]: forward function *) -Definition test_shared_borrow_enum2_fwd : result u32 := +Definition test_shared_borrow_enum2 : result u32 := Return 0%u32. End NoNestedBorrows . diff --git a/tests/coq/misc/Paper.v b/tests/coq/misc/Paper.v index 175a523d..d397995b 100644 --- a/tests/coq/misc/Paper.v +++ b/tests/coq/misc/Paper.v @@ -10,20 +10,19 @@ Module Paper. (** [paper::ref_incr]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) -Definition ref_incr_fwd_back (x : i32) : result i32 := +Definition ref_incr (x : i32) : result i32 := i32_add x 1%i32. (** [paper::test_incr]: forward function *) -Definition test_incr_fwd : result unit := - x <- ref_incr_fwd_back 0%i32; - if negb (x s= 1%i32) then Fail_ Failure else Return tt +Definition test_incr : result unit := + x <- ref_incr 0%i32; if negb (x s= 1%i32) then Fail_ Failure else Return tt . (** Unit test for [paper::test_incr] *) -Check (test_incr_fwd )%return. +Check (test_incr )%return. (** [paper::choose]: forward function *) -Definition choose_fwd (T : Type) (b : bool) (x : T) (y : T) : result T := +Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . @@ -34,8 +33,8 @@ Definition choose_back . (** [paper::test_choose]: forward function *) -Definition test_choose_fwd : result unit := - z <- choose_fwd i32 true 0%i32 0%i32; +Definition test_choose : result unit := + z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; if negb (z0 s= 1%i32) then Fail_ Failure @@ -48,25 +47,25 @@ Definition test_choose_fwd : result unit := . (** Unit test for [paper::test_choose] *) -Check (test_choose_fwd )%return. +Check (test_choose )%return. (** [paper::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons {T} _ _. +Arguments List_Nil {T}. (** [paper::list_nth_mut]: forward function *) -Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := +Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 then Return x - else (i0 <- u32_sub i 1%u32; list_nth_mut_fwd T tl i0) - | ListNil => Fail_ Failure + else (i0 <- u32_sub i 1%u32; list_nth_mut T tl i0) + | List_Nil => Fail_ Failure end . @@ -74,44 +73,44 @@ Fixpoint list_nth_mut_fwd (T : Type) (l : List_t T) (i : u32) : result T := Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with - | ListCons x tl => + | List_Cons x tl => if i s= 0%u32 - then Return (ListCons ret tl) + then Return (List_Cons ret tl) else ( i0 <- u32_sub i 1%u32; tl0 <- list_nth_mut_back T tl i0 ret; - Return (ListCons x tl0)) - | ListNil => Fail_ Failure + Return (List_Cons x tl0)) + | List_Nil => Fail_ Failure end . (** [paper::sum]: forward function *) -Fixpoint sum_fwd (l : List_t i32) : result i32 := +Fixpoint sum (l : List_t i32) : result i32 := match l with - | ListCons x tl => i <- sum_fwd tl; i32_add x i - | ListNil => Return 0%i32 + | List_Cons x tl => i <- sum tl; i32_add x i + | List_Nil => Return 0%i32 end . (** [paper::test_nth]: forward function *) -Definition test_nth_fwd : result unit := - let l := ListNil in - let l0 := ListCons 3%i32 l in - let l1 := ListCons 2%i32 l0 in - x <- list_nth_mut_fwd i32 (ListCons 1%i32 l1) 2%u32; +Definition test_nth : result unit := + let l := List_Nil in + let l0 := List_Cons 3%i32 l in + let l1 := List_Cons 2%i32 l0 in + x <- list_nth_mut i32 (List_Cons 1%i32 l1) 2%u32; x0 <- i32_add x 1%i32; - l2 <- list_nth_mut_back i32 (ListCons 1%i32 l1) 2%u32 x0; - i <- sum_fwd l2; + l2 <- list_nth_mut_back i32 (List_Cons 1%i32 l1) 2%u32 x0; + i <- sum l2; if negb (i s= 7%i32) then Fail_ Failure else Return tt . (** Unit test for [paper::test_nth] *) -Check (test_nth_fwd )%return. +Check (test_nth )%return. (** [paper::call_choose]: forward function *) -Definition call_choose_fwd (p : (u32 * u32)) : result u32 := +Definition call_choose (p : (u32 * u32)) : result u32 := let (px, py) := p in - pz <- choose_fwd u32 true px py; + pz <- choose u32 true px py; pz0 <- u32_add pz 1%u32; p0 <- choose_back u32 true px py pz0; let (px0, _) := p0 in diff --git a/tests/coq/misc/PoloniusList.v b/tests/coq/misc/PoloniusList.v index 54021bdf..4f804b55 100644 --- a/tests/coq/misc/PoloniusList.v +++ b/tests/coq/misc/PoloniusList.v @@ -10,19 +10,19 @@ Module PoloniusList. (** [polonius_list::List] *) Inductive List_t (T : Type) := -| ListCons : T -> List_t T -> List_t T -| ListNil : List_t T +| List_Cons : T -> List_t T -> List_t T +| List_Nil : List_t T . -Arguments ListCons {T} _ _. -Arguments ListNil {T}. +Arguments List_Cons {T} _ _. +Arguments List_Nil {T}. (** [polonius_list::get_list_at_x]: forward function *) -Fixpoint get_list_at_x_fwd (ls : List_t u32) (x : u32) : result (List_t u32) := +Fixpoint get_list_at_x (ls : List_t u32) (x : u32) : result (List_t u32) := match ls with - | ListCons hd tl => - if hd s= x then Return (ListCons hd tl) else get_list_at_x_fwd tl x - | ListNil => Return ListNil + | List_Cons hd tl => + if hd s= x then Return (List_Cons hd tl) else get_list_at_x tl x + | List_Nil => Return List_Nil end . @@ -30,11 +30,11 @@ Fixpoint get_list_at_x_fwd (ls : List_t u32) (x : u32) : result (List_t u32) := Fixpoint get_list_at_x_back (ls : List_t u32) (x : u32) (ret : List_t u32) : result (List_t u32) := match ls with - | ListCons hd tl => + | List_Cons hd tl => if hd s= x then Return ret - else (tl0 <- get_list_at_x_back tl x ret; Return (ListCons hd tl0)) - | ListNil => Return ret + else (tl0 <- get_list_at_x_back tl x ret; Return (List_Cons hd tl0)) + | List_Nil => Return ret end . diff --git a/tests/coq/misc/Primitives.v b/tests/coq/misc/Primitives.v index 8d6c9c8d..85e38f01 100644 --- a/tests/coq/misc/Primitives.v +++ b/tests/coq/misc/Primitives.v @@ -63,13 +63,15 @@ Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. (*** Misc *) - Definition string := Coq.Strings.String.string. Definition char := Coq.Strings.Ascii.ascii. Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. -Definition mem_replace_fwd (a : Type) (x : a) (y : a) : a := x . -Definition mem_replace_back (a : Type) (x : a) (y : a) : a := y . +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. (*** Scalars *) @@ -408,12 +410,75 @@ Definition core_i64_max := i64_max %i64. Definition core_i128_max := i64_max %i128. Axiom core_isize_max : isize. (** TODO *) -(*** Range *) -Record range (T : Type) := mk_range { - start: T; - end_: T; +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; }. -Arguments mk_range {_}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + (*** Arrays *) Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. @@ -433,51 +498,50 @@ Qed. (* TODO: finish the definitions *) Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. -Axiom array_index_shared : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_fwd : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. -Axiom array_index_mut_back : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). (*** Slice *) Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. Axiom slice_len : forall (T : Type) (s : slice T), usize. -Axiom slice_index_shared : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_fwd : forall (T : Type) (x : slice T) (i : usize), result T. -Axiom slice_index_mut_back : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). (*** Subslices *) -Axiom array_to_slice_shared : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_fwd : forall (T : Type) (n : usize) (x : array T n), result (slice T). -Axiom array_to_slice_mut_back : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). -Axiom array_subslice_shared: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_fwd: forall (T : Type) (n : usize) (x : array T n) (r : range usize), result (slice T). -Axiom array_subslice_mut_back: forall (T : Type) (n : usize) (x : array T n) (r : range usize) (ns : slice T), result (array T n). -Axiom slice_subslice_shared: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_fwd: forall (T : Type) (x : slice T) (r : range usize), result (slice T). -Axiom slice_subslice_mut_back: forall (T : Type) (x : slice T) (r : range usize) (ns : slice T), result (slice T). +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). (*** Vectors *) -Definition vec T := { l: list T | Z.of_nat (length l) <= usize_max }. +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. -Definition vec_to_list {T: Type} (v: vec T) : list T := proj1_sig v. +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. -Definition vec_length {T: Type} (v: vec T) : Z := Z.of_nat (length (vec_to_list v)). +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). -Definition vec_new (T: Type) : vec T := (exist _ [] le_0_usize_max). +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). -Lemma vec_len_in_usize {T} (v: vec T) : usize_min <= vec_length v <= usize_max. +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. Proof. - unfold vec_length, usize_min. + unfold alloc_vec_Vec_length, usize_min. split. - lia. - apply (proj2_sig v). Qed. -Definition vec_len (T: Type) (v: vec T) : usize := - exist _ (vec_length v) (vec_len_in_usize v). +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). Fixpoint list_update {A} (l: list A) (n: nat) (a: A) : list A := @@ -488,50 +552,271 @@ Fixpoint list_update {A} (l: list A) (n: nat) (a: A) | S m => x :: (list_update t m a) end end. -Definition vec_bind {A B} (v: vec A) (f: list A -> result (list B)) : result (vec B) := - l <- f (vec_to_list v) ; +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) | right _ => Fail_ Failure end. (* The **forward** function shouldn't be used *) -Definition vec_push_fwd (T: Type) (v: vec T) (x: T) : unit := tt. +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. -Definition vec_push_back (T: Type) (v: vec T) (x: T) : result (vec T) := - vec_bind v (fun l => Return (l ++ [x])). +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). (* The **forward** function shouldn't be used *) -Definition vec_insert_fwd (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i +Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => if to_Z i Return n - | None => Fail_ Failure - end. - -Definition vec_index_back (T: Type) (v: vec T) (i: usize) (x: T) : result unit := - if to_Z i Return n - | None => Fail_ Failure +(* Helper *) +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. + +(* Helper *) +Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). + +(* Trait declaration: [core::slice::index::private_slice_index::Sealed] *) +Definition core_slice_index_private_slice_index_Sealed (self : Type) := unit. + +(* Trait declaration: [core::slice::index::SliceIndex] *) +Record core_slice_index_SliceIndex (Self T : Type) := mk_core_slice_index_SliceIndex { + core_slice_index_SliceIndex_sealedInst : core_slice_index_private_slice_index_Sealed Self; + core_slice_index_SliceIndex_Output : Type; + core_slice_index_SliceIndex_get : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x end. -Definition vec_index_mut_back (T: Type) (v: vec T) (i: usize) (x: T) : result (vec T) := - vec_bind v (fun l => - if to_Z i slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. End Primitives. -- 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(-) 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 c200d43abf96c6f3126d1de40e7e4c547e4e7371 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 27 Oct 2023 15:16:44 +0200 Subject: Add some files for the Coq trait tests --- tests/coq/traits/Makefile | 23 +++++++++++++++++++++++ tests/coq/traits/_CoqProject | 5 +++++ 2 files changed, 28 insertions(+) create mode 100644 tests/coq/traits/Makefile create mode 100644 tests/coq/traits/_CoqProject diff --git a/tests/coq/traits/Makefile b/tests/coq/traits/Makefile new file mode 100644 index 00000000..1a5aee4a --- /dev/null +++ b/tests/coq/traits/Makefile @@ -0,0 +1,23 @@ +# This file was automatically generated - modify ../Makefile.template instead +# Makefile originally taken from coq-club + +%: Makefile.coq phony + +make -f Makefile.coq $@ + +all: Makefile.coq + +make -f Makefile.coq all + +clean: Makefile.coq + +make -f Makefile.coq clean + rm -f Makefile.coq + +Makefile.coq: _CoqProject Makefile + coq_makefile -f _CoqProject | sed 's/$$(COQCHK) $$(COQCHKFLAGS) $$(COQLIBS)/$$(COQCHK) $$(COQCHKFLAGS) $$(subst -Q,-R,$$(COQLIBS))/' > Makefile.coq + +_CoqProject: ; + +Makefile: ; + +phony: ; + +.PHONY: all clean phony diff --git a/tests/coq/traits/_CoqProject b/tests/coq/traits/_CoqProject new file mode 100644 index 00000000..d573657e --- /dev/null +++ b/tests/coq/traits/_CoqProject @@ -0,0 +1,5 @@ +# This file was automatically generated - see ../Makefile +-R . Lib +-arg -w +-arg all + -- 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(-) 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 --- Makefile | 10 ++++++- compiler/Extract.ml | 37 ++++++++++------------- compiler/ExtractTypes.ml | 75 ++++++++++++++++++++++++---------------------- compiler/Pure.ml | 1 + compiler/SymbolicToPure.ml | 3 ++ 5 files changed, 68 insertions(+), 58 deletions(-) diff --git a/Makefile b/Makefile index 958ae8d7..694b47a3 100644 --- a/Makefile +++ b/Makefile @@ -91,7 +91,7 @@ tests: trans-no_nested_borrows trans-paper \ transp-polonius_list transp-betree_main \ test-transp-betree_main \ trans-loops \ - trans-array # TODO: generalize to all backends + trans-array trans-traits # TODO: generalize to all backends # Verify the F* files generated by the translation .PHONY: verify @@ -131,6 +131,14 @@ tlean-array: SUBDIR := tlean-array: OPTIONS += thol4-array: OPTIONS += +trans-traits: OPTIONS += -no-state +trans-traits: SUBDIR := traits +tfstar-traits: OPTIONS += -decreases-clauses -template-clauses +tcoq-traits: OPTIONS += -use-fuel +tlean-traits: SUBDIR := +tlean-traits: OPTIONS += +thol4-traits: OPTIONS += + # TODO: activate the arrays for all the backends thol4-array: echo "Ignoring the array test for HOL4" 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(-) 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 c8fce0c24f2f5331f2f1135cc17d45192f2b30e3 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 6 Nov 2023 18:49:27 +0100 Subject: Regenerate part of the trait tests for Lean --- tests/lean/Traits/Funs.lean | 35 ++++++++++++++++++++------------- tests/lean/Traits/Types.lean | 46 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 65 insertions(+), 16 deletions(-) diff --git a/tests/lean/Traits/Funs.lean b/tests/lean/Traits/Funs.lean index 52ff0c0a..156ef1e0 100644 --- a/tests/lean/Traits/Funs.lean +++ b/tests/lean/Traits/Funs.lean @@ -31,8 +31,8 @@ def test_bool_trait_bool (x : Bool) : Result Bool := /- [traits::Option::{1}::get_bool]: forward function -/ def Option.get_bool (T : Type) (self : Option T) : Result Bool := match self with - | Option.none => Result.ret false - | Option.some t => Result.ret true + | none => Result.ret false + | some t => Result.ret true /- Trait implementation: [traits::Option::{1}] -/ def Option.BoolTraitInst (T : Type) : BoolTrait (Option T) := { @@ -105,7 +105,7 @@ def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := /- [traits::u64::{5}::to_type]: forward function -/ def u64.to_type (self : U64) : Result Bool := - Result.ret (self > (U64.ofInt 0)) + Result.ret (self > 0#u64) /- Trait implementation: [traits::u64::{5}] -/ def u64.ToTypeInst : ToType U64 Bool := { @@ -129,7 +129,7 @@ def h4 /- [traits::TestType::{6}::test::TestType1::{0}::test]: forward function -/ def TestType.test.TestType1.test (self : TestType.test.TestType1) : Result Bool := - Result.ret (self._0 > (U64.ofInt 1)) + Result.ret (self._0 > 1#u64) /- Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] -/ def TestType.test.TestType1.TestTypetestTestTraitInst : TestType.test.TestTrait @@ -142,8 +142,8 @@ def TestType.test (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := do let x0 ← inst.to_u64 x - if x0 > (U64.ofInt 0) - then TestType.test.TestType1.test { _0 := (U64.ofInt 0) } + if x0 > 0#u64 + then TestType.test.TestType1.test { _0 := 0#u64 } else Result.ret false /- [traits::BoolWrapper::{7}::to_type]: forward function -/ @@ -158,21 +158,21 @@ def BoolWrapper.ToTypeInst (T : Type) (inst : ToType Bool T) : ToType } /- [traits::WithConstTy::LEN2] -/ -def with_const_ty_len2_body : Result Usize := Result.ret (Usize.ofInt 32) +def with_const_ty_len2_body : Result Usize := Result.ret 32#usize def with_const_ty_len2_c : Usize := eval_global with_const_ty_len2_body (by simp) /- [traits::Bool::{8}::LEN1] -/ -def bool_len1_body : Result Usize := Result.ret (Usize.ofInt 12) +def bool_len1_body : Result Usize := Result.ret 12#usize def bool_len1_c : Usize := eval_global bool_len1_body (by simp) /- [traits::Bool::{8}::f]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ -def Bool.f (i : U64) (a : Array U8 (Usize.ofInt 32)) : Result U64 := +def Bool.f (i : U64) (a : Array U8 32#usize) : Result U64 := Result.ret i /- Trait implementation: [traits::Bool::{8}] -/ -def Bool.WithConstTyInst : WithConstTy Bool (Usize.ofInt 32) := { +def Bool.WithConstTyInst : WithConstTy Bool 32#usize := { LEN1 := bool_len1_c LEN2 := with_const_ty_len2_c V := U8 @@ -207,9 +207,7 @@ def test_where1 (T : Type) (_x : T) : Result Unit := /- [traits::test_where2]: forward function -/ def test_where2 - (T : Type) (inst : WithConstTy T (Usize.ofInt 32)) (_x : U32) : - Result Unit - := + (T : Type) (inst : WithConstTy T 32#usize) (_x : U32) : Result Unit := Result.ret () /- [traits::test_child_trait1]: forward function -/ @@ -229,4 +227,15 @@ def order1 := Result.ret () +/- [traits::map_option]: forward function -/ +def map_option + (T F : Type) (inst : core.ops.function.Fn F T) (x : Option T) (f0 : F) : + Result (Option T) + := + match x with + | none => Result.ret none + | some x0 => do + let t ← inst.call f0 x0 + Result.ret (some t) + end traits diff --git a/tests/lean/Traits/Types.lean b/tests/lean/Traits/Types.lean index a8c12fe5..e325da6f 100644 --- a/tests/lean/Traits/Types.lean +++ b/tests/lean/Traits/Types.lean @@ -27,7 +27,7 @@ structure OfType (Self : Type) where /- Trait declaration: [traits::OfTypeBis] -/ structure OfTypeBis (Self T : Type) where - parent_clause_0 :ToType T Self + parent_clause_0 : ToType T Self of_type : T → Result Self /- [traits::TestType] -/ @@ -69,8 +69,8 @@ structure ParentTrait1 (Self : Type) where /- Trait declaration: [traits::ChildTrait] -/ structure ChildTrait (Self : Type) where - parent_clause_0 :ParentTrait0 Self - parent_clause_1 :ParentTrait1 Self + parent_clause_0 : ParentTrait0 Self + parent_clause_1 : ParentTrait1 Self /- Trait declaration: [traits::Iterator] -/ structure Iterator (Self : Type) where @@ -83,4 +83,44 @@ structure IntoIterator (Self : Type) where IntoIter_clause_0 : Iterator IntoIter into_iter : Self → Result IntoIter +/- Trait declaration: [traits::FromResidual] -/ +structure FromResidual (Self T : Type) where + +/- Trait declaration: [traits::Try] -/ +structure Try (Self : Type) where + parent_clause_0 : FromResidual Self Residual + Residual : Type + +/- Trait declaration: [traits::CFnOnce] -/ +structure CFnOnce (Self Args : Type) where + Output : Type + call_once : Self → Args → Result Output + +/- Trait declaration: [traits::CFnMut] -/ +structure CFnMut (Self Args : Type) where + parent_clause_0 : CFnOnce Self Args + call_mut : Self → Args → Result parent_clause_0.Output + call_mut_back : Self → Args → parent_clause_0.Output → Result Self + +/- Trait declaration: [traits::CFn] -/ +structure CFn (Self Args : Type) where + parent_clause_0 : CFnMut Self Args + call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output + +/- Trait declaration: [core::ops::function::FnOnce] -/ +structure core.ops.function.FnOnce (Self Args : Type) where + Output : Type + call_once : Self → Args → Result Output + +/- Trait declaration: [core::ops::function::FnMut] -/ +structure core.ops.function.FnMut (Self Args : Type) where + parent_clause_0 : core.ops.function.FnOnce Self Args + call_mut : Self → Args → Result parent_clause_0.Output + call_mut_back : Self → Args → parent_clause_0.Output → Result Self + +/- Trait declaration: [core::ops::function::Fn] -/ +structure core.ops.function.Fn (Self Args : Type) where + parent_clause_0 : core.ops.function.FnMut Self Args + call : Self → Args → Result parent_clause_0.parent_clause_0.Output + end traits -- 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(-) 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(-) 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 ++-- tests/lean/Traits/Funs.lean | 9 +++++++++ tests/lean/Traits/Types.lean | 4 ++++ 3 files changed, 15 insertions(+), 2 deletions(-) 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 diff --git a/tests/lean/Traits/Funs.lean b/tests/lean/Traits/Funs.lean index 156ef1e0..6a2834ff 100644 --- a/tests/lean/Traits/Funs.lean +++ b/tests/lean/Traits/Funs.lean @@ -227,6 +227,15 @@ def order1 := Result.ret () +/- Trait implementation: [traits::usize::{9}] -/ +def usize.ParentTrait1Inst : ParentTrait1 Usize := { +} + +/- Trait implementation: [traits::usize::{10}] -/ +def usize.ChildTrait1Inst : ChildTrait1 Usize := { + parent_clause_0 := usize.ParentTrait1Inst +} + /- [traits::map_option]: forward function -/ def map_option (T F : Type) (inst : core.ops.function.Fn F T) (x : Option T) (f0 : F) : diff --git a/tests/lean/Traits/Types.lean b/tests/lean/Traits/Types.lean index e325da6f..20af9cb1 100644 --- a/tests/lean/Traits/Types.lean +++ b/tests/lean/Traits/Types.lean @@ -72,6 +72,10 @@ structure ChildTrait (Self : Type) where parent_clause_0 : ParentTrait0 Self parent_clause_1 : ParentTrait1 Self +/- Trait declaration: [traits::ChildTrait1] -/ +structure ChildTrait1 (Self : Type) where + parent_clause_0 : ParentTrait1 Self + /- Trait declaration: [traits::Iterator] -/ structure Iterator (Self : Type) where Item : Type -- cgit v1.2.3 From 530a5ae56209061f091bbcafee82de07039a8124 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 8 Nov 2023 14:28:44 +0100 Subject: Update the Makefile and regenerate some tests --- Makefile | 4 ++++ tests/coq/misc/NoNestedBorrows.v | 12 ++++++++++++ tests/fstar/misc/NoNestedBorrows.fst | 12 ++++++++++++ tests/lean/NoNestedBorrows.lean | 12 ++++++++++++ 4 files changed, 40 insertions(+) diff --git a/Makefile b/Makefile index 694b47a3..486ba40e 100644 --- a/Makefile +++ b/Makefile @@ -143,6 +143,10 @@ thol4-traits: OPTIONS += thol4-array: echo "Ignoring the array test for HOL4" +# TODO: activate the traits for all the backends +thol4-traits: + echo "Ignoring the traits test for HOL4" + trans-loops: OPTIONS += -no-state trans-loops: SUBDIR := misc tfstar-loops: OPTIONS += -decreases-clauses -template-clauses diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index 47cdc3af..e916ca4a 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -71,6 +71,18 @@ Definition div_test1 (x : u32) : result u32 := Definition rem_test (x : u32) (y : u32) : result u32 := u32_rem x y. +(** [no_nested_borrows::mul_test]: forward function *) +Definition mul_test (x : u32) (y : u32) : result u32 := + u32_mul x y. + +(** [no_nested_borrows::CONST0] *) +Definition const0_body : result usize := usize_add 1%usize 1%usize. +Definition const0_c : usize := const0_body%global. + +(** [no_nested_borrows::CONST1] *) +Definition const1_body : result usize := usize_mul 2%usize 2%usize. +Definition const1_c : usize := const1_body%global. + (** [no_nested_borrows::cast_test]: forward function *) Definition cast_test (x : u32) : result i32 := scalar_cast U32 I32 x. diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index 33142250..e97927aa 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -54,6 +54,18 @@ let div_test1 (x : u32) : result u32 = let rem_test (x : u32) (y : u32) : result u32 = u32_rem x y +(** [no_nested_borrows::mul_test]: forward function *) +let mul_test (x : u32) (y : u32) : result u32 = + u32_mul x y + +(** [no_nested_borrows::CONST0] *) +let const0_body : result usize = usize_add 1 1 +let const0_c : usize = eval_global const0_body + +(** [no_nested_borrows::CONST1] *) +let const1_body : result usize = usize_mul 2 2 +let const1_c : usize = eval_global const1_body + (** [no_nested_borrows::cast_test]: forward function *) let cast_test (x : u32) : result i32 = scalar_cast U32 I32 x diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index d6d603ce..c4a6a265 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -60,6 +60,18 @@ def div_test1 (x : U32) : Result U32 := def rem_test (x : U32) (y : U32) : Result U32 := x % y +/- [no_nested_borrows::mul_test]: forward function -/ +def mul_test (x : U32) (y : U32) : Result U32 := + x * y + +/- [no_nested_borrows::CONST0] -/ +def const0_body : Result Usize := 1#usize + 1#usize +def const0_c : Usize := eval_global const0_body (by simp) + +/- [no_nested_borrows::CONST1] -/ +def const1_body : Result Usize := 2#usize * 2#usize +def const1_c : Usize := eval_global const1_body (by simp) + /- [no_nested_borrows::cast_test]: forward function -/ def cast_test (x : U32) : Result I32 := Scalar.cast .I32 x -- 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(-) 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 eb9ff46c69b9a95c453d64eee059916130d59846 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 11:22:39 +0100 Subject: Regenerate some Lean tests --- tests/lean/Traits/Funs.lean | 25 +++++++++++++++++++++++++ tests/lean/Traits/Types.lean | 14 ++++++++++++++ 2 files changed, 39 insertions(+) diff --git a/tests/lean/Traits/Funs.lean b/tests/lean/Traits/Funs.lean index 6a2834ff..8d423280 100644 --- a/tests/lean/Traits/Funs.lean +++ b/tests/lean/Traits/Funs.lean @@ -247,4 +247,29 @@ def map_option let t ← inst.call f0 x0 Result.ret (some t) +/- Trait implementation: [traits::u32::{11}] -/ +def u32.WithTargetInst : WithTarget U32 := { + Target := U32 +} + +/- Trait implementation: [traits::u32::{12}] -/ +def u32.ParentTrait2Inst : ParentTrait2 U32 := { + U := U32 + U_clause_0 := u32.WithTargetInst +} + +/- [traits::u32::{13}::convert]: forward function -/ +def u32.convert (x : U32) : Result U32 := + Result.ret x + +/- Trait implementation: [traits::u32::{13}] -/ +def u32.ChildTrait2Inst : ChildTrait2 U32 := { + parent_clause_0 := u32.ParentTrait2Inst + convert := u32.convert +} + +/- [traits::incr_u32]: forward function -/ +def incr_u32 (x : U32) : Result U32 := + x + 1#u32 + end traits diff --git a/tests/lean/Traits/Types.lean b/tests/lean/Traits/Types.lean index 20af9cb1..4c5dd874 100644 --- a/tests/lean/Traits/Types.lean +++ b/tests/lean/Traits/Types.lean @@ -127,4 +127,18 @@ structure core.ops.function.Fn (Self Args : Type) where parent_clause_0 : core.ops.function.FnMut Self Args call : Self → Args → Result parent_clause_0.parent_clause_0.Output +/- Trait declaration: [traits::WithTarget] -/ +structure WithTarget (Self : Type) where + Target : Type + +/- Trait declaration: [traits::ParentTrait2] -/ +structure ParentTrait2 (Self : Type) where + U : Type + U_clause_0 : WithTarget U + +/- Trait declaration: [traits::ChildTrait2] -/ +structure ChildTrait2 (Self : Type) where + parent_clause_0 : ParentTrait2 Self + convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target + end traits -- cgit v1.2.3 From 9754c65c76cc48f9d3feab410dfe18273ae08c05 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 11:24:56 +0100 Subject: Update the Makefile to rename the "trans-" rules to "test-" --- Makefile | 92 ++++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 46 insertions(+), 46 deletions(-) diff --git a/Makefile b/Makefile index 486ba40e..bdabe878 100644 --- a/Makefile +++ b/Makefile @@ -85,13 +85,13 @@ clean: # Test the project by translating test files to F* .PHONY: tests -tests: trans-no_nested_borrows trans-paper \ - trans-hashmap trans-hashmap_main \ - trans-external trans-constants \ - transp-polonius_list transp-betree_main \ - test-transp-betree_main \ - trans-loops \ - trans-array trans-traits # TODO: generalize to all backends +tests: test-no_nested_borrows test-paper \ + test-hashmap test-hashmap_main \ + test-external test-constants \ + testp-polonius_list testp-betree_main \ + ctest-testp-betree_main \ + test-loops \ + test-array test-traits # TODO: generalize to all backends # Verify the F* files generated by the translation .PHONY: verify @@ -114,25 +114,25 @@ AENEAS_CMD = $(AENEAS_EXE) $(CHARON_TEST_DIR)/llbc/$(FILE).llbc -dest tests/$(BA # Add specific options to some tests -trans-no_nested_borrows trans-paper: \ +test-no_nested_borrows test-paper: \ OPTIONS += -test-trans-units -no-split-files -no-state -trans-no_nested_borrows trans-paper: SUBDIR := misc +test-no_nested_borrows test-paper: SUBDIR := misc tfstar-no_nested_borrows tfstar-paper: tlean-no_nested_borrows: SUBDIR := tlean-paper: SUBDIR := thol4-no_nested_borrows: SUBDIR := misc-no_nested_borrows thol4-paper: SUBDIR := misc-paper -trans-array: OPTIONS += -no-state -trans-array: SUBDIR := array +test-array: OPTIONS += -no-state +test-array: SUBDIR := array tfstar-array: OPTIONS += -decreases-clauses -template-clauses tcoq-array: OPTIONS += -use-fuel tlean-array: SUBDIR := tlean-array: OPTIONS += thol4-array: OPTIONS += -trans-traits: OPTIONS += -no-state -trans-traits: SUBDIR := traits +test-traits: OPTIONS += -no-state +test-traits: SUBDIR := traits tfstar-traits: OPTIONS += -decreases-clauses -template-clauses tcoq-traits: OPTIONS += -use-fuel tlean-traits: SUBDIR := @@ -147,16 +147,16 @@ thol4-array: thol4-traits: echo "Ignoring the traits test for HOL4" -trans-loops: OPTIONS += -no-state -trans-loops: SUBDIR := misc +test-loops: OPTIONS += -no-state +test-loops: SUBDIR := misc tfstar-loops: OPTIONS += -decreases-clauses -template-clauses tcoq-loops: OPTIONS += -use-fuel -no-split-files tlean-loops: SUBDIR := thol4-loops: SUBDIR := misc-loops # TODO: reactivate -test-trans-units -trans-hashmap: OPTIONS += -no-state -trans-hashmap: SUBDIR := hashmap +test-hashmap: OPTIONS += -no-state +test-hashmap: SUBDIR := hashmap tfstar-hashmap: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap: OPTIONS += -use-fuel tlean-hashmap: SUBDIR := @@ -164,15 +164,15 @@ tlean-hashmap: OPTIONS += -no-gen-lib-entry # We add a custom import in the Hash thol4-hashmap: OPTIONS += # TODO: reactivate -test-trans-units -trans-hashmap_main: OPTIONS += -trans-hashmap_main: SUBDIR := hashmap_on_disk +test-hashmap_main: OPTIONS += +test-hashmap_main: SUBDIR := hashmap_on_disk tfstar-hashmap_main: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap_main: OPTIONS += -use-fuel tlean-hashmap_main: SUBDIR := thol4-hashmap_main: OPTIONS += -transp-polonius_list: OPTIONS += -test-trans-units -no-split-files -no-state -transp-polonius_list: SUBDIR := misc +testp-polonius_list: OPTIONS += -test-trans-units -no-split-files -no-state +testp-polonius_list: SUBDIR := misc tfstarp-polonius_list: OPTIONS += tcoqp-polonius_list: OPTIONS += tleanp-polonius_list: SUBDIR := @@ -180,8 +180,8 @@ tleanp-polonius_list: OPTIONS += thol4p-polonius_list: SUBDIR := misc-polonius_list thol4p-polonius_list: OPTIONS += -trans-constants: OPTIONS += -test-trans-units -no-split-files -no-state -trans-constants: SUBDIR := misc +test-constants: OPTIONS += -test-trans-units -no-split-files -no-state +test-constants: SUBDIR := misc tfstar-constants: OPTIONS += tcoq-constants: OPTIONS += tlean-constants: SUBDIR := @@ -189,8 +189,8 @@ tlean-constants: OPTIONS += thol4-constants: SUBDIR := misc-constants thol4-constants: OPTIONS += -trans-external: OPTIONS += -test-trans-units -trans-external: SUBDIR := misc +test-external: OPTIONS += -test-trans-units +test-external: SUBDIR := misc tfstar-external: OPTIONS += tcoq-external: OPTIONS += tlean-external: SUBDIR := @@ -199,25 +199,25 @@ thol4-external: SUBDIR := misc-external thol4-external: OPTIONS += BETREE_FSTAR_OPTIONS = -decreases-clauses -template-clauses -transp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units -transp-betree_main: SUBDIR:=betree +testp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units +testp-betree_main: SUBDIR:=betree tfstarp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) tcoqp-betree_main: OPTIONS += -use-fuel tleanp-betree_main: SUBDIR := tleanp-betree_main: OPTIONS += thol4-betree_main: OPTIONS += -# Additional test on the betree: translate it without `-backward-no-state-update`. +# Additional, *c*ustom test on the betree: translate it without `-backward-no-state-update`. # This generates very ugly code, but is good to test the translation. -.PHONY: test-transp-betree_main -test-transp-betree_main: transp-betree_main -test-transp-betree_main: OPTIONS += -backend fstar -test-trans-units -test-transp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) -test-transp-betree_main: BACKEND_SUBDIR := "fstar" -test-transp-betree_main: SUBDIR:=betree_back_stateful -test-transp-betree_main: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) -test-transp-betree_main: FILE = betree_main -test-transp-betree_main: +.PHONY: ctest-testp-betree_main +ctest-testp-betree_main: testp-betree_main +ctest-testp-betree_main: OPTIONS += -backend fstar -test-trans-units +ctest-testp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) +ctest-testp-betree_main: BACKEND_SUBDIR := "fstar" +ctest-testp-betree_main: SUBDIR:=betree_back_stateful +ctest-testp-betree_main: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) +ctest-testp-betree_main: FILE = betree_main +ctest-testp-betree_main: $(AENEAS_CMD) # Generic rules to extract the LLBC from a rust file @@ -234,20 +234,20 @@ gen-llbcp-%: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) gen-llbcp-%: $(CHARON_CMD) -# Generic rules to test the translation of an LLBC file. +# Generic rules to test the testlation of an LLBC file. # Note that the files requiring the Polonius borrow-checker are generated # in the tests-polonius subdirectory. -.PHONY: trans-% -trans-%: CHARON_TEST_DIR = $(CHARON_TESTS_REGULAR_DIR) -trans-%: FILE = $* -trans-%: gen-llbc-% tfstar-% tcoq-% tlean-% thol4-% +.PHONY: test-% +test-%: CHARON_TEST_DIR = $(CHARON_TESTS_REGULAR_DIR) +test-%: FILE = $* +test-%: gen-llbc-% tfstar-% tcoq-% tlean-% thol4-% echo "# Test $* done" # "p" stands for "Polonius" -.PHONY: transp-% -transp-%: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) -transp-%: FILE = $* -transp-%: gen-llbcp-% tfstarp-% tcoqp-% tleanp-% thol4p-% +.PHONY: testp-% +testp-%: CHARON_TEST_DIR = $(CHARON_TESTS_POLONIUS_DIR) +testp-%: FILE = $* +testp-%: gen-llbcp-% tfstarp-% tcoqp-% tleanp-% thol4p-% echo "# Test $* done" .PHONY: tfstar-% -- 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 --- Makefile | 26 +- compiler/Config.ml | 4 +- compiler/Driver.ml | 14 +- tests/fstar/misc/Loops.fst | 784 +++++++++++++++++++++++++++++++++++++++++++ tests/lean/Array.lean | 436 +++++++++++++++++++++++- tests/lean/Loops.lean | 630 +++++++++++++++++++++++++++++++++- tests/lean/Loops/Funs.lean | 625 ---------------------------------- tests/lean/Loops/Types.lean | 13 - tests/lean/Traits.lean | 411 ++++++++++++++++++++++- tests/lean/Traits/Funs.lean | 275 --------------- tests/lean/Traits/Types.lean | 144 -------- 11 files changed, 2280 insertions(+), 1082 deletions(-) create mode 100644 tests/fstar/misc/Loops.fst delete mode 100644 tests/lean/Loops/Funs.lean delete mode 100644 tests/lean/Loops/Types.lean delete mode 100644 tests/lean/Traits/Funs.lean delete mode 100644 tests/lean/Traits/Types.lean diff --git a/Makefile b/Makefile index bdabe878..19992442 100644 --- a/Makefile +++ b/Makefile @@ -115,7 +115,7 @@ AENEAS_CMD = $(AENEAS_EXE) $(CHARON_TEST_DIR)/llbc/$(FILE).llbc -dest tests/$(BA # Add specific options to some tests test-no_nested_borrows test-paper: \ - OPTIONS += -test-trans-units -no-split-files -no-state + OPTIONS += -test-trans-units test-no_nested_borrows test-paper: SUBDIR := misc tfstar-no_nested_borrows tfstar-paper: tlean-no_nested_borrows: SUBDIR := @@ -123,7 +123,7 @@ tlean-paper: SUBDIR := thol4-no_nested_borrows: SUBDIR := misc-no_nested_borrows thol4-paper: SUBDIR := misc-paper -test-array: OPTIONS += -no-state +test-array: OPTIONS += test-array: SUBDIR := array tfstar-array: OPTIONS += -decreases-clauses -template-clauses tcoq-array: OPTIONS += -use-fuel @@ -131,7 +131,7 @@ tlean-array: SUBDIR := tlean-array: OPTIONS += thol4-array: OPTIONS += -test-traits: OPTIONS += -no-state +test-traits: OPTIONS += test-traits: SUBDIR := traits tfstar-traits: OPTIONS += -decreases-clauses -template-clauses tcoq-traits: OPTIONS += -use-fuel @@ -147,15 +147,15 @@ thol4-array: thol4-traits: echo "Ignoring the traits test for HOL4" -test-loops: OPTIONS += -no-state +test-loops: OPTIONS += test-loops: SUBDIR := misc -tfstar-loops: OPTIONS += -decreases-clauses -template-clauses -tcoq-loops: OPTIONS += -use-fuel -no-split-files +tfstar-loops: OPTIONS += -decreases-clauses -template-clauses -split-files +tcoq-loops: OPTIONS += -use-fuel tlean-loops: SUBDIR := thol4-loops: SUBDIR := misc-loops # TODO: reactivate -test-trans-units -test-hashmap: OPTIONS += -no-state +test-hashmap: OPTIONS += -split-files test-hashmap: SUBDIR := hashmap tfstar-hashmap: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap: OPTIONS += -use-fuel @@ -164,14 +164,14 @@ tlean-hashmap: OPTIONS += -no-gen-lib-entry # We add a custom import in the Hash thol4-hashmap: OPTIONS += # TODO: reactivate -test-trans-units -test-hashmap_main: OPTIONS += +test-hashmap_main: OPTIONS += -state -split-files test-hashmap_main: SUBDIR := hashmap_on_disk tfstar-hashmap_main: OPTIONS += -decreases-clauses -template-clauses tcoq-hashmap_main: OPTIONS += -use-fuel tlean-hashmap_main: SUBDIR := thol4-hashmap_main: OPTIONS += -testp-polonius_list: OPTIONS += -test-trans-units -no-split-files -no-state +testp-polonius_list: OPTIONS += -test-trans-units testp-polonius_list: SUBDIR := misc tfstarp-polonius_list: OPTIONS += tcoqp-polonius_list: OPTIONS += @@ -180,7 +180,7 @@ tleanp-polonius_list: OPTIONS += thol4p-polonius_list: SUBDIR := misc-polonius_list thol4p-polonius_list: OPTIONS += -test-constants: OPTIONS += -test-trans-units -no-split-files -no-state +test-constants: OPTIONS += -test-trans-units test-constants: SUBDIR := misc tfstar-constants: OPTIONS += tcoq-constants: OPTIONS += @@ -189,7 +189,7 @@ tlean-constants: OPTIONS += thol4-constants: SUBDIR := misc-constants thol4-constants: OPTIONS += -test-external: OPTIONS += -test-trans-units +test-external: OPTIONS += -test-trans-units -state -split-files test-external: SUBDIR := misc tfstar-external: OPTIONS += tcoq-external: OPTIONS += @@ -199,7 +199,7 @@ thol4-external: SUBDIR := misc-external thol4-external: OPTIONS += BETREE_FSTAR_OPTIONS = -decreases-clauses -template-clauses -testp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units +testp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units -state -split-files testp-betree_main: SUBDIR:=betree tfstarp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) tcoqp-betree_main: OPTIONS += -use-fuel @@ -211,7 +211,7 @@ thol4-betree_main: OPTIONS += # This generates very ugly code, but is good to test the translation. .PHONY: ctest-testp-betree_main ctest-testp-betree_main: testp-betree_main -ctest-testp-betree_main: OPTIONS += -backend fstar -test-trans-units +ctest-testp-betree_main: OPTIONS += -backend fstar -test-trans-units -state -split-files ctest-testp-betree_main: OPTIONS += $(BETREE_FSTAR_OPTIONS) ctest-testp-betree_main: BACKEND_SUBDIR := "fstar" ctest-testp-betree_main: SUBDIR:=betree_back_stateful 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 \ diff --git a/tests/fstar/misc/Loops.fst b/tests/fstar/misc/Loops.fst new file mode 100644 index 00000000..823acdd4 --- /dev/null +++ b/tests/fstar/misc/Loops.fst @@ -0,0 +1,784 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [loops] *) +module Loops +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [loops::sum]: decreases clause *) +unfold let sum_loop_decreases (max : u32) (i : u32) (s : u32) : nat = admit () + +(** [loops::sum]: loop 0: forward function *) +let rec sum_loop + (max : u32) (i : u32) (s : u32) : + Tot (result u32) (decreases (sum_loop_decreases max i s)) + = + if i < max + then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop max i0 s0 + else u32_mul s 2 + +(** [loops::sum]: forward function *) +let sum (max : u32) : result u32 = + sum_loop max 0 0 + +(** [loops::sum_with_mut_borrows]: decreases clause *) +unfold +let sum_with_mut_borrows_loop_decreases (max : u32) (mi : u32) (ms : u32) : nat + = + admit () + +(** [loops::sum_with_mut_borrows]: loop 0: forward function *) +let rec sum_with_mut_borrows_loop + (max : u32) (mi : u32) (ms : u32) : + Tot (result u32) (decreases (sum_with_mut_borrows_loop_decreases max mi ms)) + = + if mi < max + then + let* ms0 = u32_add ms mi in + let* mi0 = u32_add mi 1 in + sum_with_mut_borrows_loop max mi0 ms0 + else u32_mul ms 2 + +(** [loops::sum_with_mut_borrows]: forward function *) +let sum_with_mut_borrows (max : u32) : result u32 = + sum_with_mut_borrows_loop max 0 0 + +(** [loops::sum_with_shared_borrows]: decreases clause *) +unfold +let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : + nat = + admit () + +(** [loops::sum_with_shared_borrows]: loop 0: forward function *) +let rec sum_with_shared_borrows_loop + (max : u32) (i : u32) (s : u32) : + Tot (result u32) (decreases (sum_with_shared_borrows_loop_decreases max i s)) + = + if i < max + then + let* i0 = u32_add i 1 in + let* s0 = u32_add s i0 in + sum_with_shared_borrows_loop max i0 s0 + else u32_mul s 2 + +(** [loops::sum_with_shared_borrows]: forward function *) +let sum_with_shared_borrows (max : u32) : result u32 = + sum_with_shared_borrows_loop max 0 0 + +(** [loops::clear]: decreases clause *) +unfold +let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () + +(** [loops::clear]: loop 0: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let rec clear_loop + (v : alloc_vec_Vec u32) (i : usize) : + Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) + = + let i0 = alloc_vec_Vec_len u32 v in + if i < i0 + then + let* i1 = usize_add i 1 in + let* v0 = + alloc_vec_Vec_index_mut_back u32 usize + (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0 in + clear_loop v0 i1 + else Return v + +(** [loops::clear]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = + clear_loop v 0 + +(** [loops::List] *) +type list_t (t : Type0) = +| List_Cons : t -> list_t t -> list_t t +| List_Nil : list_t t + +(** [loops::list_mem]: decreases clause *) +unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () + +(** [loops::list_mem]: loop 0: forward function *) +let rec list_mem_loop + (x : u32) (ls : list_t u32) : + Tot (result bool) (decreases (list_mem_loop_decreases x ls)) + = + begin match ls with + | List_Cons y tl -> if y = x then Return true else list_mem_loop x tl + | List_Nil -> Return false + end + +(** [loops::list_mem]: forward function *) +let list_mem (x : u32) (ls : list_t u32) : result bool = + list_mem_loop x ls + +(** [loops::list_nth_mut_loop]: decreases clause *) +unfold +let list_nth_mut_loop_loop_decreases (t : Type0) (ls : list_t t) (i : u32) : + nat = + admit () + +(** [loops::list_nth_mut_loop]: loop 0: forward function *) +let rec list_nth_mut_loop_loop + (t : Type0) (ls : list_t t) (i : u32) : + Tot (result t) (decreases (list_nth_mut_loop_loop_decreases t ls i)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Return x + else let* i0 = u32_sub i 1 in list_nth_mut_loop_loop t tl i0 + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop]: forward function *) +let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result t = + list_nth_mut_loop_loop t ls i + +(** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) +let rec list_nth_mut_loop_loop_back + (t : Type0) (ls : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) (decreases (list_nth_mut_loop_loop_decreases t ls i)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Return (List_Cons ret tl) + else + let* i0 = u32_sub i 1 in + let* tl0 = list_nth_mut_loop_loop_back t tl i0 ret in + Return (List_Cons x tl0) + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop]: backward function 0 *) +let list_nth_mut_loop_back + (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = + list_nth_mut_loop_loop_back t ls i ret + +(** [loops::list_nth_shared_loop]: decreases clause *) +unfold +let list_nth_shared_loop_loop_decreases (t : Type0) (ls : list_t t) (i : u32) : + nat = + admit () + +(** [loops::list_nth_shared_loop]: loop 0: forward function *) +let rec list_nth_shared_loop_loop + (t : Type0) (ls : list_t t) (i : u32) : + Tot (result t) (decreases (list_nth_shared_loop_loop_decreases t ls i)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Return x + else let* i0 = u32_sub i 1 in list_nth_shared_loop_loop t tl i0 + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_loop]: forward function *) +let list_nth_shared_loop (t : Type0) (ls : list_t t) (i : u32) : result t = + list_nth_shared_loop_loop t ls i + +(** [loops::get_elem_mut]: decreases clause *) +unfold +let get_elem_mut_loop_decreases (x : usize) (ls : list_t usize) : nat = + admit () + +(** [loops::get_elem_mut]: loop 0: forward function *) +let rec get_elem_mut_loop + (x : usize) (ls : list_t usize) : + Tot (result usize) (decreases (get_elem_mut_loop_decreases x ls)) + = + begin match ls with + | List_Cons y tl -> if y = x then Return y else get_elem_mut_loop x tl + | List_Nil -> Fail Failure + end + +(** [loops::get_elem_mut]: forward function *) +let get_elem_mut + (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = + let* l = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + get_elem_mut_loop x l + +(** [loops::get_elem_mut]: loop 0: backward function 0 *) +let rec get_elem_mut_loop_back + (x : usize) (ls : list_t usize) (ret : usize) : + Tot (result (list_t usize)) (decreases (get_elem_mut_loop_decreases x ls)) + = + begin match ls with + | List_Cons y tl -> + if y = x + then Return (List_Cons ret tl) + else let* tl0 = get_elem_mut_loop_back x tl ret in Return (List_Cons y tl0) + | List_Nil -> Fail Failure + end + +(** [loops::get_elem_mut]: backward function 0 *) +let get_elem_mut_back + (slots : alloc_vec_Vec (list_t usize)) (x : usize) (ret : usize) : + result (alloc_vec_Vec (list_t usize)) + = + let* l = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + let* l0 = get_elem_mut_loop_back x l ret in + alloc_vec_Vec_index_mut_back (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) slots + 0 l0 + +(** [loops::get_elem_shared]: decreases clause *) +unfold +let get_elem_shared_loop_decreases (x : usize) (ls : list_t usize) : nat = + admit () + +(** [loops::get_elem_shared]: loop 0: forward function *) +let rec get_elem_shared_loop + (x : usize) (ls : list_t usize) : + Tot (result usize) (decreases (get_elem_shared_loop_decreases x ls)) + = + begin match ls with + | List_Cons y tl -> if y = x then Return y else get_elem_shared_loop x tl + | List_Nil -> Fail Failure + end + +(** [loops::get_elem_shared]: forward function *) +let get_elem_shared + (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = + let* l = + alloc_vec_Vec_index (list_t usize) usize + (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) + slots 0 in + get_elem_shared_loop x l + +(** [loops::id_mut]: forward function *) +let id_mut (t : Type0) (ls : list_t t) : result (list_t t) = + Return ls + +(** [loops::id_mut]: backward function 0 *) +let id_mut_back + (t : Type0) (ls : list_t t) (ret : list_t t) : result (list_t t) = + Return ret + +(** [loops::id_shared]: forward function *) +let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = + Return ls + +(** [loops::list_nth_mut_loop_with_id]: decreases clause *) +unfold +let list_nth_mut_loop_with_id_loop_decreases (t : Type0) (i : u32) + (ls : list_t t) : nat = + admit () + +(** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) +let rec list_nth_mut_loop_with_id_loop + (t : Type0) (i : u32) (ls : list_t t) : + Tot (result t) (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Return x + else let* i0 = u32_sub i 1 in list_nth_mut_loop_with_id_loop t i0 tl + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_with_id]: forward function *) +let list_nth_mut_loop_with_id + (t : Type0) (ls : list_t t) (i : u32) : result t = + let* ls0 = id_mut t ls in list_nth_mut_loop_with_id_loop t i ls0 + +(** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) +let rec list_nth_mut_loop_with_id_loop_back + (t : Type0) (i : u32) (ls : list_t t) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Return (List_Cons ret tl) + else + let* i0 = u32_sub i 1 in + let* tl0 = list_nth_mut_loop_with_id_loop_back t i0 tl ret in + Return (List_Cons x tl0) + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_with_id]: backward function 0 *) +let list_nth_mut_loop_with_id_back + (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = + let* ls0 = id_mut t ls in + let* l = list_nth_mut_loop_with_id_loop_back t i ls0 ret in + id_mut_back t ls l + +(** [loops::list_nth_shared_loop_with_id]: decreases clause *) +unfold +let list_nth_shared_loop_with_id_loop_decreases (t : Type0) (i : u32) + (ls : list_t t) : nat = + admit () + +(** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) +let rec list_nth_shared_loop_with_id_loop + (t : Type0) (i : u32) (ls : list_t t) : + Tot (result t) + (decreases (list_nth_shared_loop_with_id_loop_decreases t i ls)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Return x + else let* i0 = u32_sub i 1 in list_nth_shared_loop_with_id_loop t i0 tl + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_loop_with_id]: forward function *) +let list_nth_shared_loop_with_id + (t : Type0) (ls : list_t t) (i : u32) : result t = + let* ls0 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls0 + +(** [loops::list_nth_mut_loop_pair]: decreases clause *) +unfold +let list_nth_mut_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) + (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) +let rec list_nth_mut_loop_pair_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_pair]: forward function *) +let list_nth_mut_loop_pair + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_mut_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) +let rec list_nth_mut_loop_pair_loop_back'a + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (List_Cons ret tl0) + else + let* i0 = u32_sub i 1 in + let* tl00 = list_nth_mut_loop_pair_loop_back'a t tl0 tl1 i0 ret in + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_pair]: backward function 0 *) +let list_nth_mut_loop_pair_back'a + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + result (list_t t) + = + list_nth_mut_loop_pair_loop_back'a t ls0 ls1 i ret + +(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 *) +let rec list_nth_mut_loop_pair_loop_back'b + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (List_Cons ret tl1) + else + let* i0 = u32_sub i 1 in + let* tl10 = list_nth_mut_loop_pair_loop_back'b t tl0 tl1 i0 ret in + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_pair]: backward function 1 *) +let list_nth_mut_loop_pair_back'b + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + result (list_t t) + = + list_nth_mut_loop_pair_loop_back'b t ls0 ls1 i ret + +(** [loops::list_nth_shared_loop_pair]: decreases clause *) +unfold +let list_nth_shared_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) + (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) +let rec list_nth_shared_loop_pair_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_shared_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else let* i0 = u32_sub i 1 in list_nth_shared_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_loop_pair]: forward function *) +let list_nth_shared_loop_pair + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_shared_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_mut_loop_pair_merge]: decreases clause *) +unfold +let list_nth_mut_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) + (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) +let rec list_nth_mut_loop_pair_merge_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else + let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_pair_merge]: forward function *) +let list_nth_mut_loop_pair_merge + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_mut_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) +let rec list_nth_mut_loop_pair_merge_loop_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : (t & t)) : + Tot (result ((list_t t) & (list_t t))) + (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then let (x, x2) = ret in Return (List_Cons x tl0, List_Cons x2 tl1) + else + let* i0 = u32_sub i 1 in + let* (tl00, tl10) = + list_nth_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in + Return (List_Cons x0 tl00, List_Cons x1 tl10) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_loop_pair_merge]: backward function 0 *) +let list_nth_mut_loop_pair_merge_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : (t & t)) : + result ((list_t t) & (list_t t)) + = + list_nth_mut_loop_pair_merge_loop_back t ls0 ls1 i ret + +(** [loops::list_nth_shared_loop_pair_merge]: decreases clause *) +unfold +let list_nth_shared_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) + (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) +let rec list_nth_shared_loop_pair_merge_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else + let* i0 = u32_sub i 1 in + list_nth_shared_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_loop_pair_merge]: forward function *) +let list_nth_shared_loop_pair_merge + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_shared_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_mut_shared_loop_pair]: decreases clause *) +unfold +let list_nth_mut_shared_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) + (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) +let rec list_nth_mut_shared_loop_pair_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else + let* i0 = u32_sub i 1 in + list_nth_mut_shared_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_shared_loop_pair]: forward function *) +let list_nth_mut_shared_loop_pair + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_mut_shared_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) +let rec list_nth_mut_shared_loop_pair_loop_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (List_Cons ret tl0) + else + let* i0 = u32_sub i 1 in + let* tl00 = list_nth_mut_shared_loop_pair_loop_back t tl0 tl1 i0 ret in + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_shared_loop_pair]: backward function 0 *) +let list_nth_mut_shared_loop_pair_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + result (list_t t) + = + list_nth_mut_shared_loop_pair_loop_back t ls0 ls1 i ret + +(** [loops::list_nth_mut_shared_loop_pair_merge]: decreases clause *) +unfold +let list_nth_mut_shared_loop_pair_merge_loop_decreases (t : Type0) + (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) +let rec list_nth_mut_shared_loop_pair_merge_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else + let* i0 = u32_sub i 1 in + list_nth_mut_shared_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) +let list_nth_mut_shared_loop_pair_merge + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) +let rec list_nth_mut_shared_loop_pair_merge_loop_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (List_Cons ret tl0) + else + let* i0 = u32_sub i 1 in + let* tl00 = + list_nth_mut_shared_loop_pair_merge_loop_back t tl0 tl1 i0 ret in + Return (List_Cons x0 tl00) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 *) +let list_nth_mut_shared_loop_pair_merge_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + result (list_t t) + = + list_nth_mut_shared_loop_pair_merge_loop_back t ls0 ls1 i ret + +(** [loops::list_nth_shared_mut_loop_pair]: decreases clause *) +unfold +let list_nth_shared_mut_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) + (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) +let rec list_nth_shared_mut_loop_pair_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else + let* i0 = u32_sub i 1 in + list_nth_shared_mut_loop_pair_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_mut_loop_pair]: forward function *) +let list_nth_shared_mut_loop_pair + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_shared_mut_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) +let rec list_nth_shared_mut_loop_pair_loop_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (List_Cons ret tl1) + else + let* i0 = u32_sub i 1 in + let* tl10 = list_nth_shared_mut_loop_pair_loop_back t tl0 tl1 i0 ret in + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_mut_loop_pair]: backward function 1 *) +let list_nth_shared_mut_loop_pair_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + result (list_t t) + = + list_nth_shared_mut_loop_pair_loop_back t ls0 ls1 i ret + +(** [loops::list_nth_shared_mut_loop_pair_merge]: decreases clause *) +unfold +let list_nth_shared_mut_loop_pair_merge_loop_decreases (t : Type0) + (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = + admit () + +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) +let rec list_nth_shared_mut_loop_pair_merge_loop + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : + Tot (result (t & t)) + (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (x0, x1) + else + let* i0 = u32_sub i 1 in + list_nth_shared_mut_loop_pair_merge_loop t tl0 tl1 i0 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) +let list_nth_shared_mut_loop_pair_merge + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = + list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) +let rec list_nth_shared_mut_loop_pair_merge_loop_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + Tot (result (list_t t)) + (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) + = + begin match ls0 with + | List_Cons x0 tl0 -> + begin match ls1 with + | List_Cons x1 tl1 -> + if i = 0 + then Return (List_Cons ret tl1) + else + let* i0 = u32_sub i 1 in + let* tl10 = + list_nth_shared_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in + Return (List_Cons x1 tl10) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end + +(** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 *) +let list_nth_shared_mut_loop_pair_merge_back + (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : + result (list_t t) + = + list_nth_shared_mut_loop_pair_merge_loop_back t ls0 ls1 i ret + diff --git a/tests/lean/Array.lean b/tests/lean/Array.lean index 277b63d9..20f02e97 100644 --- a/tests/lean/Array.lean +++ b/tests/lean/Array.lean @@ -1 +1,435 @@ -import Array.Funs +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [array] +import Base +open Primitives + +namespace array + +/- [array::AB] -/ +inductive AB := +| A : AB +| B : AB + +/- [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def incr (x : U32) : Result U32 := + x + 1#u32 + +/- [array::array_to_shared_slice_]: forward function -/ +def array_to_shared_slice_ + (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s + +/- [array::array_to_mut_slice_]: forward function -/ +def array_to_mut_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := + Array.to_slice T 32#usize s + +/- [array::array_to_mut_slice_]: backward function 0 -/ +def array_to_mut_slice__back + (T : Type) (s : Array T 32#usize) (ret0 : Slice T) : + Result (Array T 32#usize) + := + Array.from_slice T 32#usize s ret0 + +/- [array::array_len]: forward function -/ +def array_len (T : Type) (s : Array T 32#usize) : Result Usize := + do + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 + Result.ret i + +/- [array::shared_array_len]: forward function -/ +def shared_array_len (T : Type) (s : Array T 32#usize) : Result Usize := + do + let s0 ← Array.to_slice T 32#usize s + let i := Slice.len T s0 + Result.ret i + +/- [array::shared_slice_len]: forward function -/ +def shared_slice_len (T : Type) (s : Slice T) : Result Usize := + let i := Slice.len T s + Result.ret i + +/- [array::index_array_shared]: forward function -/ +def index_array_shared + (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i + +/- [array::index_array_u32]: forward function -/ +def index_array_u32 (s : Array U32 32#usize) (i : Usize) : Result U32 := + Array.index_usize U32 32#usize s i + +/- [array::index_array_copy]: forward function -/ +def index_array_copy (x : Array U32 32#usize) : Result U32 := + Array.index_usize U32 32#usize x 0#usize + +/- [array::index_mut_array]: forward function -/ +def index_mut_array (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := + Array.index_usize T 32#usize s i + +/- [array::index_mut_array]: backward function 0 -/ +def index_mut_array_back + (T : Type) (s : Array T 32#usize) (i : Usize) (ret0 : T) : + Result (Array T 32#usize) + := + Array.update_usize T 32#usize s i ret0 + +/- [array::index_slice]: forward function -/ +def index_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i + +/- [array::index_mut_slice]: forward function -/ +def index_mut_slice (T : Type) (s : Slice T) (i : Usize) : Result T := + Slice.index_usize T s i + +/- [array::index_mut_slice]: backward function 0 -/ +def index_mut_slice_back + (T : Type) (s : Slice T) (i : Usize) (ret0 : T) : Result (Slice T) := + Slice.update_usize T s i ret0 + +/- [array::slice_subslice_shared_]: forward function -/ +def slice_subslice_shared_ + (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := + core.slice.index.Slice.index U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } + +/- [array::slice_subslice_mut_]: forward function -/ +def slice_subslice_mut_ + (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := + core.slice.index.Slice.index_mut U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } + +/- [array::slice_subslice_mut_]: backward function 0 -/ +def slice_subslice_mut__back + (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : + Result (Slice U32) + := + core.slice.index.Slice.index_mut_back U32 (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + { start := y, end_ := z } ret0 + +/- [array::array_to_slice_shared_]: forward function -/ +def array_to_slice_shared_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice U32 32#usize x + +/- [array::array_to_slice_mut_]: forward function -/ +def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := + Array.to_slice U32 32#usize x + +/- [array::array_to_slice_mut_]: backward function 0 -/ +def array_to_slice_mut__back + (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := + Array.from_slice U32 32#usize x ret0 + +/- [array::array_subslice_shared_]: forward function -/ +def array_subslice_shared_ + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } + +/- [array::array_subslice_mut_]: forward function -/ +def array_subslice_mut_ + (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } + +/- [array::array_subslice_mut_]: backward function 0 -/ +def array_subslice_mut__back + (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : + Result (Array U32 32#usize) + := + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } ret0 + +/- [array::index_slice_0]: forward function -/ +def index_slice_0 (T : Type) (s : Slice T) : Result T := + Slice.index_usize T s 0#usize + +/- [array::index_array_0]: forward function -/ +def index_array_0 (T : Type) (s : Array T 32#usize) : Result T := + Array.index_usize T 32#usize s 0#usize + +/- [array::index_index_array]: forward function -/ +def index_index_array + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : + Result U32 + := + do + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + Array.index_usize U32 32#usize a j + +/- [array::update_update_array]: forward function -/ +def update_update_array + (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : + Result Unit + := + do + let a ← Array.index_usize (Array U32 32#usize) 32#usize s i + let a0 ← Array.update_usize U32 32#usize a j 0#u32 + let _ ← Array.update_usize (Array U32 32#usize) 32#usize s i a0 + Result.ret () + +/- [array::array_local_deep_copy]: forward function -/ +def array_local_deep_copy (x : Array U32 32#usize) : Result Unit := + Result.ret () + +/- [array::take_array]: forward function -/ +def take_array (a : Array U32 2#usize) : Result Unit := + Result.ret () + +/- [array::take_array_borrow]: forward function -/ +def take_array_borrow (a : Array U32 2#usize) : Result Unit := + Result.ret () + +/- [array::take_slice]: forward function -/ +def take_slice (s : Slice U32) : Result Unit := + Result.ret () + +/- [array::take_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def take_mut_slice (s : Slice U32) : Result (Slice U32) := + Result.ret s + +/- [array::take_all]: forward function -/ +def take_all : Result Unit := + do + let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let _ ← take_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let _ ← take_slice s + let s0 ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s1 ← take_mut_slice s0 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Result.ret () + +/- [array::index_array]: forward function -/ +def index_array (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::index_array_borrow]: forward function -/ +def index_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::index_slice_u32_0]: forward function -/ +def index_slice_u32_0 (x : Slice U32) : Result U32 := + Slice.index_usize U32 x 0#usize + +/- [array::index_mut_slice_u32_0]: forward function -/ +def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := + Slice.index_usize U32 x 0#usize + +/- [array::index_mut_slice_u32_0]: backward function 0 -/ +def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := + do + let _ ← Slice.index_usize U32 x 0#usize + Result.ret x + +/- [array::index_all]: forward function -/ +def index_all : Result U32 := + do + let i ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i0 ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i1 ← i + i0 + let i2 ← index_array_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i3 ← i1 + i2 + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i4 ← index_slice_u32_0 s + let i5 ← i3 + i4 + let s0 ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let i6 ← index_mut_slice_u32_0 s0 + let i7 ← i5 + i6 + let s1 ← index_mut_slice_u32_0_back s0 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + Result.ret i7 + +/- [array::update_array]: forward function -/ +def update_array (x : Array U32 2#usize) : Result Unit := + do + let _ ← Array.update_usize U32 2#usize x 0#usize 1#u32 + Result.ret () + +/- [array::update_array_mut_borrow]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def update_array_mut_borrow + (x : Array U32 2#usize) : Result (Array U32 2#usize) := + Array.update_usize U32 2#usize x 0#usize 1#u32 + +/- [array::update_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def update_mut_slice (x : Slice U32) : Result (Slice U32) := + Slice.update_usize U32 x 0#usize 1#u32 + +/- [array::update_all]: forward function -/ +def update_all : Result Unit := + do + let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let x ← update_array_mut_borrow (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s ← Array.to_slice U32 2#usize x + let s0 ← update_mut_slice s + let _ ← Array.from_slice U32 2#usize x s0 + Result.ret () + +/- [array::range_all]: forward function -/ +def range_all : Result Unit := + do + let s ← + core.array.Array.index_mut U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } + let s0 ← update_mut_slice s + let _ ← + core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 4#usize + (core.slice.index.Slice.coreopsindexIndexMutInst U32 + (core.ops.range.Range Usize) + (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) + { start := 1#usize, end_ := 3#usize } s0 + Result.ret () + +/- [array::deref_array_borrow]: forward function -/ +def deref_array_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::deref_array_mut_borrow]: forward function -/ +def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := + Array.index_usize U32 2#usize x 0#usize + +/- [array::deref_array_mut_borrow]: backward function 0 -/ +def deref_array_mut_borrow_back + (x : Array U32 2#usize) : Result (Array U32 2#usize) := + do + let _ ← Array.index_usize U32 2#usize x 0#usize + Result.ret x + +/- [array::take_array_t]: forward function -/ +def take_array_t (a : Array AB 2#usize) : Result Unit := + Result.ret () + +/- [array::non_copyable_array]: forward function -/ +def non_copyable_array : Result Unit := + do + let _ ← take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) + Result.ret () + +/- [array::sum]: loop 0: forward function -/ +divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := + let i0 := Slice.len U32 s + if i < i0 + then + do + let i1 ← Slice.index_usize U32 s i + let sum1 ← sum0 + i1 + let i2 ← i + 1#usize + sum_loop s sum1 i2 + else Result.ret sum0 + +/- [array::sum]: forward function -/ +def sum (s : Slice U32) : Result U32 := + sum_loop s 0#u32 0#usize + +/- [array::sum2]: loop 0: forward function -/ +divergent def sum2_loop + (s : Slice U32) (s2 : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := + let i0 := Slice.len U32 s + if i < i0 + then + do + let i1 ← Slice.index_usize U32 s i + let i2 ← Slice.index_usize U32 s2 i + let i3 ← i1 + i2 + let sum1 ← sum0 + i3 + let i4 ← i + 1#usize + sum2_loop s s2 sum1 i4 + else Result.ret sum0 + +/- [array::sum2]: forward function -/ +def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := + let i := Slice.len U32 s + let i0 := Slice.len U32 s2 + if not (i = i0) + then Result.fail Error.panic + else sum2_loop s s2 0#u32 0#usize + +/- [array::f0]: forward function -/ +def f0 : Result Unit := + do + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← Slice.update_usize U32 s 0#usize 1#u32 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 + Result.ret () + +/- [array::f1]: forward function -/ +def f1 : Result Unit := + do + let _ ← + Array.update_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize 1#u32 + Result.ret () + +/- [array::f2]: forward function -/ +def f2 (i : U32) : Result Unit := + Result.ret () + +/- [array::f4]: forward function -/ +def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := + core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize + (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range + Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + { start := y, end_ := z } + +/- [array::f3]: forward function -/ +def f3 : Result U32 := + do + let i ← + Array.index_usize U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + 0#usize + let _ ← f2 i + let b := Array.repeat U32 32#usize 0#u32 + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) + let s0 ← f4 b 16#usize 18#usize + sum2 s s0 + +/- [array::SZ] -/ +def sz_body : Result Usize := Result.ret 32#usize +def sz_c : Usize := eval_global sz_body (by simp) + +/- [array::f5]: forward function -/ +def f5 (x : Array U32 32#usize) : Result U32 := + Array.index_usize U32 32#usize x 0#usize + +/- [array::ite]: forward function -/ +def ite : Result Unit := + do + let s ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s0 ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + let s1 ← index_mut_slice_u32_0_back s0 + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 + let s2 ← index_mut_slice_u32_0_back s + let _ ← + Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s2 + Result.ret () + +end array diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index 60c73776..c6360338 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -1 +1,629 @@ -import Loops.Funs +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [loops] +import Base +open Primitives + +namespace loops + +/- [loops::sum]: loop 0: forward function -/ +divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := + if i < max + then do + let s0 ← s + i + let i0 ← i + 1#u32 + sum_loop max i0 s0 + else s * 2#u32 + +/- [loops::sum]: forward function -/ +def sum (max : U32) : Result U32 := + sum_loop max 0#u32 0#u32 + +/- [loops::sum_with_mut_borrows]: loop 0: forward function -/ +divergent def sum_with_mut_borrows_loop + (max : U32) (mi : U32) (ms : U32) : Result U32 := + if mi < max + then + do + let ms0 ← ms + mi + let mi0 ← mi + 1#u32 + sum_with_mut_borrows_loop max mi0 ms0 + else ms * 2#u32 + +/- [loops::sum_with_mut_borrows]: forward function -/ +def sum_with_mut_borrows (max : U32) : Result U32 := + sum_with_mut_borrows_loop max 0#u32 0#u32 + +/- [loops::sum_with_shared_borrows]: loop 0: forward function -/ +divergent def sum_with_shared_borrows_loop + (max : U32) (i : U32) (s : U32) : Result U32 := + if i < max + then + do + let i0 ← i + 1#u32 + let s0 ← s + i0 + sum_with_shared_borrows_loop max i0 s0 + else s * 2#u32 + +/- [loops::sum_with_shared_borrows]: forward function -/ +def sum_with_shared_borrows (max : U32) : Result U32 := + sum_with_shared_borrows_loop max 0#u32 0#u32 + +/- [loops::clear]: loop 0: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +divergent def clear_loop + (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := + let i0 := alloc.vec.Vec.len U32 v + if i < i0 + then + do + let i1 ← i + 1#usize + let v0 ← + alloc.vec.Vec.index_mut_back U32 Usize + (core.slice.index.usize.coresliceindexSliceIndexInst U32) v i 0#u32 + clear_loop v0 i1 + else Result.ret v + +/- [loops::clear]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := + clear_loop v 0#usize + +/- [loops::List] -/ +inductive List (T : Type) := +| Cons : T → List T → List T +| Nil : List T + +/- [loops::list_mem]: loop 0: forward function -/ +divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := + match ls with + | List.Cons y tl => if y = x + then Result.ret true + else list_mem_loop x tl + | List.Nil => Result.ret false + +/- [loops::list_mem]: forward function -/ +def list_mem (x : U32) (ls : List U32) : Result Bool := + list_mem_loop x ls + +/- [loops::list_nth_mut_loop]: loop 0: forward function -/ +divergent def list_nth_mut_loop_loop + (T : Type) (ls : List T) (i : U32) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_loop T tl i0 + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop]: forward function -/ +def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result T := + list_nth_mut_loop_loop T ls i + +/- [loops::list_nth_mut_loop]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_loop_back + (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl) + else + do + let i0 ← i - 1#u32 + let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret0 + Result.ret (List.Cons x tl0) + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop]: backward function 0 -/ +def list_nth_mut_loop_back + (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + list_nth_mut_loop_loop_back T ls i ret0 + +/- [loops::list_nth_shared_loop]: loop 0: forward function -/ +divergent def list_nth_shared_loop_loop + (T : Type) (ls : List T) (i : U32) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_loop T tl i0 + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop]: forward function -/ +def list_nth_shared_loop (T : Type) (ls : List T) (i : U32) : Result T := + list_nth_shared_loop_loop T ls i + +/- [loops::get_elem_mut]: loop 0: forward function -/ +divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := + match ls with + | List.Cons y tl => if y = x + then Result.ret y + else get_elem_mut_loop x tl + | List.Nil => Result.fail Error.panic + +/- [loops::get_elem_mut]: forward function -/ +def get_elem_mut + (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := + do + let l ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize + get_elem_mut_loop x l + +/- [loops::get_elem_mut]: loop 0: backward function 0 -/ +divergent def get_elem_mut_loop_back + (x : Usize) (ls : List Usize) (ret0 : Usize) : Result (List Usize) := + match ls with + | List.Cons y tl => + if y = x + then Result.ret (List.Cons ret0 tl) + else + do + let tl0 ← get_elem_mut_loop_back x tl ret0 + Result.ret (List.Cons y tl0) + | List.Nil => Result.fail Error.panic + +/- [loops::get_elem_mut]: backward function 0 -/ +def get_elem_mut_back + (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret0 : Usize) : + Result (alloc.vec.Vec (List Usize)) + := + do + let l ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize + let l0 ← get_elem_mut_loop_back x l ret0 + alloc.vec.Vec.index_mut_back (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) slots + 0#usize l0 + +/- [loops::get_elem_shared]: loop 0: forward function -/ +divergent def get_elem_shared_loop + (x : Usize) (ls : List Usize) : Result Usize := + match ls with + | List.Cons y tl => if y = x + then Result.ret y + else get_elem_shared_loop x tl + | List.Nil => Result.fail Error.panic + +/- [loops::get_elem_shared]: forward function -/ +def get_elem_shared + (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := + do + let l ← + alloc.vec.Vec.index (List Usize) Usize + (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) + slots 0#usize + get_elem_shared_loop x l + +/- [loops::id_mut]: forward function -/ +def id_mut (T : Type) (ls : List T) : Result (List T) := + Result.ret ls + +/- [loops::id_mut]: backward function 0 -/ +def id_mut_back (T : Type) (ls : List T) (ret0 : List T) : Result (List T) := + Result.ret ret0 + +/- [loops::id_shared]: forward function -/ +def id_shared (T : Type) (ls : List T) : Result (List T) := + Result.ret ls + +/- [loops::list_nth_mut_loop_with_id]: loop 0: forward function -/ +divergent def list_nth_mut_loop_with_id_loop + (T : Type) (i : U32) (ls : List T) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_with_id_loop T i0 tl + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_with_id]: forward function -/ +def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := + do + let ls0 ← id_mut T ls + list_nth_mut_loop_with_id_loop T i ls0 + +/- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_with_id_loop_back + (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl) + else + do + let i0 ← i - 1#u32 + let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret0 + Result.ret (List.Cons x tl0) + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_with_id]: backward function 0 -/ +def list_nth_mut_loop_with_id_back + (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + do + let ls0 ← id_mut T ls + let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret0 + id_mut_back T ls l + +/- [loops::list_nth_shared_loop_with_id]: loop 0: forward function -/ +divergent def list_nth_shared_loop_with_id_loop + (T : Type) (i : U32) (ls : List T) : Result T := + match ls with + | List.Cons x tl => + if i = 0#u32 + then Result.ret x + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_with_id_loop T i0 tl + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop_with_id]: forward function -/ +def list_nth_shared_loop_with_id + (T : Type) (ls : List T) (i : U32) : Result T := + do + let ls0 ← id_shared T ls + list_nth_shared_loop_with_id_loop T i ls0 + +/- [loops::list_nth_mut_loop_pair]: loop 0: forward function -/ +divergent def list_nth_mut_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else do + let i0 ← i - 1#u32 + list_nth_mut_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair]: forward function -/ +def list_nth_mut_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_pair_loop_back'a + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl0) + else + do + let i0 ← i - 1#u32 + let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair]: backward function 0 -/ +def list_nth_mut_loop_pair_back'a + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret0 + +/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 -/ +divergent def list_nth_mut_loop_pair_loop_back'b + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl1) + else + do + let i0 ← i - 1#u32 + let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret0 + Result.ret (List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair]: backward function 1 -/ +def list_nth_mut_loop_pair_back'b + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_loop_pair]: loop 0: forward function -/ +divergent def list_nth_shared_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else do + let i0 ← i - 1#u32 + list_nth_shared_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop_pair]: forward function -/ +def list_nth_shared_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_mut_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_mut_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair_merge]: forward function -/ +def list_nth_mut_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 -/ +divergent def list_nth_mut_loop_pair_merge_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : + Result ((List T) × (List T)) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then let (t, t0) := ret0 + Result.ret (List.Cons t tl0, List.Cons t0 tl1) + else + do + let i0 ← i - 1#u32 + let (tl00, tl10) ← + list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00, List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_loop_pair_merge]: backward function 0 -/ +def list_nth_mut_loop_pair_merge_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : + Result ((List T) × (List T)) + := + list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_shared_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_shared_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_loop_pair_merge]: forward function -/ +def list_nth_shared_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function -/ +divergent def list_nth_mut_shared_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_mut_shared_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair]: forward function -/ +def list_nth_mut_shared_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_shared_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 -/ +divergent def list_nth_mut_shared_loop_pair_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl0) + else + do + let i0 ← i - 1#u32 + let tl00 ← + list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair]: backward function 0 -/ +def list_nth_mut_shared_loop_pair_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_mut_shared_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair_merge]: forward function -/ +def list_nth_mut_shared_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 -/ +divergent def list_nth_mut_shared_loop_pair_merge_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl0) + else + do + let i0 ← i - 1#u32 + let tl00 ← + list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x0 tl00) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 -/ +def list_nth_mut_shared_loop_pair_merge_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function -/ +divergent def list_nth_shared_mut_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_shared_mut_loop_pair_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair]: forward function -/ +def list_nth_shared_mut_loop_pair + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_mut_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 -/ +divergent def list_nth_shared_mut_loop_pair_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl1) + else + do + let i0 ← i - 1#u32 + let tl10 ← + list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair]: backward function 1 -/ +def list_nth_shared_mut_loop_pair_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret0 + +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function -/ +divergent def list_nth_shared_mut_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (x0, x1) + else + do + let i0 ← i - 1#u32 + list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i0 + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair_merge]: forward function -/ +def list_nth_shared_mut_loop_pair_merge + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := + list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 -/ +divergent def list_nth_shared_mut_loop_pair_merge_loop_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ret (List.Cons ret0 tl1) + else + do + let i0 ← i - 1#u32 + let tl10 ← + list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + Result.ret (List.Cons x1 tl10) + | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail Error.panic + +/- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 -/ +def list_nth_shared_mut_loop_pair_merge_back + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + Result (List T) + := + list_nth_shared_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 + +end loops diff --git a/tests/lean/Loops/Funs.lean b/tests/lean/Loops/Funs.lean deleted file mode 100644 index f9c7569e..00000000 --- a/tests/lean/Loops/Funs.lean +++ /dev/null @@ -1,625 +0,0 @@ --- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS --- [loops]: function definitions -import Base -import Loops.Types -open Primitives - -namespace loops - -/- [loops::sum]: loop 0: forward function -/ -divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := - if i < max - then do - let s0 ← s + i - let i0 ← i + 1#u32 - sum_loop max i0 s0 - else s * 2#u32 - -/- [loops::sum]: forward function -/ -def sum (max : U32) : Result U32 := - sum_loop max 0#u32 0#u32 - -/- [loops::sum_with_mut_borrows]: loop 0: forward function -/ -divergent def sum_with_mut_borrows_loop - (max : U32) (mi : U32) (ms : U32) : Result U32 := - if mi < max - then - do - let ms0 ← ms + mi - let mi0 ← mi + 1#u32 - sum_with_mut_borrows_loop max mi0 ms0 - else ms * 2#u32 - -/- [loops::sum_with_mut_borrows]: forward function -/ -def sum_with_mut_borrows (max : U32) : Result U32 := - sum_with_mut_borrows_loop max 0#u32 0#u32 - -/- [loops::sum_with_shared_borrows]: loop 0: forward function -/ -divergent def sum_with_shared_borrows_loop - (max : U32) (i : U32) (s : U32) : Result U32 := - if i < max - then - do - let i0 ← i + 1#u32 - let s0 ← s + i0 - sum_with_shared_borrows_loop max i0 s0 - else s * 2#u32 - -/- [loops::sum_with_shared_borrows]: forward function -/ -def sum_with_shared_borrows (max : U32) : Result U32 := - sum_with_shared_borrows_loop max 0#u32 0#u32 - -/- [loops::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ -divergent def clear_loop - (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := - let i0 := alloc.vec.Vec.len U32 v - if i < i0 - then - do - let i1 ← i + 1#usize - let v0 ← - alloc.vec.Vec.index_mut_back U32 Usize - (core.slice.index.usize.coresliceindexSliceIndexInst U32) v i 0#u32 - clear_loop v0 i1 - else Result.ret v - -/- [loops::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ -def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := - clear_loop v 0#usize - -/- [loops::list_mem]: loop 0: forward function -/ -divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := - match ls with - | List.Cons y tl => if y = x - then Result.ret true - else list_mem_loop x tl - | List.Nil => Result.ret false - -/- [loops::list_mem]: forward function -/ -def list_mem (x : U32) (ls : List U32) : Result Bool := - list_mem_loop x ls - -/- [loops::list_nth_mut_loop]: loop 0: forward function -/ -divergent def list_nth_mut_loop_loop - (T : Type) (ls : List T) (i : U32) : Result T := - match ls with - | List.Cons x tl => - if i = 0#u32 - then Result.ret x - else do - let i0 ← i - 1#u32 - list_nth_mut_loop_loop T tl i0 - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop]: forward function -/ -def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result T := - list_nth_mut_loop_loop T ls i - -/- [loops::list_nth_mut_loop]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_loop_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - match ls with - | List.Cons x tl => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl) - else - do - let i0 ← i - 1#u32 - let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret0 - Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop]: backward function 0 -/ -def list_nth_mut_loop_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - list_nth_mut_loop_loop_back T ls i ret0 - -/- [loops::list_nth_shared_loop]: loop 0: forward function -/ -divergent def list_nth_shared_loop_loop - (T : Type) (ls : List T) (i : U32) : Result T := - match ls with - | List.Cons x tl => - if i = 0#u32 - then Result.ret x - else do - let i0 ← i - 1#u32 - list_nth_shared_loop_loop T tl i0 - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop]: forward function -/ -def list_nth_shared_loop (T : Type) (ls : List T) (i : U32) : Result T := - list_nth_shared_loop_loop T ls i - -/- [loops::get_elem_mut]: loop 0: forward function -/ -divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := - match ls with - | List.Cons y tl => if y = x - then Result.ret y - else get_elem_mut_loop x tl - | List.Nil => Result.fail Error.panic - -/- [loops::get_elem_mut]: forward function -/ -def get_elem_mut - (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := - do - let l ← - alloc.vec.Vec.index_mut (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) - slots 0#usize - get_elem_mut_loop x l - -/- [loops::get_elem_mut]: loop 0: backward function 0 -/ -divergent def get_elem_mut_loop_back - (x : Usize) (ls : List Usize) (ret0 : Usize) : Result (List Usize) := - match ls with - | List.Cons y tl => - if y = x - then Result.ret (List.Cons ret0 tl) - else - do - let tl0 ← get_elem_mut_loop_back x tl ret0 - Result.ret (List.Cons y tl0) - | List.Nil => Result.fail Error.panic - -/- [loops::get_elem_mut]: backward function 0 -/ -def get_elem_mut_back - (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret0 : Usize) : - Result (alloc.vec.Vec (List Usize)) - := - do - let l ← - alloc.vec.Vec.index_mut (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) - slots 0#usize - let l0 ← get_elem_mut_loop_back x l ret0 - alloc.vec.Vec.index_mut_back (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) slots - 0#usize l0 - -/- [loops::get_elem_shared]: loop 0: forward function -/ -divergent def get_elem_shared_loop - (x : Usize) (ls : List Usize) : Result Usize := - match ls with - | List.Cons y tl => if y = x - then Result.ret y - else get_elem_shared_loop x tl - | List.Nil => Result.fail Error.panic - -/- [loops::get_elem_shared]: forward function -/ -def get_elem_shared - (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := - do - let l ← - alloc.vec.Vec.index (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) - slots 0#usize - get_elem_shared_loop x l - -/- [loops::id_mut]: forward function -/ -def id_mut (T : Type) (ls : List T) : Result (List T) := - Result.ret ls - -/- [loops::id_mut]: backward function 0 -/ -def id_mut_back (T : Type) (ls : List T) (ret0 : List T) : Result (List T) := - Result.ret ret0 - -/- [loops::id_shared]: forward function -/ -def id_shared (T : Type) (ls : List T) : Result (List T) := - Result.ret ls - -/- [loops::list_nth_mut_loop_with_id]: loop 0: forward function -/ -divergent def list_nth_mut_loop_with_id_loop - (T : Type) (i : U32) (ls : List T) : Result T := - match ls with - | List.Cons x tl => - if i = 0#u32 - then Result.ret x - else do - let i0 ← i - 1#u32 - list_nth_mut_loop_with_id_loop T i0 tl - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_with_id]: forward function -/ -def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := - do - let ls0 ← id_mut T ls - list_nth_mut_loop_with_id_loop T i ls0 - -/- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_with_id_loop_back - (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := - match ls with - | List.Cons x tl => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl) - else - do - let i0 ← i - 1#u32 - let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret0 - Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_with_id]: backward function 0 -/ -def list_nth_mut_loop_with_id_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - do - let ls0 ← id_mut T ls - let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret0 - id_mut_back T ls l - -/- [loops::list_nth_shared_loop_with_id]: loop 0: forward function -/ -divergent def list_nth_shared_loop_with_id_loop - (T : Type) (i : U32) (ls : List T) : Result T := - match ls with - | List.Cons x tl => - if i = 0#u32 - then Result.ret x - else do - let i0 ← i - 1#u32 - list_nth_shared_loop_with_id_loop T i0 tl - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop_with_id]: forward function -/ -def list_nth_shared_loop_with_id - (T : Type) (ls : List T) (i : U32) : Result T := - do - let ls0 ← id_shared T ls - list_nth_shared_loop_with_id_loop T i ls0 - -/- [loops::list_nth_mut_loop_pair]: loop 0: forward function -/ -divergent def list_nth_mut_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else do - let i0 ← i - 1#u32 - list_nth_mut_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair]: forward function -/ -def list_nth_mut_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_pair_loop_back'a - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl0) - else - do - let i0 ← i - 1#u32 - let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair]: backward function 0 -/ -def list_nth_mut_loop_pair_back'a - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret0 - -/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 -/ -divergent def list_nth_mut_loop_pair_loop_back'b - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl1) - else - do - let i0 ← i - 1#u32 - let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret0 - Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair]: backward function 1 -/ -def list_nth_mut_loop_pair_back'b - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_loop_pair]: loop 0: forward function -/ -divergent def list_nth_shared_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else do - let i0 ← i - 1#u32 - list_nth_shared_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop_pair]: forward function -/ -def list_nth_shared_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_mut_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else - do - let i0 ← i - 1#u32 - list_nth_mut_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair_merge]: forward function -/ -def list_nth_mut_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 -/ -divergent def list_nth_mut_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : - Result ((List T) × (List T)) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then let (t, t0) := ret0 - Result.ret (List.Cons t tl0, List.Cons t0 tl1) - else - do - let i0 ← i - 1#u32 - let (tl00, tl10) ← - list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00, List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_loop_pair_merge]: backward function 0 -/ -def list_nth_mut_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : - Result ((List T) × (List T)) - := - list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_shared_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else - do - let i0 ← i - 1#u32 - list_nth_shared_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_loop_pair_merge]: forward function -/ -def list_nth_shared_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function -/ -divergent def list_nth_mut_shared_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else - do - let i0 ← i - 1#u32 - list_nth_mut_shared_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair]: forward function -/ -def list_nth_mut_shared_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_shared_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 -/ -divergent def list_nth_mut_shared_loop_pair_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl0) - else - do - let i0 ← i - 1#u32 - let tl00 ← - list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair]: backward function 0 -/ -def list_nth_mut_shared_loop_pair_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_mut_shared_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else - do - let i0 ← i - 1#u32 - list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair_merge]: forward function -/ -def list_nth_mut_shared_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 -/ -divergent def list_nth_mut_shared_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl0) - else - do - let i0 ← i - 1#u32 - let tl00 ← - list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 -/ -def list_nth_mut_shared_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function -/ -divergent def list_nth_shared_mut_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else - do - let i0 ← i - 1#u32 - list_nth_shared_mut_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair]: forward function -/ -def list_nth_shared_mut_loop_pair - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_mut_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 -/ -divergent def list_nth_shared_mut_loop_pair_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl1) - else - do - let i0 ← i - 1#u32 - let tl10 ← - list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair]: backward function 1 -/ -def list_nth_shared_mut_loop_pair_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret0 - -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function -/ -divergent def list_nth_shared_mut_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (x0, x1) - else - do - let i0 ← i - 1#u32 - list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair_merge]: forward function -/ -def list_nth_shared_mut_loop_pair_merge - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 -/ -divergent def list_nth_shared_mut_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ret (List.Cons ret0 tl1) - else - do - let i0 ← i - 1#u32 - let tl10 ← - list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 - Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic - -/- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 -/ -def list_nth_shared_mut_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : - Result (List T) - := - list_nth_shared_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 - -end loops diff --git a/tests/lean/Loops/Types.lean b/tests/lean/Loops/Types.lean deleted file mode 100644 index 018af901..00000000 --- a/tests/lean/Loops/Types.lean +++ /dev/null @@ -1,13 +0,0 @@ --- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS --- [loops]: type definitions -import Base -open Primitives - -namespace loops - -/- [loops::List] -/ -inductive List (T : Type) := -| Cons : T → List T → List T -| Nil : List T - -end loops diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index 5e812e95..94ae0bb0 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -1 +1,410 @@ -import Traits.Funs +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [traits] +import Base +open Primitives + +namespace traits + +/- Trait declaration: [traits::BoolTrait] -/ +structure BoolTrait (Self : Type) where + get_bool : Self → Result Bool + +/- [traits::Bool::{0}::get_bool]: forward function -/ +def Bool.get_bool (self : Bool) : Result Bool := + Result.ret self + +/- Trait implementation: [traits::Bool::{0}] -/ +def Bool.BoolTraitInst : BoolTrait Bool := { + get_bool := Bool.get_bool +} + +/- [traits::BoolTrait::ret_true]: forward function -/ +def BoolTrait.ret_true + {Self : Type} (self_clause : BoolTrait Self) (self : Self) : Result Bool := + Result.ret true + +/- [traits::test_bool_trait_bool]: forward function -/ +def test_bool_trait_bool (x : Bool) : Result Bool := + do + let b ← Bool.get_bool x + if b + then BoolTrait.ret_true Bool.BoolTraitInst x + else Result.ret false + +/- [traits::Option::{1}::get_bool]: forward function -/ +def Option.get_bool (T : Type) (self : Option T) : Result Bool := + match self with + | none => Result.ret false + | some t => Result.ret true + +/- Trait implementation: [traits::Option::{1}] -/ +def Option.BoolTraitInst (T : Type) : BoolTrait (Option T) := { + get_bool := Option.get_bool T +} + +/- [traits::test_bool_trait_option]: forward function -/ +def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := + do + let b ← Option.get_bool T x + if b + then BoolTrait.ret_true (Option.BoolTraitInst T) x + else Result.ret false + +/- [traits::test_bool_trait]: forward function -/ +def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := + inst.get_bool x + +/- Trait declaration: [traits::ToU64] -/ +structure ToU64 (Self : Type) where + to_u64 : Self → Result U64 + +/- [traits::u64::{2}::to_u64]: forward function -/ +def u64.to_u64 (self : U64) : Result U64 := + Result.ret self + +/- Trait implementation: [traits::u64::{2}] -/ +def u64.ToU64Inst : ToU64 U64 := { + to_u64 := u64.to_u64 +} + +/- [traits::Tuple2::{3}::to_u64]: forward function -/ +def Tuple2.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := + do + let (t, t0) := self + let i ← inst.to_u64 t + let i0 ← inst.to_u64 t0 + i + i0 + +/- Trait implementation: [traits::Tuple2::{3}] -/ +def Tuple2.ToU64Inst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { + to_u64 := Tuple2.to_u64 A inst +} + +/- [traits::f]: forward function -/ +def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := + Tuple2.to_u64 T inst x + +/- [traits::g]: forward function -/ +def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := + inst.to_u64 x + +/- [traits::h0]: forward function -/ +def h0 (x : U64) : Result U64 := + u64.to_u64 x + +/- [traits::Wrapper] -/ +structure Wrapper (T : Type) where + x : T + +/- [traits::Wrapper::{4}::to_u64]: forward function -/ +def Wrapper.to_u64 + (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := + inst.to_u64 self.x + +/- Trait implementation: [traits::Wrapper::{4}] -/ +def Wrapper.ToU64Inst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper T) := { + to_u64 := Wrapper.to_u64 T inst +} + +/- [traits::h1]: forward function -/ +def h1 (x : Wrapper U64) : Result U64 := + Wrapper.to_u64 U64 u64.ToU64Inst x + +/- [traits::h2]: forward function -/ +def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := + Wrapper.to_u64 T inst x + +/- Trait declaration: [traits::ToType] -/ +structure ToType (Self T : Type) where + to_type : Self → Result T + +/- [traits::u64::{5}::to_type]: forward function -/ +def u64.to_type (self : U64) : Result Bool := + Result.ret (self > 0#u64) + +/- Trait implementation: [traits::u64::{5}] -/ +def u64.ToTypeInst : ToType U64 Bool := { + to_type := u64.to_type +} + +/- Trait declaration: [traits::OfType] -/ +structure OfType (Self : Type) where + of_type : forall (T : Type) (inst : ToType T Self), T → Result Self + +/- [traits::h3]: forward function -/ +def h3 + (T1 T2 : Type) (inst : OfType T1) (inst0 : ToType T2 T1) (y : T2) : + Result T1 + := + inst.of_type T2 inst0 y + +/- Trait declaration: [traits::OfTypeBis] -/ +structure OfTypeBis (Self T : Type) where + parent_clause_0 : ToType T Self + of_type : T → Result Self + +/- [traits::h4]: forward function -/ +def h4 + (T1 T2 : Type) (inst : OfTypeBis T1 T2) (inst0 : ToType T2 T1) (y : T2) : + Result T1 + := + inst.of_type y + +/- [traits::TestType] -/ +structure TestType (T : Type) where + _0 : T + +/- [traits::TestType::{6}::test::TestType1] -/ +structure TestType.test.TestType1 where + _0 : U64 + +/- Trait declaration: [traits::TestType::{6}::test::TestTrait] -/ +structure TestType.test.TestTrait (Self : Type) where + test : Self → Result Bool + +/- [traits::TestType::{6}::test::TestType1::{0}::test]: forward function -/ +def TestType.test.TestType1.test + (self : TestType.test.TestType1) : Result Bool := + Result.ret (self._0 > 1#u64) + +/- Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] -/ +def TestType.test.TestType1.TestTypetestTestTraitInst : TestType.test.TestTrait + TestType.test.TestType1 := { + test := TestType.test.TestType1.test +} + +/- [traits::TestType::{6}::test]: forward function -/ +def TestType.test + (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := + do + let x0 ← inst.to_u64 x + if x0 > 0#u64 + then TestType.test.TestType1.test { _0 := 0#u64 } + else Result.ret false + +/- [traits::BoolWrapper] -/ +structure BoolWrapper where + _0 : Bool + +/- [traits::BoolWrapper::{7}::to_type]: forward function -/ +def BoolWrapper.to_type + (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := + inst.to_type self._0 + +/- Trait implementation: [traits::BoolWrapper::{7}] -/ +def BoolWrapper.ToTypeInst (T : Type) (inst : ToType Bool T) : ToType + BoolWrapper T := { + to_type := BoolWrapper.to_type T inst +} + +/- [traits::WithConstTy::LEN2] -/ +def with_const_ty_len2_body : Result Usize := Result.ret 32#usize +def with_const_ty_len2_c : Usize := + eval_global with_const_ty_len2_body (by simp) + +/- Trait declaration: [traits::WithConstTy] -/ +structure WithConstTy (Self : Type) (LEN : Usize) where + LEN1 : Usize + LEN2 : Usize + V : Type + W : Type + W_clause_0 : ToU64 W + f : W → Array U8 LEN → Result W + +/- [traits::Bool::{8}::LEN1] -/ +def bool_len1_body : Result Usize := Result.ret 12#usize +def bool_len1_c : Usize := eval_global bool_len1_body (by simp) + +/- [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) -/ +def Bool.f (i : U64) (a : Array U8 32#usize) : Result U64 := + Result.ret i + +/- Trait implementation: [traits::Bool::{8}] -/ +def Bool.WithConstTyInst : WithConstTy Bool 32#usize := { + LEN1 := bool_len1_c + LEN2 := with_const_ty_len2_c + V := U8 + W := U64 + W_clause_0 := u64.ToU64Inst + f := Bool.f +} + +/- [traits::use_with_const_ty1]: forward function -/ +def use_with_const_ty1 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) : Result Usize := + let i := inst.LEN1 + Result.ret i + +/- [traits::use_with_const_ty2]: forward function -/ +def use_with_const_ty2 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (w : inst.W) : + Result Unit + := + Result.ret () + +/- [traits::use_with_const_ty3]: forward function -/ +def use_with_const_ty3 + (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (x : inst.W) : + Result U64 + := + inst.W_clause_0.to_u64 x + +/- [traits::test_where1]: forward function -/ +def test_where1 (T : Type) (_x : T) : Result Unit := + Result.ret () + +/- [traits::test_where2]: forward function -/ +def test_where2 + (T : Type) (inst : WithConstTy T 32#usize) (_x : U32) : Result Unit := + Result.ret () + +/- [alloc::string::String] -/ +axiom alloc.string.String : Type + +/- Trait declaration: [traits::ParentTrait0] -/ +structure ParentTrait0 (Self : Type) where + W : Type + get_name : Self → Result alloc.string.String + get_w : Self → Result W + +/- Trait declaration: [traits::ParentTrait1] -/ +structure ParentTrait1 (Self : Type) where + +/- Trait declaration: [traits::ChildTrait] -/ +structure ChildTrait (Self : Type) where + parent_clause_0 : ParentTrait0 Self + parent_clause_1 : ParentTrait1 Self + +/- [traits::test_child_trait1]: forward function -/ +def test_child_trait1 + (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := + inst.parent_clause_0.get_name x + +/- [traits::test_child_trait2]: forward function -/ +def test_child_trait2 + (T : Type) (inst : ChildTrait T) (x : T) : Result inst.parent_clause_0.W := + inst.parent_clause_0.get_w x + +/- [traits::order1]: forward function -/ +def order1 + (T U : Type) (inst : ParentTrait0 T) (inst0 : ParentTrait0 U) : + Result Unit + := + Result.ret () + +/- Trait declaration: [traits::ChildTrait1] -/ +structure ChildTrait1 (Self : Type) where + parent_clause_0 : ParentTrait1 Self + +/- Trait implementation: [traits::usize::{9}] -/ +def usize.ParentTrait1Inst : ParentTrait1 Usize := { +} + +/- Trait implementation: [traits::usize::{10}] -/ +def usize.ChildTrait1Inst : ChildTrait1 Usize := { + parent_clause_0 := usize.ParentTrait1Inst +} + +/- Trait declaration: [traits::Iterator] -/ +structure Iterator (Self : Type) where + Item : Type + +/- Trait declaration: [traits::IntoIterator] -/ +structure IntoIterator (Self : Type) where + Item : Type + IntoIter : Type + IntoIter_clause_0 : Iterator IntoIter + into_iter : Self → Result IntoIter + +/- Trait declaration: [traits::FromResidual] -/ +structure FromResidual (Self T : Type) where + +/- Trait declaration: [traits::Try] -/ +structure Try (Self : Type) where + parent_clause_0 : FromResidual Self Residual + Residual : Type + +/- Trait declaration: [traits::CFnOnce] -/ +structure CFnOnce (Self Args : Type) where + Output : Type + call_once : Self → Args → Result Output + +/- Trait declaration: [traits::CFnMut] -/ +structure CFnMut (Self Args : Type) where + parent_clause_0 : CFnOnce Self Args + call_mut : Self → Args → Result parent_clause_0.Output + call_mut_back : Self → Args → parent_clause_0.Output → Result Self + +/- Trait declaration: [traits::CFn] -/ +structure CFn (Self Args : Type) where + parent_clause_0 : CFnMut Self Args + call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output + +/- Trait declaration: [core::ops::function::FnOnce] -/ +structure core.ops.function.FnOnce (Self Args : Type) where + Output : Type + call_once : Self → Args → Result Output + +/- Trait declaration: [core::ops::function::FnMut] -/ +structure core.ops.function.FnMut (Self Args : Type) where + parent_clause_0 : core.ops.function.FnOnce Self Args + call_mut : Self → Args → Result parent_clause_0.Output + call_mut_back : Self → Args → parent_clause_0.Output → Result Self + +/- Trait declaration: [core::ops::function::Fn] -/ +structure core.ops.function.Fn (Self Args : Type) where + parent_clause_0 : core.ops.function.FnMut Self Args + call : Self → Args → Result parent_clause_0.parent_clause_0.Output + +/- [traits::map_option]: forward function -/ +def map_option + (T F : Type) (inst : core.ops.function.Fn F T) (x : Option T) (f0 : F) : + Result (Option T) + := + match x with + | none => Result.ret none + | some x0 => do + let t ← inst.call f0 x0 + Result.ret (some t) + +/- Trait declaration: [traits::WithTarget] -/ +structure WithTarget (Self : Type) where + Target : Type + +/- Trait declaration: [traits::ParentTrait2] -/ +structure ParentTrait2 (Self : Type) where + U : Type + U_clause_0 : WithTarget U + +/- Trait declaration: [traits::ChildTrait2] -/ +structure ChildTrait2 (Self : Type) where + parent_clause_0 : ParentTrait2 Self + convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target + +/- Trait implementation: [traits::u32::{11}] -/ +def u32.WithTargetInst : WithTarget U32 := { + Target := U32 +} + +/- Trait implementation: [traits::u32::{12}] -/ +def u32.ParentTrait2Inst : ParentTrait2 U32 := { + U := U32 + U_clause_0 := u32.WithTargetInst +} + +/- [traits::u32::{13}::convert]: forward function -/ +def u32.convert (x : U32) : Result U32 := + Result.ret x + +/- Trait implementation: [traits::u32::{13}] -/ +def u32.ChildTrait2Inst : ChildTrait2 U32 := { + parent_clause_0 := u32.ParentTrait2Inst + convert := u32.convert +} + +/- [traits::incr_u32]: forward function -/ +def incr_u32 (x : U32) : Result U32 := + x + 1#u32 + +end traits diff --git a/tests/lean/Traits/Funs.lean b/tests/lean/Traits/Funs.lean deleted file mode 100644 index 8d423280..00000000 --- a/tests/lean/Traits/Funs.lean +++ /dev/null @@ -1,275 +0,0 @@ --- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS --- [traits]: function definitions -import Base -import Traits.Types -open Primitives - -namespace traits - -/- [traits::Bool::{0}::get_bool]: forward function -/ -def Bool.get_bool (self : Bool) : Result Bool := - Result.ret self - -/- Trait implementation: [traits::Bool::{0}] -/ -def Bool.BoolTraitInst : BoolTrait Bool := { - get_bool := Bool.get_bool -} - -/- [traits::BoolTrait::ret_true]: forward function -/ -def BoolTrait.ret_true - {Self : Type} (self_clause : BoolTrait Self) (self : Self) : Result Bool := - Result.ret true - -/- [traits::test_bool_trait_bool]: forward function -/ -def test_bool_trait_bool (x : Bool) : Result Bool := - do - let b ← Bool.get_bool x - if b - then BoolTrait.ret_true Bool.BoolTraitInst x - else Result.ret false - -/- [traits::Option::{1}::get_bool]: forward function -/ -def Option.get_bool (T : Type) (self : Option T) : Result Bool := - match self with - | none => Result.ret false - | some t => Result.ret true - -/- Trait implementation: [traits::Option::{1}] -/ -def Option.BoolTraitInst (T : Type) : BoolTrait (Option T) := { - get_bool := Option.get_bool T -} - -/- [traits::test_bool_trait_option]: forward function -/ -def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := - do - let b ← Option.get_bool T x - if b - then BoolTrait.ret_true (Option.BoolTraitInst T) x - else Result.ret false - -/- [traits::test_bool_trait]: forward function -/ -def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := - inst.get_bool x - -/- [traits::u64::{2}::to_u64]: forward function -/ -def u64.to_u64 (self : U64) : Result U64 := - Result.ret self - -/- Trait implementation: [traits::u64::{2}] -/ -def u64.ToU64Inst : ToU64 U64 := { - to_u64 := u64.to_u64 -} - -/- [traits::Tuple2::{3}::to_u64]: forward function -/ -def Tuple2.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := - do - let (t, t0) := self - let i ← inst.to_u64 t - let i0 ← inst.to_u64 t0 - i + i0 - -/- Trait implementation: [traits::Tuple2::{3}] -/ -def Tuple2.ToU64Inst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { - to_u64 := Tuple2.to_u64 A inst -} - -/- [traits::f]: forward function -/ -def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := - Tuple2.to_u64 T inst x - -/- [traits::g]: forward function -/ -def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := - inst.to_u64 x - -/- [traits::h0]: forward function -/ -def h0 (x : U64) : Result U64 := - u64.to_u64 x - -/- [traits::Wrapper::{4}::to_u64]: forward function -/ -def Wrapper.to_u64 - (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := - inst.to_u64 self.x - -/- Trait implementation: [traits::Wrapper::{4}] -/ -def Wrapper.ToU64Inst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper T) := { - to_u64 := Wrapper.to_u64 T inst -} - -/- [traits::h1]: forward function -/ -def h1 (x : Wrapper U64) : Result U64 := - Wrapper.to_u64 U64 u64.ToU64Inst x - -/- [traits::h2]: forward function -/ -def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := - Wrapper.to_u64 T inst x - -/- [traits::u64::{5}::to_type]: forward function -/ -def u64.to_type (self : U64) : Result Bool := - Result.ret (self > 0#u64) - -/- Trait implementation: [traits::u64::{5}] -/ -def u64.ToTypeInst : ToType U64 Bool := { - to_type := u64.to_type -} - -/- [traits::h3]: forward function -/ -def h3 - (T1 T2 : Type) (inst : OfType T1) (inst0 : ToType T2 T1) (y : T2) : - Result T1 - := - inst.of_type T2 inst0 y - -/- [traits::h4]: forward function -/ -def h4 - (T1 T2 : Type) (inst : OfTypeBis T1 T2) (inst0 : ToType T2 T1) (y : T2) : - Result T1 - := - inst.of_type y - -/- [traits::TestType::{6}::test::TestType1::{0}::test]: forward function -/ -def TestType.test.TestType1.test - (self : TestType.test.TestType1) : Result Bool := - Result.ret (self._0 > 1#u64) - -/- Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] -/ -def TestType.test.TestType1.TestTypetestTestTraitInst : TestType.test.TestTrait - TestType.test.TestType1 := { - test := TestType.test.TestType1.test -} - -/- [traits::TestType::{6}::test]: forward function -/ -def TestType.test - (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := - do - let x0 ← inst.to_u64 x - if x0 > 0#u64 - then TestType.test.TestType1.test { _0 := 0#u64 } - else Result.ret false - -/- [traits::BoolWrapper::{7}::to_type]: forward function -/ -def BoolWrapper.to_type - (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := - inst.to_type self._0 - -/- Trait implementation: [traits::BoolWrapper::{7}] -/ -def BoolWrapper.ToTypeInst (T : Type) (inst : ToType Bool T) : ToType - BoolWrapper T := { - to_type := BoolWrapper.to_type T inst -} - -/- [traits::WithConstTy::LEN2] -/ -def with_const_ty_len2_body : Result Usize := Result.ret 32#usize -def with_const_ty_len2_c : Usize := - eval_global with_const_ty_len2_body (by simp) - -/- [traits::Bool::{8}::LEN1] -/ -def bool_len1_body : Result Usize := Result.ret 12#usize -def bool_len1_c : Usize := eval_global bool_len1_body (by simp) - -/- [traits::Bool::{8}::f]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ -def Bool.f (i : U64) (a : Array U8 32#usize) : Result U64 := - Result.ret i - -/- Trait implementation: [traits::Bool::{8}] -/ -def Bool.WithConstTyInst : WithConstTy Bool 32#usize := { - LEN1 := bool_len1_c - LEN2 := with_const_ty_len2_c - V := U8 - W := U64 - W_clause_0 := u64.ToU64Inst - f := Bool.f -} - -/- [traits::use_with_const_ty1]: forward function -/ -def use_with_const_ty1 - (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) : Result Usize := - let i := inst.LEN1 - Result.ret i - -/- [traits::use_with_const_ty2]: forward function -/ -def use_with_const_ty2 - (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (w : inst.W) : - Result Unit - := - Result.ret () - -/- [traits::use_with_const_ty3]: forward function -/ -def use_with_const_ty3 - (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (x : inst.W) : - Result U64 - := - inst.W_clause_0.to_u64 x - -/- [traits::test_where1]: forward function -/ -def test_where1 (T : Type) (_x : T) : Result Unit := - Result.ret () - -/- [traits::test_where2]: forward function -/ -def test_where2 - (T : Type) (inst : WithConstTy T 32#usize) (_x : U32) : Result Unit := - Result.ret () - -/- [traits::test_child_trait1]: forward function -/ -def test_child_trait1 - (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := - inst.parent_clause_0.get_name x - -/- [traits::test_child_trait2]: forward function -/ -def test_child_trait2 - (T : Type) (inst : ChildTrait T) (x : T) : Result inst.parent_clause_0.W := - inst.parent_clause_0.get_w x - -/- [traits::order1]: forward function -/ -def order1 - (T U : Type) (inst : ParentTrait0 T) (inst0 : ParentTrait0 U) : - Result Unit - := - Result.ret () - -/- Trait implementation: [traits::usize::{9}] -/ -def usize.ParentTrait1Inst : ParentTrait1 Usize := { -} - -/- Trait implementation: [traits::usize::{10}] -/ -def usize.ChildTrait1Inst : ChildTrait1 Usize := { - parent_clause_0 := usize.ParentTrait1Inst -} - -/- [traits::map_option]: forward function -/ -def map_option - (T F : Type) (inst : core.ops.function.Fn F T) (x : Option T) (f0 : F) : - Result (Option T) - := - match x with - | none => Result.ret none - | some x0 => do - let t ← inst.call f0 x0 - Result.ret (some t) - -/- Trait implementation: [traits::u32::{11}] -/ -def u32.WithTargetInst : WithTarget U32 := { - Target := U32 -} - -/- Trait implementation: [traits::u32::{12}] -/ -def u32.ParentTrait2Inst : ParentTrait2 U32 := { - U := U32 - U_clause_0 := u32.WithTargetInst -} - -/- [traits::u32::{13}::convert]: forward function -/ -def u32.convert (x : U32) : Result U32 := - Result.ret x - -/- Trait implementation: [traits::u32::{13}] -/ -def u32.ChildTrait2Inst : ChildTrait2 U32 := { - parent_clause_0 := u32.ParentTrait2Inst - convert := u32.convert -} - -/- [traits::incr_u32]: forward function -/ -def incr_u32 (x : U32) : Result U32 := - x + 1#u32 - -end traits diff --git a/tests/lean/Traits/Types.lean b/tests/lean/Traits/Types.lean deleted file mode 100644 index 4c5dd874..00000000 --- a/tests/lean/Traits/Types.lean +++ /dev/null @@ -1,144 +0,0 @@ --- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS --- [traits]: type definitions -import Base -open Primitives - -namespace traits - -/- Trait declaration: [traits::BoolTrait] -/ -structure BoolTrait (Self : Type) where - get_bool : Self → Result Bool - -/- Trait declaration: [traits::ToU64] -/ -structure ToU64 (Self : Type) where - to_u64 : Self → Result U64 - -/- [traits::Wrapper] -/ -structure Wrapper (T : Type) where - x : T - -/- Trait declaration: [traits::ToType] -/ -structure ToType (Self T : Type) where - to_type : Self → Result T - -/- Trait declaration: [traits::OfType] -/ -structure OfType (Self : Type) where - of_type : forall (T : Type) (inst : ToType T Self), T → Result Self - -/- Trait declaration: [traits::OfTypeBis] -/ -structure OfTypeBis (Self T : Type) where - parent_clause_0 : ToType T Self - of_type : T → Result Self - -/- [traits::TestType] -/ -structure TestType (T : Type) where - _0 : T - -/- [traits::TestType::{6}::test::TestType1] -/ -structure TestType.test.TestType1 where - _0 : U64 - -/- Trait declaration: [traits::TestType::{6}::test::TestTrait] -/ -structure TestType.test.TestTrait (Self : Type) where - test : Self → Result Bool - -/- [traits::BoolWrapper] -/ -structure BoolWrapper where - _0 : Bool - -/- Trait declaration: [traits::WithConstTy] -/ -structure WithConstTy (Self : Type) (LEN : Usize) where - LEN1 : Usize - LEN2 : Usize - V : Type - W : Type - W_clause_0 : ToU64 W - f : W → Array U8 LEN → Result W - -/- [alloc::string::String] -/ -axiom alloc.string.String : Type - -/- Trait declaration: [traits::ParentTrait0] -/ -structure ParentTrait0 (Self : Type) where - W : Type - get_name : Self → Result alloc.string.String - get_w : Self → Result W - -/- Trait declaration: [traits::ParentTrait1] -/ -structure ParentTrait1 (Self : Type) where - -/- Trait declaration: [traits::ChildTrait] -/ -structure ChildTrait (Self : Type) where - parent_clause_0 : ParentTrait0 Self - parent_clause_1 : ParentTrait1 Self - -/- Trait declaration: [traits::ChildTrait1] -/ -structure ChildTrait1 (Self : Type) where - parent_clause_0 : ParentTrait1 Self - -/- Trait declaration: [traits::Iterator] -/ -structure Iterator (Self : Type) where - Item : Type - -/- Trait declaration: [traits::IntoIterator] -/ -structure IntoIterator (Self : Type) where - Item : Type - IntoIter : Type - IntoIter_clause_0 : Iterator IntoIter - into_iter : Self → Result IntoIter - -/- Trait declaration: [traits::FromResidual] -/ -structure FromResidual (Self T : Type) where - -/- Trait declaration: [traits::Try] -/ -structure Try (Self : Type) where - parent_clause_0 : FromResidual Self Residual - Residual : Type - -/- Trait declaration: [traits::CFnOnce] -/ -structure CFnOnce (Self Args : Type) where - Output : Type - call_once : Self → Args → Result Output - -/- Trait declaration: [traits::CFnMut] -/ -structure CFnMut (Self Args : Type) where - parent_clause_0 : CFnOnce Self Args - call_mut : Self → Args → Result parent_clause_0.Output - call_mut_back : Self → Args → parent_clause_0.Output → Result Self - -/- Trait declaration: [traits::CFn] -/ -structure CFn (Self Args : Type) where - parent_clause_0 : CFnMut Self Args - call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output - -/- Trait declaration: [core::ops::function::FnOnce] -/ -structure core.ops.function.FnOnce (Self Args : Type) where - Output : Type - call_once : Self → Args → Result Output - -/- Trait declaration: [core::ops::function::FnMut] -/ -structure core.ops.function.FnMut (Self Args : Type) where - parent_clause_0 : core.ops.function.FnOnce Self Args - call_mut : Self → Args → Result parent_clause_0.Output - call_mut_back : Self → Args → parent_clause_0.Output → Result Self - -/- Trait declaration: [core::ops::function::Fn] -/ -structure core.ops.function.Fn (Self Args : Type) where - parent_clause_0 : core.ops.function.FnMut Self Args - call : Self → Args → Result parent_clause_0.parent_clause_0.Output - -/- Trait declaration: [traits::WithTarget] -/ -structure WithTarget (Self : Type) where - Target : Type - -/- Trait declaration: [traits::ParentTrait2] -/ -structure ParentTrait2 (Self : Type) where - U : Type - U_clause_0 : WithTarget U - -/- Trait declaration: [traits::ChildTrait2] -/ -structure ChildTrait2 (Self : Type) where - parent_clause_0 : ParentTrait2 Self - convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target - -end traits -- 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 ++ tests/fstar/array/Array.fst | 387 +++++++++++++++++++++ tests/fstar/traits/Primitives.fst | 713 ++++++++++++++++++++++++++++++++++++++ tests/fstar/traits/Traits.fst | 401 +++++++++++++++++++++ 6 files changed, 1616 insertions(+), 36 deletions(-) create mode 100644 tests/fstar/array/Array.fst create mode 100644 tests/fstar/traits/Primitives.fst create mode 100644 tests/fstar/traits/Traits.fst 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 = [] diff --git a/tests/fstar/array/Array.fst b/tests/fstar/array/Array.fst new file mode 100644 index 00000000..341f5239 --- /dev/null +++ b/tests/fstar/array/Array.fst @@ -0,0 +1,387 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [array] *) +module Array +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [array::AB] *) +type aB_t = | AB_A : aB_t | AB_B : aB_t + +(** [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let incr (x : u32) : result u32 = + u32_add x 1 + +(** [array::array_to_shared_slice_]: forward function *) +let array_to_shared_slice_ (t : Type0) (s : array t 32) : result (slice t) = + array_to_slice t 32 s + +(** [array::array_to_mut_slice_]: forward function *) +let array_to_mut_slice_ (t : Type0) (s : array t 32) : result (slice t) = + array_to_slice t 32 s + +(** [array::array_to_mut_slice_]: backward function 0 *) +let array_to_mut_slice__back + (t : Type0) (s : array t 32) (ret : slice t) : result (array t 32) = + array_from_slice t 32 s ret + +(** [array::array_len]: forward function *) +let array_len (t : Type0) (s : array t 32) : result usize = + let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i + +(** [array::shared_array_len]: forward function *) +let shared_array_len (t : Type0) (s : array t 32) : result usize = + let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i + +(** [array::shared_slice_len]: forward function *) +let shared_slice_len (t : Type0) (s : slice t) : result usize = + let i = slice_len t s in Return i + +(** [array::index_array_shared]: forward function *) +let index_array_shared (t : Type0) (s : array t 32) (i : usize) : result t = + array_index_usize t 32 s i + +(** [array::index_array_u32]: forward function *) +let index_array_u32 (s : array u32 32) (i : usize) : result u32 = + array_index_usize u32 32 s i + +(** [array::index_array_copy]: forward function *) +let index_array_copy (x : array u32 32) : result u32 = + array_index_usize u32 32 x 0 + +(** [array::index_mut_array]: forward function *) +let index_mut_array (t : Type0) (s : array t 32) (i : usize) : result t = + array_index_usize t 32 s i + +(** [array::index_mut_array]: backward function 0 *) +let index_mut_array_back + (t : Type0) (s : array t 32) (i : usize) (ret : t) : result (array t 32) = + array_update_usize t 32 s i ret + +(** [array::index_slice]: forward function *) +let index_slice (t : Type0) (s : slice t) (i : usize) : result t = + slice_index_usize t s i + +(** [array::index_mut_slice]: forward function *) +let index_mut_slice (t : Type0) (s : slice t) (i : usize) : result t = + slice_index_usize t s i + +(** [array::index_mut_slice]: backward function 0 *) +let index_mut_slice_back + (t : Type0) (s : slice t) (i : usize) (ret : t) : result (slice t) = + slice_update_usize t s i ret + +(** [array::slice_subslice_shared_]: forward function *) +let slice_subslice_shared_ + (x : slice u32) (y : usize) (z : usize) : result (slice u32) = + core_slice_index_Slice_index u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } + +(** [array::slice_subslice_mut_]: forward function *) +let slice_subslice_mut_ + (x : slice u32) (y : usize) (z : usize) : result (slice u32) = + core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } + +(** [array::slice_subslice_mut_]: backward function 0 *) +let slice_subslice_mut__back + (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : + result (slice u32) + = + core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + { start = y; end_ = z } ret + +(** [array::array_to_slice_shared_]: forward function *) +let array_to_slice_shared_ (x : array u32 32) : result (slice u32) = + array_to_slice u32 32 x + +(** [array::array_to_slice_mut_]: forward function *) +let array_to_slice_mut_ (x : array u32 32) : result (slice u32) = + array_to_slice u32 32 x + +(** [array::array_to_slice_mut_]: backward function 0 *) +let array_to_slice_mut__back + (x : array u32 32) (ret : slice u32) : result (array u32 32) = + array_from_slice u32 32 x ret + +(** [array::array_subslice_shared_]: forward function *) +let array_subslice_shared_ + (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = + core_array_Array_index u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } + +(** [array::array_subslice_mut_]: forward function *) +let array_subslice_mut_ + (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = + core_array_Array_index_mut u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } + +(** [array::array_subslice_mut_]: backward function 0 *) +let array_subslice_mut__back + (x : array u32 32) (y : usize) (z : usize) (ret : slice u32) : + result (array u32 32) + = + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } ret + +(** [array::index_slice_0]: forward function *) +let index_slice_0 (t : Type0) (s : slice t) : result t = + slice_index_usize t s 0 + +(** [array::index_array_0]: forward function *) +let index_array_0 (t : Type0) (s : array t 32) : result t = + array_index_usize t 32 s 0 + +(** [array::index_index_array]: forward function *) +let index_index_array + (s : array (array u32 32) 32) (i : usize) (j : usize) : result u32 = + let* a = array_index_usize (array u32 32) 32 s i in + array_index_usize u32 32 a j + +(** [array::update_update_array]: forward function *) +let update_update_array + (s : array (array u32 32) 32) (i : usize) (j : usize) : result unit = + let* a = array_index_usize (array u32 32) 32 s i in + let* a0 = array_update_usize u32 32 a j 0 in + let* _ = array_update_usize (array u32 32) 32 s i a0 in + Return () + +(** [array::array_local_deep_copy]: forward function *) +let array_local_deep_copy (x : array u32 32) : result unit = + Return () + +(** [array::take_array]: forward function *) +let take_array (a : array u32 2) : result unit = + Return () + +(** [array::take_array_borrow]: forward function *) +let take_array_borrow (a : array u32 2) : result unit = + Return () + +(** [array::take_slice]: forward function *) +let take_slice (s : slice u32) : result unit = + Return () + +(** [array::take_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let take_mut_slice (s : slice u32) : result (slice u32) = + Return s + +(** [array::take_all]: forward function *) +let take_all : result unit = + let* _ = take_array (mk_array u32 2 [ 0; 0 ]) in + let* _ = take_array_borrow (mk_array u32 2 [ 0; 0 ]) in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* _ = take_slice s in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s1 = take_mut_slice s0 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + Return () + +(** [array::index_array]: forward function *) +let index_array (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 + +(** [array::index_array_borrow]: forward function *) +let index_array_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 + +(** [array::index_slice_u32_0]: forward function *) +let index_slice_u32_0 (x : slice u32) : result u32 = + slice_index_usize u32 x 0 + +(** [array::index_mut_slice_u32_0]: forward function *) +let index_mut_slice_u32_0 (x : slice u32) : result u32 = + slice_index_usize u32 x 0 + +(** [array::index_mut_slice_u32_0]: backward function 0 *) +let index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) = + let* _ = slice_index_usize u32 x 0 in Return x + +(** [array::index_all]: forward function *) +let index_all : result u32 = + let* i = index_array (mk_array u32 2 [ 0; 0 ]) in + let* i0 = index_array (mk_array u32 2 [ 0; 0 ]) in + let* i1 = u32_add i i0 in + let* i2 = index_array_borrow (mk_array u32 2 [ 0; 0 ]) in + let* i3 = u32_add i1 i2 in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* i4 = index_slice_u32_0 s in + let* i5 = u32_add i3 i4 in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* i6 = index_mut_slice_u32_0 s0 in + let* i7 = u32_add i5 i6 in + let* s1 = index_mut_slice_u32_0_back s0 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + Return i7 + +(** [array::update_array]: forward function *) +let update_array (x : array u32 2) : result unit = + let* _ = array_update_usize u32 2 x 0 1 in Return () + +(** [array::update_array_mut_borrow]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let update_array_mut_borrow (x : array u32 2) : result (array u32 2) = + array_update_usize u32 2 x 0 1 + +(** [array::update_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let update_mut_slice (x : slice u32) : result (slice u32) = + slice_update_usize u32 x 0 1 + +(** [array::update_all]: forward function *) +let update_all : result unit = + let* _ = update_array (mk_array u32 2 [ 0; 0 ]) in + let* x = update_array_mut_borrow (mk_array u32 2 [ 0; 0 ]) in + let* s = array_to_slice u32 2 x in + let* s0 = update_mut_slice s in + let* _ = array_from_slice u32 2 x s0 in + Return () + +(** [array::range_all]: forward function *) +let range_all : result unit = + let* s = + core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } in + let* s0 = update_mut_slice s in + let* _ = + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4 + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } s0 in + Return () + +(** [array::deref_array_borrow]: forward function *) +let deref_array_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 + +(** [array::deref_array_mut_borrow]: forward function *) +let deref_array_mut_borrow (x : array u32 2) : result u32 = + array_index_usize u32 2 x 0 + +(** [array::deref_array_mut_borrow]: backward function 0 *) +let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = + let* _ = array_index_usize u32 2 x 0 in Return x + +(** [array::take_array_t]: forward function *) +let take_array_t (a : array aB_t 2) : result unit = + Return () + +(** [array::non_copyable_array]: forward function *) +let non_copyable_array : result unit = + let* _ = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) in Return () + +(** [array::sum]: decreases clause *) +unfold +let sum_loop_decreases (s : slice u32) (sum0 : u32) (i : usize) : nat = + admit () + +(** [array::sum]: loop 0: forward function *) +let rec sum_loop + (s : slice u32) (sum0 : u32) (i : usize) : + Tot (result u32) (decreases (sum_loop_decreases s sum0 i)) + = + let i0 = slice_len u32 s in + if i < i0 + then + let* i1 = slice_index_usize u32 s i in + let* sum1 = u32_add sum0 i1 in + let* i2 = usize_add i 1 in + sum_loop s sum1 i2 + else Return sum0 + +(** [array::sum]: forward function *) +let sum (s : slice u32) : result u32 = + sum_loop s 0 0 + +(** [array::sum2]: decreases clause *) +unfold +let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum0 : u32) + (i : usize) : nat = + admit () + +(** [array::sum2]: loop 0: forward function *) +let rec sum2_loop + (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : + Tot (result u32) (decreases (sum2_loop_decreases s s2 sum0 i)) + = + let i0 = slice_len u32 s in + if i < i0 + then + let* i1 = slice_index_usize u32 s i in + let* i2 = slice_index_usize u32 s2 i in + let* i3 = u32_add i1 i2 in + let* sum1 = u32_add sum0 i3 in + let* i4 = usize_add i 1 in + sum2_loop s s2 sum1 i4 + else Return sum0 + +(** [array::sum2]: forward function *) +let sum2 (s : slice u32) (s2 : slice u32) : result u32 = + let i = slice_len u32 s in + let i0 = slice_len u32 s2 in + if not (i = i0) then Fail Failure else sum2_loop s s2 0 0 + +(** [array::f0]: forward function *) +let f0 : result unit = + let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in + let* s0 = slice_update_usize u32 s 0 1 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in + Return () + +(** [array::f1]: forward function *) +let f1 : result unit = + let* _ = array_update_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in Return () + +(** [array::f2]: forward function *) +let f2 (i : u32) : result unit = + Return () + +(** [array::f4]: forward function *) +let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = + core_array_Array_index u32 (core_ops_range_Range usize) 32 + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + { start = y; end_ = z } + +(** [array::f3]: forward function *) +let f3 : result u32 = + let* i = array_index_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in + let* _ = f2 i in + let b = array_repeat u32 32 0 in + let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in + let* s0 = f4 b 16 18 in + sum2 s s0 + +(** [array::SZ] *) +let sz_body : result usize = Return 32 +let sz_c : usize = eval_global sz_body + +(** [array::f5]: forward function *) +let f5 (x : array u32 32) : result u32 = + array_index_usize u32 32 x 0 + +(** [array::ite]: forward function *) +let ite : result unit = + let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in + let* s1 = index_mut_slice_u32_0_back s0 in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in + let* s2 = index_mut_slice_u32_0_back s in + let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s2 in + Return () + diff --git a/tests/fstar/traits/Primitives.fst b/tests/fstar/traits/Primitives.fst new file mode 100644 index 00000000..71d75c11 --- /dev/null +++ b/tests/fstar/traits/Primitives.fst @@ -0,0 +1,713 @@ +/// This file lists primitive and assumed functions and types +module Primitives +open FStar.Mul +open FStar.List.Tot + +#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" + +(*** Utilities *) +val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : + ls':list a{ + length ls' = length ls /\ + index ls' i == x + } +#push-options "--fuel 1" +let rec list_update #a ls i x = + match ls with + | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x +#pop-options + +(*** Result *) +type error : Type0 = +| Failure +| OutOfFuel + +type result (a : Type0) : Type0 = +| Return : v:a -> result a +| Fail : e:error -> result a + +// Monadic return operator +unfold let return (#a : Type0) (x : a) : result a = Return x + +// Monadic bind operator. +// Allows to use the notation: +// ``` +// let* x = y in +// ... +// ``` +unfold let (let*) (#a #b : Type0) (m: result a) + (f: (x:a) -> Pure (result b) (requires (m == Return x)) (ensures fun _ -> True)) : + result b = + match m with + | Return x -> f x + | Fail e -> Fail e + +// Monadic assert(...) +let massert (b:bool) : result unit = if b then Return () else Fail Failure + +// Normalize and unwrap a successful result (used for globals). +let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x + +(*** Misc *) +type char = FStar.Char.char +type string = string + +let is_zero (n: nat) : bool = n = 0 +let decrease (n: nat{n > 0}) : nat = n - 1 + +let core_mem_replace (a : Type0) (x : a) (y : a) : a = x +let core_mem_replace_back (a : Type0) (x : a) (y : a) : a = y + +// We don't really use raw pointers for now +type mut_raw_ptr (t : Type0) = { v : t } +type const_raw_ptr (t : Type0) = { v : t } + +(*** Scalars *) +/// Rem.: most of the following code was partially generated + +let isize_min : int = -9223372036854775808 // TODO: should be opaque +let isize_max : int = 9223372036854775807 // TODO: should be opaque +let i8_min : int = -128 +let i8_max : int = 127 +let i16_min : int = -32768 +let i16_max : int = 32767 +let i32_min : int = -2147483648 +let i32_max : int = 2147483647 +let i64_min : int = -9223372036854775808 +let i64_max : int = 9223372036854775807 +let i128_min : int = -170141183460469231731687303715884105728 +let i128_max : int = 170141183460469231731687303715884105727 +let usize_min : int = 0 +let usize_max : int = 4294967295 // TODO: should be opaque +let u8_min : int = 0 +let u8_max : int = 255 +let u16_min : int = 0 +let u16_max : int = 65535 +let u32_min : int = 0 +let u32_max : int = 4294967295 +let u64_min : int = 0 +let u64_max : int = 18446744073709551615 +let u128_min : int = 0 +let u128_max : int = 340282366920938463463374607431768211455 + +type scalar_ty = +| Isize +| I8 +| I16 +| I32 +| I64 +| I128 +| Usize +| U8 +| U16 +| U32 +| U64 +| U128 + +let is_unsigned = function + | Isize | I8 | I16 | I32 | I64 | I128 -> false + | Usize | U8 | U16 | U32 | U64 | U128 -> true + + +let scalar_min (ty : scalar_ty) : int = + match ty with + | Isize -> isize_min + | I8 -> i8_min + | I16 -> i16_min + | I32 -> i32_min + | I64 -> i64_min + | I128 -> i128_min + | Usize -> usize_min + | U8 -> u8_min + | U16 -> u16_min + | U32 -> u32_min + | U64 -> u64_min + | U128 -> u128_min + +let scalar_max (ty : scalar_ty) : int = + match ty with + | Isize -> isize_max + | I8 -> i8_max + | I16 -> i16_max + | I32 -> i32_max + | I64 -> i64_max + | I128 -> i128_max + | Usize -> usize_max + | U8 -> u8_max + | U16 -> u16_max + | U32 -> u32_max + | U64 -> u64_max + | U128 -> u128_max + +type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} + +let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = + if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail Failure + +let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) + +let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (x / y) else Fail Failure + +/// The remainder operation +let int_rem (x : int) (y : int{y <> 0}) : int = + if x >= 0 then (x % y) else -(x % y) + +(* Checking consistency with Rust *) +let _ = assert_norm(int_rem 1 2 = 1) +let _ = assert_norm(int_rem (-1) 2 = -1) +let _ = assert_norm(int_rem 1 (-2) = 1) +let _ = assert_norm(int_rem (-1) (-2) = -1) + +let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + if y <> 0 then mk_scalar ty (int_rem x y) else Fail Failure + +let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x + y) + +let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x - y) + +let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = + mk_scalar ty (x * y) + +let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logxor #8 x y + | U16 -> FStar.UInt.logxor #16 x y + | U32 -> FStar.UInt.logxor #32 x y + | U64 -> FStar.UInt.logxor #64 x y + | U128 -> FStar.UInt.logxor #128 x y + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +// TODO: check the semantics of casts in Rust +let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = + mk_scalar tgt_ty x + +/// The scalar types +type isize : eqtype = scalar Isize +type i8 : eqtype = scalar I8 +type i16 : eqtype = scalar I16 +type i32 : eqtype = scalar I32 +type i64 : eqtype = scalar I64 +type i128 : eqtype = scalar I128 +type usize : eqtype = scalar Usize +type u8 : eqtype = scalar U8 +type u16 : eqtype = scalar U16 +type u32 : eqtype = scalar U32 +type u64 : eqtype = scalar U64 +type u128 : eqtype = scalar U128 + + +let core_isize_min : isize = isize_min +let core_isize_max : isize = isize_max +let core_i8_min : i8 = i8_min +let core_i8_max : i8 = i8_max +let core_i16_min : i16 = i16_min +let core_i16_max : i16 = i16_max +let core_i32_min : i32 = i32_min +let core_i32_max : i32 = i32_max +let core_i64_min : i64 = i64_min +let core_i64_max : i64 = i64_max +let core_i128_min : i128 = i128_min +let core_i128_max : i128 = i128_max + +let core_usize_min : usize = usize_min +let core_usize_max : usize = usize_max +let core_u8_min : u8 = u8_min +let core_u8_max : u8 = u8_max +let core_u16_min : u16 = u16_min +let core_u16_max : u16 = u16_max +let core_u32_min : u32 = u32_min +let core_u32_max : u32 = u32_max +let core_u64_min : u64 = u64_min +let core_u64_max : u64 = u64_max +let core_u128_min : u128 = u128_min +let core_u128_max : u128 = u128_max + +/// Negation +let isize_neg = scalar_neg #Isize +let i8_neg = scalar_neg #I8 +let i16_neg = scalar_neg #I16 +let i32_neg = scalar_neg #I32 +let i64_neg = scalar_neg #I64 +let i128_neg = scalar_neg #I128 + +/// Division +let isize_div = scalar_div #Isize +let i8_div = scalar_div #I8 +let i16_div = scalar_div #I16 +let i32_div = scalar_div #I32 +let i64_div = scalar_div #I64 +let i128_div = scalar_div #I128 +let usize_div = scalar_div #Usize +let u8_div = scalar_div #U8 +let u16_div = scalar_div #U16 +let u32_div = scalar_div #U32 +let u64_div = scalar_div #U64 +let u128_div = scalar_div #U128 + +/// Remainder +let isize_rem = scalar_rem #Isize +let i8_rem = scalar_rem #I8 +let i16_rem = scalar_rem #I16 +let i32_rem = scalar_rem #I32 +let i64_rem = scalar_rem #I64 +let i128_rem = scalar_rem #I128 +let usize_rem = scalar_rem #Usize +let u8_rem = scalar_rem #U8 +let u16_rem = scalar_rem #U16 +let u32_rem = scalar_rem #U32 +let u64_rem = scalar_rem #U64 +let u128_rem = scalar_rem #U128 + +/// Addition +let isize_add = scalar_add #Isize +let i8_add = scalar_add #I8 +let i16_add = scalar_add #I16 +let i32_add = scalar_add #I32 +let i64_add = scalar_add #I64 +let i128_add = scalar_add #I128 +let usize_add = scalar_add #Usize +let u8_add = scalar_add #U8 +let u16_add = scalar_add #U16 +let u32_add = scalar_add #U32 +let u64_add = scalar_add #U64 +let u128_add = scalar_add #U128 + +/// Subtraction +let isize_sub = scalar_sub #Isize +let i8_sub = scalar_sub #I8 +let i16_sub = scalar_sub #I16 +let i32_sub = scalar_sub #I32 +let i64_sub = scalar_sub #I64 +let i128_sub = scalar_sub #I128 +let usize_sub = scalar_sub #Usize +let u8_sub = scalar_sub #U8 +let u16_sub = scalar_sub #U16 +let u32_sub = scalar_sub #U32 +let u64_sub = scalar_sub #U64 +let u128_sub = scalar_sub #U128 + +/// Multiplication +let isize_mul = scalar_mul #Isize +let i8_mul = scalar_mul #I8 +let i16_mul = scalar_mul #I16 +let i32_mul = scalar_mul #I32 +let i64_mul = scalar_mul #I64 +let i128_mul = scalar_mul #I128 +let usize_mul = scalar_mul #Usize +let u8_mul = scalar_mul #U8 +let u16_mul = scalar_mul #U16 +let u32_mul = scalar_mul #U32 +let u64_mul = scalar_mul #U64 +let u128_mul = scalar_mul #U128 + +/// Logical operators, defined for unsigned types only, so far +let u8_xor = scalar_lxor #U8 +let u16_xor = scalar_lxor #U16 +let u32_xor = scalar_lxor #U32 +let u64_xor = scalar_lxor #U64 +let u128_xor = scalar_lxor #U128 + +(*** core::ops *) + +// Trait declaration: [core::ops::index::Index] +noeq type core_ops_index_Index (self idx : Type0) = { + output : Type0; + index : self → idx → result output +} + +// Trait declaration: [core::ops::index::IndexMut] +noeq type core_ops_index_IndexMut (self idx : Type0) = { + indexInst : core_ops_index_Index self idx; + index_mut : self → idx → result indexInst.output; + index_mut_back : self → idx → indexInst.output → result self; +} + +// Trait declaration [core::ops::deref::Deref] +noeq type core_ops_deref_Deref (self : Type0) = { + target : Type0; + deref : self → result target; +} + +// Trait declaration [core::ops::deref::DerefMut] +noeq type core_ops_deref_DerefMut (self : Type0) = { + derefInst : core_ops_deref_Deref self; + deref_mut : self → result derefInst.target; + deref_mut_back : self → derefInst.target → result self; +} + +type core_ops_range_Range (a : Type0) = { + start : a; + end_ : a; +} + +(*** [alloc] *) + +let alloc_boxed_Box_deref (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x +let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x + +// Trait instance +let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { + target = self; + deref = alloc_boxed_Box_deref self; +} + +// Trait instance +let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreOpsDerefInst self; + deref_mut = alloc_boxed_Box_deref_mut self; + deref_mut_back = alloc_boxed_Box_deref_mut_back self; +} + +(*** Array *) +type array (a : Type0) (n : usize) = s:list a{length s = n} + +// We tried putting the normalize_term condition as a refinement on the list +// but it didn't work. It works with the requires clause. +let mk_array (a : Type0) (n : usize) + (l : list a) : + Pure (array a n) + (requires (normalize_term(FStar.List.Tot.length l) = n)) + (ensures (fun _ -> True)) = + normalize_term_spec (FStar.List.Tot.length l); + l + +let array_index_usize (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let array_update_usize (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = + if i < length x then Return (list_update x i nx) + else Fail Failure + +(*** Slice *) +type slice (a : Type0) = s:list a{length s <= usize_max} + +let slice_len (a : Type0) (s : slice a) : usize = length s + +let slice_index_usize (a : Type0) (x : slice a) (i : usize) : result a = + if i < length x then Return (index x i) + else Fail Failure + +let slice_update_usize (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = + if i < length x then Return (list_update x i nx) + else Fail Failure + +(*** Subslices *) + +let array_to_slice (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x +let array_from_slice (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = + if length s = n then Return s + else Fail Failure + +// TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) +let array_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) : result (slice a) = + admit() + +let array_update_subslice (a : Type0) (n : usize) (x : array a n) (r : core_ops_range_Range usize) (ns : slice a) : result (array a n) = + admit() + +let array_repeat (a : Type0) (n : usize) (x : a) : array a n = + admit() + +let slice_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) : result (slice a) = + admit() + +let slice_update_subslice (a : Type0) (x : slice a) (r : core_ops_range_Range usize) (ns : slice a) : result (slice a) = + admit() + +(*** Vector *) +type alloc_vec_Vec (a : Type0) = v:list a{length v <= usize_max} + +let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] == 0); [] +let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v + +// Helper +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = + if i < length v then Return (index v i) else Fail Failure +// Helper +let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + +// The **forward** function shouldn't be used +let alloc_vec_Vec_push_fwd (a : Type0) (v : alloc_vec_Vec a) (x : a) : unit = () +let alloc_vec_Vec_push (a : Type0) (v : alloc_vec_Vec a) (x : a) : + Pure (result (alloc_vec_Vec a)) + (requires True) + (ensures (fun res -> + match res with + | Fail e -> e == Failure + | Return v' -> length v' = length v + 1)) = + if length v < usize_max then begin + (**) assert_norm(length [x] == 1); + (**) append_length v [x]; + (**) assert(length (append v [x]) = length v + 1); + Return (append v [x]) + end + else Fail Failure + +// The **forward** function shouldn't be used +let alloc_vec_Vec_insert_fwd (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result unit = + if i < length v then Return () else Fail Failure +let alloc_vec_Vec_insert (a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = + if i < length v then Return (list_update v i x) else Fail Failure + +// Trait declaration: [core::slice::index::private_slice_index::Sealed] +type core_slice_index_private_slice_index_Sealed (self : Type0) = unit + +// Trait declaration: [core::slice::index::SliceIndex] +noeq type core_slice_index_SliceIndex (self t : Type0) = { + sealedInst : core_slice_index_private_slice_index_Sealed self; + output : Type0; + get : self → t → result (option output); + get_mut : self → t → result (option output); + get_mut_back : self → t → option output → result t; + get_unchecked : self → const_raw_ptr t → result (const_raw_ptr output); + get_unchecked_mut : self → mut_raw_ptr t → result (mut_raw_ptr output); + index : self → t → result output; + index_mut : self → t → result output; + index_mut_back : self → t → output → result t; +} + +// [core::slice::index::[T]::index]: forward function +let core_slice_index_Slice_index + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (s : slice t) (i : idx) : result inst.output = + let* x = inst.get i s in + match x with + | None -> Fail Failure + | Some x -> Return x + +// [core::slice::index::Range:::get]: forward function +let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : + result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: forward function +let core_slice_index_Range_get_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = + admit () // TODO + +// [core::slice::index::Range::get_mut]: backward function 0 +let core_slice_index_Range_get_mut_back + (t : Type0) : + core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::get_unchecked]: forward function +let core_slice_index_Range_get_unchecked + (t : Type0) : + core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::get_unchecked_mut]: forward function +let core_slice_index_Range_get_unchecked_mut + (t : Type0) : + core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = + // Don't know what the model should be - for now we always fail to make + // sure code which uses it fails + fun _ _ -> Fail Failure + +// [core::slice::index::Range::index]: forward function +let core_slice_index_Range_index + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: forward function +let core_slice_index_Range_index_mut + (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::Range::index_mut]: backward function 0 +let core_slice_index_Range_index_mut_back + (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = + admit () // TODO + +// [core::slice::index::[T]::index_mut]: forward function +let core_slice_index_Slice_index_mut + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → result inst.output = + admit () // + +// [core::slice::index::[T]::index_mut]: backward function 0 +let core_slice_index_Slice_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : + slice t → idx → inst.output → result (slice t) = + admit () // TODO + +// [core::array::[T; N]::index]: forward function +let core_array_Array_index + (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) + (a : array t n) (i : idx) : result inst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: forward function +let core_array_Array_index_mut + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) : result inst.indexInst.output = + admit () // TODO + +// [core::array::[T; N]::index_mut]: backward function 0 +let core_array_Array_index_mut_back + (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) + (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = + admit () // TODO + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::private_slice_index::Range] +let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () + +// Trait implementation: [core::slice::index::Range] +let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { + sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + output = slice t; + get = core_slice_index_Range_get t; + get_mut = core_slice_index_Range_get_mut t; + get_mut_back = core_slice_index_Range_get_mut_back t; + get_unchecked = core_slice_index_Range_get_unchecked t; + get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; + index = core_slice_index_Range_index t; + index_mut = core_slice_index_Range_index_mut t; + index_mut_back = core_slice_index_Range_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (slice t) idx = { + indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + index_mut = core_slice_index_Slice_index_mut t idx inst; + index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) + (inst : core_ops_index_Index (slice t) idx) : + core_ops_index_Index (array t n) idx = { + output = inst.output; + index = core_array_Array_index t idx n inst; +} + +// Trait implementation: [core::array::[T; N]] +let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) + (inst : core_ops_index_IndexMut (slice t) idx) : + core_ops_index_IndexMut (array t n) idx = { + indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + index_mut = core_array_Array_index_mut t idx n inst; + index_mut_back = core_array_Array_index_mut_back t idx n inst; +} + +// [core::slice::index::usize::get]: forward function +let core_slice_index_usize_get + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: forward function +let core_slice_index_usize_get_mut + (t : Type0) : usize → slice t → result (option t) = + admit () // TODO + +// [core::slice::index::usize::get_mut]: backward function 0 +let core_slice_index_usize_get_mut_back + (t : Type0) : usize → slice t → option t → result (slice t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked]: forward function +let core_slice_index_usize_get_unchecked + (t : Type0) : usize → const_raw_ptr (slice t) → result (const_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::get_unchecked_mut]: forward function +let core_slice_index_usize_get_unchecked_mut + (t : Type0) : usize → mut_raw_ptr (slice t) → result (mut_raw_ptr t) = + admit () // TODO + +// [core::slice::index::usize::index]: forward function +let core_slice_index_usize_index (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: forward function +let core_slice_index_usize_index_mut (t : Type0) : usize → slice t → result t = + admit () // TODO + +// [core::slice::index::usize::index_mut]: backward function 0 +let core_slice_index_usize_index_mut_back + (t : Type0) : usize → slice t → t → result (slice t) = + admit () // TODO + +// Trait implementation: [core::slice::index::private_slice_index::usize] +let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize = () + +// Trait implementation: [core::slice::index::usize] +let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : + core_slice_index_SliceIndex usize (slice t) = { + sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + output = t; + get = core_slice_index_usize_get t; + get_mut = core_slice_index_usize_get_mut t; + get_mut_back = core_slice_index_usize_get_mut_back t; + get_unchecked = core_slice_index_usize_get_unchecked t; + get_unchecked_mut = core_slice_index_usize_get_unchecked_mut t; + index = core_slice_index_usize_index t; + index_mut = core_slice_index_usize_index_mut t; + index_mut_back = core_slice_index_usize_index_mut_back t; +} + +// [alloc::vec::Vec::index]: forward function +let alloc_vec_Vec_index (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: forward function +let alloc_vec_Vec_index_mut (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) : result inst.output = + admit () // TODO + +// [alloc::vec::Vec::index_mut]: backward function 0 +let alloc_vec_Vec_index_mut_back + (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) + (self : alloc_vec_Vec t) (i : idx) (x : inst.output) : result (alloc_vec_Vec t) = + admit () // TODO + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (alloc_vec_Vec t) idx = { + output = inst.output; + index = alloc_vec_Vec_index t idx inst; +} + +// Trait implementation: [alloc::vec::Vec] +let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_IndexMut (alloc_vec_Vec t) idx = { + indexInst = alloc_vec_Vec_coreopsindexIndexInst t idx inst; + index_mut = alloc_vec_Vec_index_mut t idx inst; + index_mut_back = alloc_vec_Vec_index_mut_back t idx inst; +} + +(*** Theorems *) + +let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : + Lemma ( + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_update_usize v i x) + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + = + admit() diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst new file mode 100644 index 00000000..42b43cf2 --- /dev/null +++ b/tests/fstar/traits/Traits.fst @@ -0,0 +1,401 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [traits] *) +module Traits +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** Trait declaration: [traits::BoolTrait] *) +noeq type boolTrait_t (self : Type0) = { get_bool : self -> result bool; } + +(** [traits::Bool::{0}::get_bool]: forward function *) +let bool_get_bool (self : bool) : result bool = + Return self + +(** Trait implementation: [traits::Bool::{0}] *) +let bool_BoolTraitInst : boolTrait_t bool = { get_bool = bool_get_bool; } + +(** [traits::BoolTrait::ret_true]: forward function *) +let boolTrait_ret_true + (#self : Type0) (self_clause : boolTrait_t self) (self0 : self) : + result bool + = + Return true + +(** [traits::test_bool_trait_bool]: forward function *) +let test_bool_trait_bool (x : bool) : result bool = + let* b = bool_get_bool x in + if b then boolTrait_ret_true bool_BoolTraitInst x else Return false + +(** [traits::Option::{1}::get_bool]: forward function *) +let option_get_bool (t : Type0) (self : option t) : result bool = + begin match self with | None -> Return false | Some x -> Return true end + +(** Trait implementation: [traits::Option::{1}] *) +let option_BoolTraitInst (t : Type0) : boolTrait_t (option t) = { + get_bool = option_get_bool t; +} + +(** [traits::test_bool_trait_option]: forward function *) +let test_bool_trait_option (t : Type0) (x : option t) : result bool = + let* b = option_get_bool t x in + if b then boolTrait_ret_true (option_BoolTraitInst t) x else Return false + +(** [traits::test_bool_trait]: forward function *) +let test_bool_trait (t : Type0) (inst : boolTrait_t t) (x : t) : result bool = + inst.get_bool x + +(** Trait declaration: [traits::ToU64] *) +noeq type toU64_t (self : Type0) = { to_u64 : self -> result u64; } + +(** [traits::u64::{2}::to_u64]: forward function *) +let u64_to_u64 (self : u64) : result u64 = + Return self + +(** Trait implementation: [traits::u64::{2}] *) +let u64_ToU64Inst : toU64_t u64 = { to_u64 = u64_to_u64; } + +(** [traits::Tuple2::{3}::to_u64]: forward function *) +let tuple2_to_u64 + (a : Type0) (inst : toU64_t a) (self : (a & a)) : result u64 = + let (x, x0) = self in + let* i = inst.to_u64 x in + let* i0 = inst.to_u64 x0 in + u64_add i i0 + +(** Trait implementation: [traits::Tuple2::{3}] *) +let tuple2_ToU64Inst (a : Type0) (inst : toU64_t a) : toU64_t (a & a) = { + to_u64 = tuple2_to_u64 a inst; +} + +(** [traits::f]: forward function *) +let f (t : Type0) (inst : toU64_t t) (x : (t & t)) : result u64 = + tuple2_to_u64 t inst x + +(** [traits::g]: forward function *) +let g (t : Type0) (inst : toU64_t (t & t)) (x : (t & t)) : result u64 = + inst.to_u64 x + +(** [traits::h0]: forward function *) +let h0 (x : u64) : result u64 = + u64_to_u64 x + +(** [traits::Wrapper] *) +type wrapper_t (t : Type0) = { x : t; } + +(** [traits::Wrapper::{4}::to_u64]: forward function *) +let wrapper_to_u64 + (t : Type0) (inst : toU64_t t) (self : wrapper_t t) : result u64 = + inst.to_u64 self.x + +(** Trait implementation: [traits::Wrapper::{4}] *) +let wrapper_ToU64Inst (t : Type0) (inst : toU64_t t) : toU64_t (wrapper_t t) + = { + to_u64 = wrapper_to_u64 t inst; +} + +(** [traits::h1]: forward function *) +let h1 (x : wrapper_t u64) : result u64 = + wrapper_to_u64 u64 u64_ToU64Inst x + +(** [traits::h2]: forward function *) +let h2 (t : Type0) (inst : toU64_t t) (x : wrapper_t t) : result u64 = + wrapper_to_u64 t inst x + +(** Trait declaration: [traits::ToType] *) +noeq type toType_t (self t : Type0) = { to_type : self -> result t; } + +(** [traits::u64::{5}::to_type]: forward function *) +let u64_to_type (self : u64) : result bool = + Return (self > 0) + +(** Trait implementation: [traits::u64::{5}] *) +let u64_ToTypeInst : toType_t u64 bool = { to_type = u64_to_type; } + +(** Trait declaration: [traits::OfType] *) +noeq type ofType_t (self : Type0) = { + of_type : (t : Type0) -> (inst : toType_t t self) -> t -> result self; +} + +(** [traits::h3]: forward function *) +let h3 + (t1 t2 : Type0) (inst : ofType_t t1) (inst0 : toType_t t2 t1) (y : t2) : + result t1 + = + inst.of_type t2 inst0 y + +(** Trait declaration: [traits::OfTypeBis] *) +noeq type ofTypeBis_t (self t : Type0) = { + parent_clause_0 : toType_t t self; + of_type : t -> result self; +} + +(** [traits::h4]: forward function *) +let h4 + (t1 t2 : Type0) (inst : ofTypeBis_t t1 t2) (inst0 : toType_t t2 t1) + (y : t2) : + result t1 + = + inst.of_type y + +(** [traits::TestType] *) +type testType_t (t : Type0) = { _0 : t; } + +(** [traits::TestType::{6}::test::TestType1] *) +type testType_test_TestType1_t = { _0 : u64; } + +(** Trait declaration: [traits::TestType::{6}::test::TestTrait] *) +noeq type testType_test_TestTrait_t (self : Type0) = { + test : self -> result bool; +} + +(** [traits::TestType::{6}::test::TestType1::{0}::test]: forward function *) +let testType_test_TestType1_test + (self : testType_test_TestType1_t) : result bool = + Return (self._0 > 1) + +(** Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] *) +let testType_test_TestType1_TestType_test_TestTraitInst : + testType_test_TestTrait_t testType_test_TestType1_t = { + test = testType_test_TestType1_test; +} + +(** [traits::TestType::{6}::test]: forward function *) +let testType_test + (t : Type0) (inst : toU64_t t) (self : testType_t t) (x : t) : result bool = + let* x0 = inst.to_u64 x in + if x0 > 0 then testType_test_TestType1_test { _0 = 0 } else Return false + +(** [traits::BoolWrapper] *) +type boolWrapper_t = { _0 : bool; } + +(** [traits::BoolWrapper::{7}::to_type]: forward function *) +let boolWrapper_to_type + (t : Type0) (inst : toType_t bool t) (self : boolWrapper_t) : result t = + inst.to_type self._0 + +(** Trait implementation: [traits::BoolWrapper::{7}] *) +let boolWrapper_ToTypeInst (t : Type0) (inst : toType_t bool t) : toType_t + boolWrapper_t t = { + to_type = boolWrapper_to_type t inst; +} + +(** [traits::WithConstTy::LEN2] *) +let with_const_ty_len2_body : result usize = Return 32 +let with_const_ty_len2_c : usize = eval_global with_const_ty_len2_body + +(** Trait declaration: [traits::WithConstTy] *) +noeq type withConstTy_t (self : Type0) (len : usize) = { + cLEN1 : usize; + cLEN2 : usize; + tV : Type0; + tW : Type0; + tW_clause_0 : toU64_t tW; + f : tW -> array u8 len -> result tW; +} + +(** [traits::Bool::{8}::LEN1] *) +let bool_len1_body : result usize = Return 12 +let bool_len1_c : usize = eval_global bool_len1_body + +(** [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +let bool_f (i : u64) (a : array u8 32) : result u64 = + Return i + +(** Trait implementation: [traits::Bool::{8}] *) +let bool_WithConstTyInst : withConstTy_t bool 32 = { + cLEN1 = bool_len1_c; + cLEN2 = with_const_ty_len2_c; + tV = u8; + tW = u64; + tW_clause_0 = u64_ToU64Inst; + f = bool_f; +} + +(** [traits::use_with_const_ty1]: forward function *) +let use_with_const_ty1 + (h : Type0) (len : usize) (inst : withConstTy_t h len) : result usize = + let i = inst.cLEN1 in Return i + +(** [traits::use_with_const_ty2]: forward function *) +let use_with_const_ty2 + (h : Type0) (len : usize) (inst : withConstTy_t h len) (w : inst.tW) : + result unit + = + Return () + +(** [traits::use_with_const_ty3]: forward function *) +let use_with_const_ty3 + (h : Type0) (len : usize) (inst : withConstTy_t h len) (x : inst.tW) : + result u64 + = + inst.tW_clause_0.to_u64 x + +(** [traits::test_where1]: forward function *) +let test_where1 (t : Type0) (_x : t) : result unit = + Return () + +(** [traits::test_where2]: forward function *) +let test_where2 + (t : Type0) (inst : withConstTy_t t 32) (_x : u32) : result unit = + Return () + +(** [alloc::string::String] *) +assume type alloc_string_String_t : Type0 + +(** Trait declaration: [traits::ParentTrait0] *) +noeq type parentTrait0_t (self : Type0) = { + tW : Type0; + get_name : self -> result alloc_string_String_t; + get_w : self -> result tW; +} + +(** Trait declaration: [traits::ParentTrait1] *) +type parentTrait1_t (self : Type0) = unit + +(** Trait declaration: [traits::ChildTrait] *) +noeq type childTrait_t (self : Type0) = { + parent_clause_0 : parentTrait0_t self; + parent_clause_1 : parentTrait1_t self; +} + +(** [traits::test_child_trait1]: forward function *) +let test_child_trait1 + (t : Type0) (inst : childTrait_t t) (x : t) : result alloc_string_String_t = + inst.parent_clause_0.get_name x + +(** [traits::test_child_trait2]: forward function *) +let test_child_trait2 + (t : Type0) (inst : childTrait_t t) (x : t) : + result inst.parent_clause_0.tW + = + inst.parent_clause_0.get_w x + +(** [traits::order1]: forward function *) +let order1 + (t u : Type0) (inst : parentTrait0_t t) (inst0 : parentTrait0_t u) : + result unit + = + Return () + +(** Trait declaration: [traits::ChildTrait1] *) +noeq type childTrait1_t (self : Type0) = { + parent_clause_0 : parentTrait1_t self; +} + +(** Trait implementation: [traits::usize::{9}] *) +let usize_ParentTrait1Inst : parentTrait1_t usize = () + +(** Trait implementation: [traits::usize::{10}] *) +let usize_ChildTrait1Inst : childTrait1_t usize = { + parent_clause_0 = usize_ParentTrait1Inst; +} + +(** Trait declaration: [traits::Iterator] *) +noeq type iterator_t (self : Type0) = { tItem : Type0; } + +(** Trait declaration: [traits::IntoIterator] *) +noeq type intoIterator_t (self : Type0) = { + tItem : Type0; + tIntoIter : Type0; + tIntoIter_clause_0 : iterator_t tIntoIter; + into_iter : self -> result tIntoIter; +} + +(** Trait declaration: [traits::FromResidual] *) +type fromResidual_t (self t : Type0) = unit + +(** Trait declaration: [traits::Try] *) +noeq type try_t (self : Type0) = { + parent_clause_0 : fromResidual_t self tResidual; + tResidual : Type0; +} + +(** Trait declaration: [traits::CFnOnce] *) +noeq type cFnOnce_t (self args : Type0) = { + tOutput : Type0; + call_once : self -> args -> result tOutput; +} + +(** Trait declaration: [traits::CFnMut] *) +noeq type cFnMut_t (self args : Type0) = { + parent_clause_0 : cFnOnce_t self args; + call_mut : self -> args -> result parent_clause_0.tOutput; + call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; +} + +(** Trait declaration: [traits::CFn] *) +noeq type cFn_t (self args : Type0) = { + parent_clause_0 : cFnMut_t self args; + call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; +} + +(** Trait declaration: [core::ops::function::FnOnce] *) +noeq type core_ops_function_FnOnce_t (self args : Type0) = { + tOutput : Type0; + call_once : self -> args -> result tOutput; +} + +(** Trait declaration: [core::ops::function::FnMut] *) +noeq type core_ops_function_FnMut_t (self args : Type0) = { + parent_clause_0 : core_ops_function_FnOnce_t self args; + call_mut : self -> args -> result parent_clause_0.tOutput; + call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; +} + +(** Trait declaration: [core::ops::function::Fn] *) +noeq type core_ops_function_Fn_t (self args : Type0) = { + parent_clause_0 : core_ops_function_FnMut_t self args; + call : self -> args -> result parent_clause_0.parent_clause_0.tOutput; +} + +(** [traits::map_option]: forward function *) +let map_option + (t f0 : Type0) (inst : core_ops_function_Fn_t f0 t) (x : option t) + (f1 : f0) : + result (option t) + = + begin match x with + | None -> Return None + | Some x0 -> let* x1 = inst.call f1 x0 in Return (Some x1) + end + +(** Trait declaration: [traits::WithTarget] *) +noeq type withTarget_t (self : Type0) = { tTarget : Type0; } + +(** Trait declaration: [traits::ParentTrait2] *) +noeq type parentTrait2_t (self : Type0) = { + tU : Type0; + tU_clause_0 : withTarget_t tU; +} + +(** Trait declaration: [traits::ChildTrait2] *) +noeq type childTrait2_t (self : Type0) = { + parent_clause_0 : parentTrait2_t self; + convert : parent_clause_0.tU -> result parent_clause_0.tU_clause_0.tTarget; +} + +(** Trait implementation: [traits::u32::{11}] *) +let u32_WithTargetInst : withTarget_t u32 = { tTarget = u32; } + +(** Trait implementation: [traits::u32::{12}] *) +let u32_ParentTrait2Inst : parentTrait2_t u32 = { + tU = u32; + tU_clause_0 = u32_WithTargetInst; +} + +(** [traits::u32::{13}::convert]: forward function *) +let u32_convert (x : u32) : result u32 = + Return x + +(** Trait implementation: [traits::u32::{13}] *) +let u32_ChildTrait2Inst : childTrait2_t u32 = { + parent_clause_0 = u32_ParentTrait2Inst; + convert = u32_convert; +} + +(** [traits::incr_u32]: forward function *) +let incr_u32 (x : u32) : result u32 = + u32_add x 1 + -- 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(-) 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 38a01551719d0cefdd4a1c21a050674154b0b087 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 13:44:03 +0100 Subject: Regenerate the tests --- tests/fstar/traits/Traits.fst | 70 +++++++++++++------------------------------ tests/lean/Traits.lean | 61 +++++++++++-------------------------- 2 files changed, 37 insertions(+), 94 deletions(-) diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 42b43cf2..318efa2b 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -308,59 +308,10 @@ type fromResidual_t (self t : Type0) = unit (** Trait declaration: [traits::Try] *) noeq type try_t (self : Type0) = { - parent_clause_0 : fromResidual_t self tResidual; tResidual : Type0; + parent_clause_0 : fromResidual_t self tResidual; } -(** Trait declaration: [traits::CFnOnce] *) -noeq type cFnOnce_t (self args : Type0) = { - tOutput : Type0; - call_once : self -> args -> result tOutput; -} - -(** Trait declaration: [traits::CFnMut] *) -noeq type cFnMut_t (self args : Type0) = { - parent_clause_0 : cFnOnce_t self args; - call_mut : self -> args -> result parent_clause_0.tOutput; - call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; -} - -(** Trait declaration: [traits::CFn] *) -noeq type cFn_t (self args : Type0) = { - parent_clause_0 : cFnMut_t self args; - call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; -} - -(** Trait declaration: [core::ops::function::FnOnce] *) -noeq type core_ops_function_FnOnce_t (self args : Type0) = { - tOutput : Type0; - call_once : self -> args -> result tOutput; -} - -(** Trait declaration: [core::ops::function::FnMut] *) -noeq type core_ops_function_FnMut_t (self args : Type0) = { - parent_clause_0 : core_ops_function_FnOnce_t self args; - call_mut : self -> args -> result parent_clause_0.tOutput; - call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; -} - -(** Trait declaration: [core::ops::function::Fn] *) -noeq type core_ops_function_Fn_t (self args : Type0) = { - parent_clause_0 : core_ops_function_FnMut_t self args; - call : self -> args -> result parent_clause_0.parent_clause_0.tOutput; -} - -(** [traits::map_option]: forward function *) -let map_option - (t f0 : Type0) (inst : core_ops_function_Fn_t f0 t) (x : option t) - (f1 : f0) : - result (option t) - = - begin match x with - | None -> Return None - | Some x0 -> let* x1 = inst.call f1 x0 in Return (Some x1) - end - (** Trait declaration: [traits::WithTarget] *) noeq type withTarget_t (self : Type0) = { tTarget : Type0; } @@ -399,3 +350,22 @@ let u32_ChildTrait2Inst : childTrait2_t u32 = { let incr_u32 (x : u32) : result u32 = u32_add x 1 +(** Trait declaration: [traits::CFnOnce] *) +noeq type cFnOnce_t (self args : Type0) = { + tOutput : Type0; + call_once : self -> args -> result tOutput; +} + +(** Trait declaration: [traits::CFnMut] *) +noeq type cFnMut_t (self args : Type0) = { + parent_clause_0 : cFnOnce_t self args; + call_mut : self -> args -> result parent_clause_0.tOutput; + call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; +} + +(** Trait declaration: [traits::CFn] *) +noeq type cFn_t (self args : Type0) = { + parent_clause_0 : cFnMut_t self args; + call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; +} + diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index 94ae0bb0..12e7eafa 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -322,51 +322,8 @@ structure FromResidual (Self T : Type) where /- Trait declaration: [traits::Try] -/ structure Try (Self : Type) where - parent_clause_0 : FromResidual Self Residual Residual : Type - -/- Trait declaration: [traits::CFnOnce] -/ -structure CFnOnce (Self Args : Type) where - Output : Type - call_once : Self → Args → Result Output - -/- Trait declaration: [traits::CFnMut] -/ -structure CFnMut (Self Args : Type) where - parent_clause_0 : CFnOnce Self Args - call_mut : Self → Args → Result parent_clause_0.Output - call_mut_back : Self → Args → parent_clause_0.Output → Result Self - -/- Trait declaration: [traits::CFn] -/ -structure CFn (Self Args : Type) where - parent_clause_0 : CFnMut Self Args - call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output - -/- Trait declaration: [core::ops::function::FnOnce] -/ -structure core.ops.function.FnOnce (Self Args : Type) where - Output : Type - call_once : Self → Args → Result Output - -/- Trait declaration: [core::ops::function::FnMut] -/ -structure core.ops.function.FnMut (Self Args : Type) where - parent_clause_0 : core.ops.function.FnOnce Self Args - call_mut : Self → Args → Result parent_clause_0.Output - call_mut_back : Self → Args → parent_clause_0.Output → Result Self - -/- Trait declaration: [core::ops::function::Fn] -/ -structure core.ops.function.Fn (Self Args : Type) where - parent_clause_0 : core.ops.function.FnMut Self Args - call : Self → Args → Result parent_clause_0.parent_clause_0.Output - -/- [traits::map_option]: forward function -/ -def map_option - (T F : Type) (inst : core.ops.function.Fn F T) (x : Option T) (f0 : F) : - Result (Option T) - := - match x with - | none => Result.ret none - | some x0 => do - let t ← inst.call f0 x0 - Result.ret (some t) + parent_clause_0 : FromResidual Self Residual /- Trait declaration: [traits::WithTarget] -/ structure WithTarget (Self : Type) where @@ -407,4 +364,20 @@ def u32.ChildTrait2Inst : ChildTrait2 U32 := { def incr_u32 (x : U32) : Result U32 := x + 1#u32 +/- Trait declaration: [traits::CFnOnce] -/ +structure CFnOnce (Self Args : Type) where + Output : Type + call_once : Self → Args → Result Output + +/- Trait declaration: [traits::CFnMut] -/ +structure CFnMut (Self Args : Type) where + parent_clause_0 : CFnOnce Self Args + call_mut : Self → Args → Result parent_clause_0.Output + call_mut_back : Self → Args → parent_clause_0.Output → Result Self + +/- Trait declaration: [traits::CFn] -/ +structure CFn (Self Args : Type) where + parent_clause_0 : CFnMut Self Args + call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output + end traits -- cgit v1.2.3 From 7853ddf29773d42d41df7a915e1d19c9cfd98ac7 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 13:52:31 +0100 Subject: Update the Makefile for the F* array test --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 19992442..78ddb87c 100644 --- a/Makefile +++ b/Makefile @@ -125,7 +125,7 @@ thol4-paper: SUBDIR := misc-paper test-array: OPTIONS += test-array: SUBDIR := array -tfstar-array: OPTIONS += -decreases-clauses -template-clauses +tfstar-array: OPTIONS += -decreases-clauses -template-clauses -split-files tcoq-array: OPTIONS += -use-fuel tlean-array: SUBDIR := tlean-array: OPTIONS += -- cgit v1.2.3 From eec2643daad40d3ceec51cd83eb01e7c9db1824d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 14:17:51 +0100 Subject: Remove a file --- tests/fstar/array/Array.fst | 387 -------------------------------------------- 1 file changed, 387 deletions(-) delete mode 100644 tests/fstar/array/Array.fst diff --git a/tests/fstar/array/Array.fst b/tests/fstar/array/Array.fst deleted file mode 100644 index 341f5239..00000000 --- a/tests/fstar/array/Array.fst +++ /dev/null @@ -1,387 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [array] *) -module Array -open Primitives - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [array::AB] *) -type aB_t = | AB_A : aB_t | AB_B : aB_t - -(** [array::incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -let incr (x : u32) : result u32 = - u32_add x 1 - -(** [array::array_to_shared_slice_]: forward function *) -let array_to_shared_slice_ (t : Type0) (s : array t 32) : result (slice t) = - array_to_slice t 32 s - -(** [array::array_to_mut_slice_]: forward function *) -let array_to_mut_slice_ (t : Type0) (s : array t 32) : result (slice t) = - array_to_slice t 32 s - -(** [array::array_to_mut_slice_]: backward function 0 *) -let array_to_mut_slice__back - (t : Type0) (s : array t 32) (ret : slice t) : result (array t 32) = - array_from_slice t 32 s ret - -(** [array::array_len]: forward function *) -let array_len (t : Type0) (s : array t 32) : result usize = - let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i - -(** [array::shared_array_len]: forward function *) -let shared_array_len (t : Type0) (s : array t 32) : result usize = - let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i - -(** [array::shared_slice_len]: forward function *) -let shared_slice_len (t : Type0) (s : slice t) : result usize = - let i = slice_len t s in Return i - -(** [array::index_array_shared]: forward function *) -let index_array_shared (t : Type0) (s : array t 32) (i : usize) : result t = - array_index_usize t 32 s i - -(** [array::index_array_u32]: forward function *) -let index_array_u32 (s : array u32 32) (i : usize) : result u32 = - array_index_usize u32 32 s i - -(** [array::index_array_copy]: forward function *) -let index_array_copy (x : array u32 32) : result u32 = - array_index_usize u32 32 x 0 - -(** [array::index_mut_array]: forward function *) -let index_mut_array (t : Type0) (s : array t 32) (i : usize) : result t = - array_index_usize t 32 s i - -(** [array::index_mut_array]: backward function 0 *) -let index_mut_array_back - (t : Type0) (s : array t 32) (i : usize) (ret : t) : result (array t 32) = - array_update_usize t 32 s i ret - -(** [array::index_slice]: forward function *) -let index_slice (t : Type0) (s : slice t) (i : usize) : result t = - slice_index_usize t s i - -(** [array::index_mut_slice]: forward function *) -let index_mut_slice (t : Type0) (s : slice t) (i : usize) : result t = - slice_index_usize t s i - -(** [array::index_mut_slice]: backward function 0 *) -let index_mut_slice_back - (t : Type0) (s : slice t) (i : usize) (ret : t) : result (slice t) = - slice_update_usize t s i ret - -(** [array::slice_subslice_shared_]: forward function *) -let slice_subslice_shared_ - (x : slice u32) (y : usize) (z : usize) : result (slice u32) = - core_slice_index_Slice_index u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x - { start = y; end_ = z } - -(** [array::slice_subslice_mut_]: forward function *) -let slice_subslice_mut_ - (x : slice u32) (y : usize) (z : usize) : result (slice u32) = - core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x - { start = y; end_ = z } - -(** [array::slice_subslice_mut_]: backward function 0 *) -let slice_subslice_mut__back - (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : - result (slice u32) - = - core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x - { start = y; end_ = z } ret - -(** [array::array_to_slice_shared_]: forward function *) -let array_to_slice_shared_ (x : array u32 32) : result (slice u32) = - array_to_slice u32 32 x - -(** [array::array_to_slice_mut_]: forward function *) -let array_to_slice_mut_ (x : array u32 32) : result (slice u32) = - array_to_slice u32 32 x - -(** [array::array_to_slice_mut_]: backward function 0 *) -let array_to_slice_mut__back - (x : array u32 32) (ret : slice u32) : result (array u32 32) = - array_from_slice u32 32 x ret - -(** [array::array_subslice_shared_]: forward function *) -let array_subslice_shared_ - (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - core_array_Array_index u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - { start = y; end_ = z } - -(** [array::array_subslice_mut_]: forward function *) -let array_subslice_mut_ - (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - core_array_Array_index_mut u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - { start = y; end_ = z } - -(** [array::array_subslice_mut_]: backward function 0 *) -let array_subslice_mut__back - (x : array u32 32) (y : usize) (z : usize) (ret : slice u32) : - result (array u32 32) - = - core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - { start = y; end_ = z } ret - -(** [array::index_slice_0]: forward function *) -let index_slice_0 (t : Type0) (s : slice t) : result t = - slice_index_usize t s 0 - -(** [array::index_array_0]: forward function *) -let index_array_0 (t : Type0) (s : array t 32) : result t = - array_index_usize t 32 s 0 - -(** [array::index_index_array]: forward function *) -let index_index_array - (s : array (array u32 32) 32) (i : usize) (j : usize) : result u32 = - let* a = array_index_usize (array u32 32) 32 s i in - array_index_usize u32 32 a j - -(** [array::update_update_array]: forward function *) -let update_update_array - (s : array (array u32 32) 32) (i : usize) (j : usize) : result unit = - let* a = array_index_usize (array u32 32) 32 s i in - let* a0 = array_update_usize u32 32 a j 0 in - let* _ = array_update_usize (array u32 32) 32 s i a0 in - Return () - -(** [array::array_local_deep_copy]: forward function *) -let array_local_deep_copy (x : array u32 32) : result unit = - Return () - -(** [array::take_array]: forward function *) -let take_array (a : array u32 2) : result unit = - Return () - -(** [array::take_array_borrow]: forward function *) -let take_array_borrow (a : array u32 2) : result unit = - Return () - -(** [array::take_slice]: forward function *) -let take_slice (s : slice u32) : result unit = - Return () - -(** [array::take_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -let take_mut_slice (s : slice u32) : result (slice u32) = - Return s - -(** [array::take_all]: forward function *) -let take_all : result unit = - let* _ = take_array (mk_array u32 2 [ 0; 0 ]) in - let* _ = take_array_borrow (mk_array u32 2 [ 0; 0 ]) in - let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* _ = take_slice s in - let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s1 = take_mut_slice s0 in - let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in - Return () - -(** [array::index_array]: forward function *) -let index_array (x : array u32 2) : result u32 = - array_index_usize u32 2 x 0 - -(** [array::index_array_borrow]: forward function *) -let index_array_borrow (x : array u32 2) : result u32 = - array_index_usize u32 2 x 0 - -(** [array::index_slice_u32_0]: forward function *) -let index_slice_u32_0 (x : slice u32) : result u32 = - slice_index_usize u32 x 0 - -(** [array::index_mut_slice_u32_0]: forward function *) -let index_mut_slice_u32_0 (x : slice u32) : result u32 = - slice_index_usize u32 x 0 - -(** [array::index_mut_slice_u32_0]: backward function 0 *) -let index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) = - let* _ = slice_index_usize u32 x 0 in Return x - -(** [array::index_all]: forward function *) -let index_all : result u32 = - let* i = index_array (mk_array u32 2 [ 0; 0 ]) in - let* i0 = index_array (mk_array u32 2 [ 0; 0 ]) in - let* i1 = u32_add i i0 in - let* i2 = index_array_borrow (mk_array u32 2 [ 0; 0 ]) in - let* i3 = u32_add i1 i2 in - let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* i4 = index_slice_u32_0 s in - let* i5 = u32_add i3 i4 in - let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* i6 = index_mut_slice_u32_0 s0 in - let* i7 = u32_add i5 i6 in - let* s1 = index_mut_slice_u32_0_back s0 in - let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in - Return i7 - -(** [array::update_array]: forward function *) -let update_array (x : array u32 2) : result unit = - let* _ = array_update_usize u32 2 x 0 1 in Return () - -(** [array::update_array_mut_borrow]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -let update_array_mut_borrow (x : array u32 2) : result (array u32 2) = - array_update_usize u32 2 x 0 1 - -(** [array::update_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -let update_mut_slice (x : slice u32) : result (slice u32) = - slice_update_usize u32 x 0 1 - -(** [array::update_all]: forward function *) -let update_all : result unit = - let* _ = update_array (mk_array u32 2 [ 0; 0 ]) in - let* x = update_array_mut_borrow (mk_array u32 2 [ 0; 0 ]) in - let* s = array_to_slice u32 2 x in - let* s0 = update_mut_slice s in - let* _ = array_from_slice u32 2 x s0 in - Return () - -(** [array::range_all]: forward function *) -let range_all : result unit = - let* s = - core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) - (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } in - let* s0 = update_mut_slice s in - let* _ = - core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) - (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } s0 in - Return () - -(** [array::deref_array_borrow]: forward function *) -let deref_array_borrow (x : array u32 2) : result u32 = - array_index_usize u32 2 x 0 - -(** [array::deref_array_mut_borrow]: forward function *) -let deref_array_mut_borrow (x : array u32 2) : result u32 = - array_index_usize u32 2 x 0 - -(** [array::deref_array_mut_borrow]: backward function 0 *) -let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = - let* _ = array_index_usize u32 2 x 0 in Return x - -(** [array::take_array_t]: forward function *) -let take_array_t (a : array aB_t 2) : result unit = - Return () - -(** [array::non_copyable_array]: forward function *) -let non_copyable_array : result unit = - let* _ = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) in Return () - -(** [array::sum]: decreases clause *) -unfold -let sum_loop_decreases (s : slice u32) (sum0 : u32) (i : usize) : nat = - admit () - -(** [array::sum]: loop 0: forward function *) -let rec sum_loop - (s : slice u32) (sum0 : u32) (i : usize) : - Tot (result u32) (decreases (sum_loop_decreases s sum0 i)) - = - let i0 = slice_len u32 s in - if i < i0 - then - let* i1 = slice_index_usize u32 s i in - let* sum1 = u32_add sum0 i1 in - let* i2 = usize_add i 1 in - sum_loop s sum1 i2 - else Return sum0 - -(** [array::sum]: forward function *) -let sum (s : slice u32) : result u32 = - sum_loop s 0 0 - -(** [array::sum2]: decreases clause *) -unfold -let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum0 : u32) - (i : usize) : nat = - admit () - -(** [array::sum2]: loop 0: forward function *) -let rec sum2_loop - (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : - Tot (result u32) (decreases (sum2_loop_decreases s s2 sum0 i)) - = - let i0 = slice_len u32 s in - if i < i0 - then - let* i1 = slice_index_usize u32 s i in - let* i2 = slice_index_usize u32 s2 i in - let* i3 = u32_add i1 i2 in - let* sum1 = u32_add sum0 i3 in - let* i4 = usize_add i 1 in - sum2_loop s s2 sum1 i4 - else Return sum0 - -(** [array::sum2]: forward function *) -let sum2 (s : slice u32) (s2 : slice u32) : result u32 = - let i = slice_len u32 s in - let i0 = slice_len u32 s2 in - if not (i = i0) then Fail Failure else sum2_loop s s2 0 0 - -(** [array::f0]: forward function *) -let f0 : result unit = - let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in - let* s0 = slice_update_usize u32 s 0 1 in - let* _ = array_from_slice u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in - Return () - -(** [array::f1]: forward function *) -let f1 : result unit = - let* _ = array_update_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in Return () - -(** [array::f2]: forward function *) -let f2 (i : u32) : result unit = - Return () - -(** [array::f4]: forward function *) -let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = - core_array_Array_index u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - { start = y; end_ = z } - -(** [array::f3]: forward function *) -let f3 : result u32 = - let* i = array_index_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in - let* _ = f2 i in - let b = array_repeat u32 32 0 in - let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in - let* s0 = f4 b 16 18 in - sum2 s s0 - -(** [array::SZ] *) -let sz_body : result usize = Return 32 -let sz_c : usize = eval_global sz_body - -(** [array::f5]: forward function *) -let f5 (x : array u32 32) : result u32 = - array_index_usize u32 32 x 0 - -(** [array::ite]: forward function *) -let ite : result unit = - let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in - let* s1 = index_mut_slice_u32_0_back s0 in - let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in - let* s2 = index_mut_slice_u32_0_back s in - let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s2 in - Return () - -- cgit v1.2.3 From 9157959cc421c481cf584ada69f51d58da82e8f9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 14:22:06 +0100 Subject: Deactivate the HOL4 tests --- Makefile | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 78ddb87c..b67bd08b 100644 --- a/Makefile +++ b/Makefile @@ -290,17 +290,25 @@ tleanp-%: BACKEND_SUBDIR := lean tleanp-%: $(AENEAS_CMD) +# TODO: reactivate HOL4 once traits are parameterized by their associated types .PHONY: thol4-% thol4-%: OPTIONS += -backend hol4 thol4-%: BACKEND_SUBDIR := hol4 thol4-%: - $(AENEAS_CMD) + echo Ignoring the $* test for HOL4 + +#thol4-%: +# $(AENEAS_CMD) +# TODO: reactivate HOL4 once traits are parameterized by their associated types .PHONY: thol4p-% thol4p-%: OPTIONS += -backend hol4 thol4p-%: BACKEND_SUBDIR := hol4 thol4p-%: - $(AENEAS_CMD) + echo Ignoring the $* test for HOL4 + +#thol4p-%: +# $(AENEAS_CMD) # Nix - TODO: add the lean tests .PHONY: nix -- 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 --- Makefile | 2 +- compiler/Extract.ml | 391 +++++++++++++++++++++++++++++---------------- compiler/ExtractBase.ml | 8 + compiler/ExtractBuiltin.ml | 12 +- compiler/ExtractTypes.ml | 106 +++++++----- compiler/FunsAnalysis.ml | 7 +- compiler/Translate.ml | 22 ++- 7 files changed, 354 insertions(+), 194 deletions(-) diff --git a/Makefile b/Makefile index b67bd08b..427a5751 100644 --- a/Makefile +++ b/Makefile @@ -134,7 +134,7 @@ thol4-array: OPTIONS += test-traits: OPTIONS += test-traits: SUBDIR := traits tfstar-traits: OPTIONS += -decreases-clauses -template-clauses -tcoq-traits: OPTIONS += -use-fuel +tcoq-traits: OPTIONS += tlean-traits: SUBDIR := tlean-traits: OPTIONS += thol4-traits: OPTIONS += 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 From 49ffc966cfdbd71f8c83a3c72ab81e1bb101f420 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 16:24:07 +0100 Subject: Regenerate the Coq test files --- tests/coq/array/Array.v | 470 +++++++++++++++ tests/coq/array/Array_Funs.v | 476 --------------- tests/coq/array/Array_Types.v | 14 - tests/coq/array/_CoqProject | 3 +- tests/coq/betree/BetreeMain_Types.v | 4 +- tests/coq/hashmap/Hashmap_Types.v | 14 +- tests/coq/hashmap_on_disk/HashmapMain_Types.v | 14 +- tests/coq/misc/Constants.v | 10 +- tests/coq/misc/Loops.v | 4 +- tests/coq/misc/NoNestedBorrows.v | 32 +- tests/coq/misc/Paper.v | 4 +- tests/coq/misc/PoloniusList.v | 4 +- tests/coq/traits/Primitives.v | 822 ++++++++++++++++++++++++++ tests/coq/traits/Traits.v | 520 ++++++++++++++++ tests/coq/traits/_CoqProject | 2 + 15 files changed, 1858 insertions(+), 535 deletions(-) create mode 100644 tests/coq/array/Array.v delete mode 100644 tests/coq/array/Array_Funs.v delete mode 100644 tests/coq/array/Array_Types.v create mode 100644 tests/coq/traits/Primitives.v create mode 100644 tests/coq/traits/Traits.v diff --git a/tests/coq/array/Array.v b/tests/coq/array/Array.v new file mode 100644 index 00000000..825f73e0 --- /dev/null +++ b/tests/coq/array/Array.v @@ -0,0 +1,470 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [array] *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module Array. + +(** [array::AB] *) +Inductive AB_t := | AB_A : AB_t | AB_B : AB_t. + +(** [array::incr]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition incr (x : u32) : result u32 := + u32_add x 1%u32. + +(** [array::array_to_shared_slice_]: forward function *) +Definition array_to_shared_slice_ + (T : Type) (s : array T 32%usize) : result (slice T) := + array_to_slice T 32%usize s +. + +(** [array::array_to_mut_slice_]: forward function *) +Definition array_to_mut_slice_ + (T : Type) (s : array T 32%usize) : result (slice T) := + array_to_slice T 32%usize s +. + +(** [array::array_to_mut_slice_]: backward function 0 *) +Definition array_to_mut_slice__back + (T : Type) (s : array T 32%usize) (ret : slice T) : + result (array T 32%usize) + := + array_from_slice T 32%usize s ret +. + +(** [array::array_len]: forward function *) +Definition array_len (T : Type) (s : array T 32%usize) : result usize := + s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i +. + +(** [array::shared_array_len]: forward function *) +Definition shared_array_len (T : Type) (s : array T 32%usize) : result usize := + s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i +. + +(** [array::shared_slice_len]: forward function *) +Definition shared_slice_len (T : Type) (s : slice T) : result usize := + let i := slice_len T s in Return i +. + +(** [array::index_array_shared]: forward function *) +Definition index_array_shared + (T : Type) (s : array T 32%usize) (i : usize) : result T := + array_index_usize T 32%usize s i +. + +(** [array::index_array_u32]: forward function *) +Definition index_array_u32 (s : array u32 32%usize) (i : usize) : result u32 := + array_index_usize u32 32%usize s i +. + +(** [array::index_array_copy]: forward function *) +Definition index_array_copy (x : array u32 32%usize) : result u32 := + array_index_usize u32 32%usize x 0%usize +. + +(** [array::index_mut_array]: forward function *) +Definition index_mut_array + (T : Type) (s : array T 32%usize) (i : usize) : result T := + array_index_usize T 32%usize s i +. + +(** [array::index_mut_array]: backward function 0 *) +Definition index_mut_array_back + (T : Type) (s : array T 32%usize) (i : usize) (ret : T) : + result (array T 32%usize) + := + array_update_usize T 32%usize s i ret +. + +(** [array::index_slice]: forward function *) +Definition index_slice (T : Type) (s : slice T) (i : usize) : result T := + slice_index_usize T s i +. + +(** [array::index_mut_slice]: forward function *) +Definition index_mut_slice (T : Type) (s : slice T) (i : usize) : result T := + slice_index_usize T s i +. + +(** [array::index_mut_slice]: backward function 0 *) +Definition index_mut_slice_back + (T : Type) (s : slice T) (i : usize) (ret : T) : result (slice T) := + slice_update_usize T s i ret +. + +(** [array::slice_subslice_shared_]: forward function *) +Definition slice_subslice_shared_ + (x : slice u32) (y : usize) (z : usize) : result (slice u32) := + core_slice_index_Slice_index u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::slice_subslice_mut_]: forward function *) +Definition slice_subslice_mut_ + (x : slice u32) (y : usize) (z : usize) : result (slice u32) := + core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::slice_subslice_mut_]: backward function 0 *) +Definition slice_subslice_mut__back + (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : + result (slice u32) + := + core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret +. + +(** [array::array_to_slice_shared_]: forward function *) +Definition array_to_slice_shared_ + (x : array u32 32%usize) : result (slice u32) := + array_to_slice u32 32%usize x +. + +(** [array::array_to_slice_mut_]: forward function *) +Definition array_to_slice_mut_ (x : array u32 32%usize) : result (slice u32) := + array_to_slice u32 32%usize x +. + +(** [array::array_to_slice_mut_]: backward function 0 *) +Definition array_to_slice_mut__back + (x : array u32 32%usize) (ret : slice u32) : result (array u32 32%usize) := + array_from_slice u32 32%usize x ret +. + +(** [array::array_subslice_shared_]: forward function *) +Definition array_subslice_shared_ + (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := + core_array_Array_index u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::array_subslice_mut_]: forward function *) +Definition array_subslice_mut_ + (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := + core_array_Array_index_mut u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::array_subslice_mut_]: backward function 0 *) +Definition array_subslice_mut__back + (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) : + result (array u32 32%usize) + := + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret +. + +(** [array::index_slice_0]: forward function *) +Definition index_slice_0 (T : Type) (s : slice T) : result T := + slice_index_usize T s 0%usize +. + +(** [array::index_array_0]: forward function *) +Definition index_array_0 (T : Type) (s : array T 32%usize) : result T := + array_index_usize T 32%usize s 0%usize +. + +(** [array::index_index_array]: forward function *) +Definition index_index_array + (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : + result u32 + := + a <- array_index_usize (array u32 32%usize) 32%usize s i; + array_index_usize u32 32%usize a j +. + +(** [array::update_update_array]: forward function *) +Definition update_update_array + (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : + result unit + := + a <- array_index_usize (array u32 32%usize) 32%usize s i; + a0 <- array_update_usize u32 32%usize a j 0%u32; + _ <- array_update_usize (array u32 32%usize) 32%usize s i a0; + Return tt +. + +(** [array::array_local_deep_copy]: forward function *) +Definition array_local_deep_copy (x : array u32 32%usize) : result unit := + Return tt +. + +(** [array::take_array]: forward function *) +Definition take_array (a : array u32 2%usize) : result unit := + Return tt. + +(** [array::take_array_borrow]: forward function *) +Definition take_array_borrow (a : array u32 2%usize) : result unit := + Return tt +. + +(** [array::take_slice]: forward function *) +Definition take_slice (s : slice u32) : result unit := + Return tt. + +(** [array::take_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition take_mut_slice (s : slice u32) : result (slice u32) := + Return s. + +(** [array::take_all]: forward function *) +Definition take_all : result unit := + _ <- take_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + _ <- take_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + _ <- take_slice s; + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s1 <- take_mut_slice s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; + Return tt +. + +(** [array::index_array]: forward function *) +Definition index_array (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::index_array_borrow]: forward function *) +Definition index_array_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::index_slice_u32_0]: forward function *) +Definition index_slice_u32_0 (x : slice u32) : result u32 := + slice_index_usize u32 x 0%usize +. + +(** [array::index_mut_slice_u32_0]: forward function *) +Definition index_mut_slice_u32_0 (x : slice u32) : result u32 := + slice_index_usize u32 x 0%usize +. + +(** [array::index_mut_slice_u32_0]: backward function 0 *) +Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := + _ <- slice_index_usize u32 x 0%usize; Return x +. + +(** [array::index_all]: forward function *) +Definition index_all : result u32 := + i <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i0 <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i1 <- u32_add i i0; + i2 <- index_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i3 <- u32_add i1 i2; + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i4 <- index_slice_u32_0 s; + i5 <- u32_add i3 i4; + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + i6 <- index_mut_slice_u32_0 s0; + i7 <- u32_add i5 i6; + s1 <- index_mut_slice_u32_0_back s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; + Return i7 +. + +(** [array::update_array]: forward function *) +Definition update_array (x : array u32 2%usize) : result unit := + _ <- array_update_usize u32 2%usize x 0%usize 1%u32; Return tt +. + +(** [array::update_array_mut_borrow]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition update_array_mut_borrow + (x : array u32 2%usize) : result (array u32 2%usize) := + array_update_usize u32 2%usize x 0%usize 1%u32 +. + +(** [array::update_mut_slice]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition update_mut_slice (x : slice u32) : result (slice u32) := + slice_update_usize u32 x 0%usize 1%u32 +. + +(** [array::update_all]: forward function *) +Definition update_all : result unit := + _ <- update_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + x <- update_array_mut_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s <- array_to_slice u32 2%usize x; + s0 <- update_mut_slice s; + _ <- array_from_slice u32 2%usize x s0; + Return tt +. + +(** [array::range_all]: forward function *) +Definition range_all : result unit := + s <- + core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) + {| + core_ops_range_Range_start := 1%usize; + core_ops_range_Range_end_ := 3%usize + |}; + s0 <- update_mut_slice s; + _ <- + core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4%usize + (core_slice_index_Slice_coreopsindexIndexMutInst u32 + (core_ops_range_Range usize) + (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) + {| + core_ops_range_Range_start := 1%usize; + core_ops_range_Range_end_ := 3%usize + |} s0; + Return tt +. + +(** [array::deref_array_borrow]: forward function *) +Definition deref_array_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::deref_array_mut_borrow]: forward function *) +Definition deref_array_mut_borrow (x : array u32 2%usize) : result u32 := + array_index_usize u32 2%usize x 0%usize +. + +(** [array::deref_array_mut_borrow]: backward function 0 *) +Definition deref_array_mut_borrow_back + (x : array u32 2%usize) : result (array u32 2%usize) := + _ <- array_index_usize u32 2%usize x 0%usize; Return x +. + +(** [array::take_array_t]: forward function *) +Definition take_array_t (a : array AB_t 2%usize) : result unit := + Return tt. + +(** [array::non_copyable_array]: forward function *) +Definition non_copyable_array : result unit := + _ <- take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]); Return tt +. + +(** [array::sum]: loop 0: forward function *) +Fixpoint sum_loop + (n : nat) (s : slice u32) (sum0 : u32) (i : usize) : result u32 := + match n with + | O => Fail_ OutOfFuel + | S n0 => + let i0 := slice_len u32 s in + if i s< i0 + then ( + i1 <- slice_index_usize u32 s i; + sum1 <- u32_add sum0 i1; + i2 <- usize_add i 1%usize; + sum_loop n0 s sum1 i2) + else Return sum0 + end +. + +(** [array::sum]: forward function *) +Definition sum (n : nat) (s : slice u32) : result u32 := + sum_loop n s 0%u32 0%usize +. + +(** [array::sum2]: loop 0: forward function *) +Fixpoint sum2_loop + (n : nat) (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : + result u32 + := + match n with + | O => Fail_ OutOfFuel + | S n0 => + let i0 := slice_len u32 s in + if i s< i0 + then ( + i1 <- slice_index_usize u32 s i; + i2 <- slice_index_usize u32 s2 i; + i3 <- u32_add i1 i2; + sum1 <- u32_add sum0 i3; + i4 <- usize_add i 1%usize; + sum2_loop n0 s s2 sum1 i4) + else Return sum0 + end +. + +(** [array::sum2]: forward function *) +Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := + let i := slice_len u32 s in + let i0 := slice_len u32 s2 in + if negb (i s= i0) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize +. + +(** [array::f0]: forward function *) +Definition f0 : result unit := + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); + s0 <- slice_update_usize u32 s 0%usize 1%u32; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) s0; + Return tt +. + +(** [array::f1]: forward function *) +Definition f1 : result unit := + _ <- + array_update_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) + 0%usize 1%u32; + Return tt +. + +(** [array::f2]: forward function *) +Definition f2 (i : u32) : result unit := + Return tt. + +(** [array::f4]: forward function *) +Definition f4 + (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := + core_array_Array_index u32 (core_ops_range_Range usize) 32%usize + (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range + usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} +. + +(** [array::f3]: forward function *) +Definition f3 (n : nat) : result u32 := + i <- + array_index_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) + 0%usize; + _ <- f2 i; + let b := array_repeat u32 32%usize 0%u32 in + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); + s0 <- f4 b 16%usize 18%usize; + sum2 n s s0 +. + +(** [array::SZ] *) +Definition sz_body : result usize := Return 32%usize. +Definition sz_c : usize := sz_body%global. + +(** [array::f5]: forward function *) +Definition f5 (x : array u32 32%usize) : result u32 := + array_index_usize u32 32%usize x 0%usize +. + +(** [array::ite]: forward function *) +Definition ite : result unit := + s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + s1 <- index_mut_slice_u32_0_back s0; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; + s2 <- index_mut_slice_u32_0_back s; + _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s2; + Return tt +. + +End Array . diff --git a/tests/coq/array/Array_Funs.v b/tests/coq/array/Array_Funs.v deleted file mode 100644 index 9980a6e8..00000000 --- a/tests/coq/array/Array_Funs.v +++ /dev/null @@ -1,476 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [array]: function definitions *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Require Export Array_Types. -Import Array_Types. -Module Array_Funs. - -(** [array::incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition incr (x : u32) : result u32 := - u32_add x 1%u32. - -(** [array::array_to_shared_slice_]: forward function *) -Definition array_to_shared_slice_ - (T : Type) (s : array T 32%usize) : result (slice T) := - array_to_slice T 32%usize s -. - -(** [array::array_to_mut_slice_]: forward function *) -Definition array_to_mut_slice_ - (T : Type) (s : array T 32%usize) : result (slice T) := - array_to_slice T 32%usize s -. - -(** [array::array_to_mut_slice_]: backward function 0 *) -Definition array_to_mut_slice__back - (T : Type) (s : array T 32%usize) (ret : slice T) : - result (array T 32%usize) - := - array_from_slice T 32%usize s ret -. - -(** [array::array_len]: forward function *) -Definition array_len (T : Type) (s : array T 32%usize) : result usize := - s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i -. - -(** [array::shared_array_len]: forward function *) -Definition shared_array_len (T : Type) (s : array T 32%usize) : result usize := - s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i -. - -(** [array::shared_slice_len]: forward function *) -Definition shared_slice_len (T : Type) (s : slice T) : result usize := - let i := slice_len T s in Return i -. - -(** [array::index_array_shared]: forward function *) -Definition index_array_shared - (T : Type) (s : array T 32%usize) (i : usize) : result T := - array_index_usize T 32%usize s i -. - -(** [array::index_array_u32]: forward function *) -Definition index_array_u32 (s : array u32 32%usize) (i : usize) : result u32 := - array_index_usize u32 32%usize s i -. - -(** [array::index_array_copy]: forward function *) -Definition index_array_copy (x : array u32 32%usize) : result u32 := - array_index_usize u32 32%usize x 0%usize -. - -(** [array::index_mut_array]: forward function *) -Definition index_mut_array - (T : Type) (s : array T 32%usize) (i : usize) : result T := - array_index_usize T 32%usize s i -. - -(** [array::index_mut_array]: backward function 0 *) -Definition index_mut_array_back - (T : Type) (s : array T 32%usize) (i : usize) (ret : T) : - result (array T 32%usize) - := - array_update_usize T 32%usize s i ret -. - -(** [array::index_slice]: forward function *) -Definition index_slice (T : Type) (s : slice T) (i : usize) : result T := - slice_index_usize T s i -. - -(** [array::index_mut_slice]: forward function *) -Definition index_mut_slice (T : Type) (s : slice T) (i : usize) : result T := - slice_index_usize T s i -. - -(** [array::index_mut_slice]: backward function 0 *) -Definition index_mut_slice_back - (T : Type) (s : slice T) (i : usize) (ret : T) : result (slice T) := - slice_update_usize T s i ret -. - -(** [array::slice_subslice_shared_]: forward function *) -Definition slice_subslice_shared_ - (n : nat) (x : slice u32) (y : usize) (z : usize) : result (slice u32) := - core_slice_index_Slice_index u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} -. - -(** [array::slice_subslice_mut_]: forward function *) -Definition slice_subslice_mut_ - (n : nat) (x : slice u32) (y : usize) (z : usize) : result (slice u32) := - core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} -. - -(** [array::slice_subslice_mut_]: backward function 0 *) -Definition slice_subslice_mut__back - (n : nat) (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : - result (slice u32) - := - core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret -. - -(** [array::array_to_slice_shared_]: forward function *) -Definition array_to_slice_shared_ - (x : array u32 32%usize) : result (slice u32) := - array_to_slice u32 32%usize x -. - -(** [array::array_to_slice_mut_]: forward function *) -Definition array_to_slice_mut_ (x : array u32 32%usize) : result (slice u32) := - array_to_slice u32 32%usize x -. - -(** [array::array_to_slice_mut_]: backward function 0 *) -Definition array_to_slice_mut__back - (x : array u32 32%usize) (ret : slice u32) : result (array u32 32%usize) := - array_from_slice u32 32%usize x ret -. - -(** [array::array_subslice_shared_]: forward function *) -Definition array_subslice_shared_ - (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) : - result (slice u32) - := - core_array_Array_index u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} -. - -(** [array::array_subslice_mut_]: forward function *) -Definition array_subslice_mut_ - (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) : - result (slice u32) - := - core_array_Array_index_mut u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} -. - -(** [array::array_subslice_mut_]: backward function 0 *) -Definition array_subslice_mut__back - (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) - : - result (array u32 32%usize) - := - core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret -. - -(** [array::index_slice_0]: forward function *) -Definition index_slice_0 (T : Type) (s : slice T) : result T := - slice_index_usize T s 0%usize -. - -(** [array::index_array_0]: forward function *) -Definition index_array_0 (T : Type) (s : array T 32%usize) : result T := - array_index_usize T 32%usize s 0%usize -. - -(** [array::index_index_array]: forward function *) -Definition index_index_array - (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : - result u32 - := - a <- array_index_usize (array u32 32%usize) 32%usize s i; - array_index_usize u32 32%usize a j -. - -(** [array::update_update_array]: forward function *) -Definition update_update_array - (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : - result unit - := - a <- array_index_usize (array u32 32%usize) 32%usize s i; - a0 <- array_update_usize u32 32%usize a j 0%u32; - _ <- array_update_usize (array u32 32%usize) 32%usize s i a0; - Return tt -. - -(** [array::array_local_deep_copy]: forward function *) -Definition array_local_deep_copy (x : array u32 32%usize) : result unit := - Return tt -. - -(** [array::take_array]: forward function *) -Definition take_array (a : array u32 2%usize) : result unit := - Return tt. - -(** [array::take_array_borrow]: forward function *) -Definition take_array_borrow (a : array u32 2%usize) : result unit := - Return tt -. - -(** [array::take_slice]: forward function *) -Definition take_slice (s : slice u32) : result unit := - Return tt. - -(** [array::take_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition take_mut_slice (s : slice u32) : result (slice u32) := - Return s. - -(** [array::take_all]: forward function *) -Definition take_all : result unit := - _ <- take_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - _ <- take_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - _ <- take_slice s; - s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s1 <- take_mut_slice s0; - _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; - Return tt -. - -(** [array::index_array]: forward function *) -Definition index_array (x : array u32 2%usize) : result u32 := - array_index_usize u32 2%usize x 0%usize -. - -(** [array::index_array_borrow]: forward function *) -Definition index_array_borrow (x : array u32 2%usize) : result u32 := - array_index_usize u32 2%usize x 0%usize -. - -(** [array::index_slice_u32_0]: forward function *) -Definition index_slice_u32_0 (x : slice u32) : result u32 := - slice_index_usize u32 x 0%usize -. - -(** [array::index_mut_slice_u32_0]: forward function *) -Definition index_mut_slice_u32_0 (x : slice u32) : result u32 := - slice_index_usize u32 x 0%usize -. - -(** [array::index_mut_slice_u32_0]: backward function 0 *) -Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := - _ <- slice_index_usize u32 x 0%usize; Return x -. - -(** [array::index_all]: forward function *) -Definition index_all : result u32 := - i <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i0 <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i1 <- u32_add i i0; - i2 <- index_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i3 <- u32_add i1 i2; - s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i4 <- index_slice_u32_0 s; - i5 <- u32_add i3 i4; - s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - i6 <- index_mut_slice_u32_0 s0; - i7 <- u32_add i5 i6; - s1 <- index_mut_slice_u32_0_back s0; - _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; - Return i7 -. - -(** [array::update_array]: forward function *) -Definition update_array (x : array u32 2%usize) : result unit := - _ <- array_update_usize u32 2%usize x 0%usize 1%u32; Return tt -. - -(** [array::update_array_mut_borrow]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition update_array_mut_borrow - (x : array u32 2%usize) : result (array u32 2%usize) := - array_update_usize u32 2%usize x 0%usize 1%u32 -. - -(** [array::update_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -Definition update_mut_slice (x : slice u32) : result (slice u32) := - slice_update_usize u32 x 0%usize 1%u32 -. - -(** [array::update_all]: forward function *) -Definition update_all : result unit := - _ <- update_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - x <- update_array_mut_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s <- array_to_slice u32 2%usize x; - s0 <- update_mut_slice s; - _ <- array_from_slice u32 2%usize x s0; - Return tt -. - -(** [array::range_all]: forward function *) -Definition range_all (n : nat) : result unit := - s <- - core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) - (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) - {| - core_ops_range_Range_start := 1%usize; - core_ops_range_Range_end_ := 3%usize - |}; - s0 <- update_mut_slice s; - _ <- - core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) - (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) - {| - core_ops_range_Range_start := 1%usize; - core_ops_range_Range_end_ := 3%usize - |} s0; - Return tt -. - -(** [array::deref_array_borrow]: forward function *) -Definition deref_array_borrow (x : array u32 2%usize) : result u32 := - array_index_usize u32 2%usize x 0%usize -. - -(** [array::deref_array_mut_borrow]: forward function *) -Definition deref_array_mut_borrow (x : array u32 2%usize) : result u32 := - array_index_usize u32 2%usize x 0%usize -. - -(** [array::deref_array_mut_borrow]: backward function 0 *) -Definition deref_array_mut_borrow_back - (x : array u32 2%usize) : result (array u32 2%usize) := - _ <- array_index_usize u32 2%usize x 0%usize; Return x -. - -(** [array::take_array_t]: forward function *) -Definition take_array_t (a : array AB_t 2%usize) : result unit := - Return tt. - -(** [array::non_copyable_array]: forward function *) -Definition non_copyable_array : result unit := - _ <- take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]); Return tt -. - -(** [array::sum]: loop 0: forward function *) -Fixpoint sum_loop - (n : nat) (s : slice u32) (sum0 : u32) (i : usize) : result u32 := - match n with - | O => Fail_ OutOfFuel - | S n0 => - let i0 := slice_len u32 s in - if i s< i0 - then ( - i1 <- slice_index_usize u32 s i; - sum1 <- u32_add sum0 i1; - i2 <- usize_add i 1%usize; - sum_loop n0 s sum1 i2) - else Return sum0 - end -. - -(** [array::sum]: forward function *) -Definition sum (n : nat) (s : slice u32) : result u32 := - sum_loop n s 0%u32 0%usize -. - -(** [array::sum2]: loop 0: forward function *) -Fixpoint sum2_loop - (n : nat) (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : - result u32 - := - match n with - | O => Fail_ OutOfFuel - | S n0 => - let i0 := slice_len u32 s in - if i s< i0 - then ( - i1 <- slice_index_usize u32 s i; - i2 <- slice_index_usize u32 s2 i; - i3 <- u32_add i1 i2; - sum1 <- u32_add sum0 i3; - i4 <- usize_add i 1%usize; - sum2_loop n0 s s2 sum1 i4) - else Return sum0 - end -. - -(** [array::sum2]: forward function *) -Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := - let i := slice_len u32 s in - let i0 := slice_len u32 s2 in - if negb (i s= i0) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize -. - -(** [array::f0]: forward function *) -Definition f0 : result unit := - s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); - s0 <- slice_update_usize u32 s 0%usize 1%u32; - _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) s0; - Return tt -. - -(** [array::f1]: forward function *) -Definition f1 : result unit := - _ <- - array_update_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) - 0%usize 1%u32; - Return tt -. - -(** [array::f2]: forward function *) -Definition f2 (i : u32) : result unit := - Return tt. - -(** [array::f4]: forward function *) -Definition f4 - (n : nat) (x : array u32 32%usize) (y : usize) (z : usize) : - result (slice u32) - := - core_array_Array_index u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x - {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} -. - -(** [array::f3]: forward function *) -Definition f3 (n : nat) : result u32 := - i <- - array_index_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) - 0%usize; - _ <- f2 i; - let b := array_repeat u32 32%usize 0%u32 in - s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); - s0 <- f4 n b 16%usize 18%usize; - sum2 n s s0 -. - -(** [array::SZ] *) -Definition sz_body : result usize := Return 32%usize. -Definition sz_c : usize := sz_body%global. - -(** [array::f5]: forward function *) -Definition f5 (x : array u32 32%usize) : result u32 := - array_index_usize u32 32%usize x 0%usize -. - -(** [array::ite]: forward function *) -Definition ite : result unit := - s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); - s1 <- index_mut_slice_u32_0_back s0; - _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s1; - s2 <- index_mut_slice_u32_0_back s; - _ <- array_from_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]) s2; - Return tt -. - -End Array_Funs . diff --git a/tests/coq/array/Array_Types.v b/tests/coq/array/Array_Types.v deleted file mode 100644 index a13d64e6..00000000 --- a/tests/coq/array/Array_Types.v +++ /dev/null @@ -1,14 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [array]: type definitions *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Module Array_Types. - -(** [array::AB] *) -Inductive AB_t := | AB_A : AB_t | AB_B : AB_t. - -End Array_Types . diff --git a/tests/coq/array/_CoqProject b/tests/coq/array/_CoqProject index f33cefe6..87d8fc3d 100644 --- a/tests/coq/array/_CoqProject +++ b/tests/coq/array/_CoqProject @@ -3,6 +3,5 @@ -arg -w -arg all -Array_Funs.v Primitives.v -Array_Types.v +Array.v diff --git a/tests/coq/betree/BetreeMain_Types.v b/tests/coq/betree/BetreeMain_Types.v index ee26622e..933a670c 100644 --- a/tests/coq/betree/BetreeMain_Types.v +++ b/tests/coq/betree/BetreeMain_Types.v @@ -14,8 +14,8 @@ Inductive betree_List_t (T : Type) := | Betree_List_Nil : betree_List_t T . -Arguments Betree_List_Cons {T} _ _. -Arguments Betree_List_Nil {T}. +Arguments Betree_List_Cons { _ }. +Arguments Betree_List_Nil { _ }. (** [betree_main::betree::UpsertFunState] *) Inductive betree_UpsertFunState_t := diff --git a/tests/coq/hashmap/Hashmap_Types.v b/tests/coq/hashmap/Hashmap_Types.v index 63d30eeb..8529803d 100644 --- a/tests/coq/hashmap/Hashmap_Types.v +++ b/tests/coq/hashmap/Hashmap_Types.v @@ -14,8 +14,8 @@ Inductive List_t (T : Type) := | List_Nil : List_t T . -Arguments List_Cons {T} _ _ _. -Arguments List_Nil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [hashmap::HashMap] *) Record HashMap_t (T : Type) := @@ -27,10 +27,10 @@ mkHashMap_t { } . -Arguments mkHashMap_t {T} _ _ _ _. -Arguments hashMap_num_entries {T}. -Arguments hashMap_max_load_factor {T}. -Arguments hashMap_max_load {T}. -Arguments hashMap_slots {T}. +Arguments mkHashMap_t { _ }. +Arguments hashMap_num_entries { _ }. +Arguments hashMap_max_load_factor { _ }. +Arguments hashMap_max_load { _ }. +Arguments hashMap_slots { _ }. End Hashmap_Types . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Types.v b/tests/coq/hashmap_on_disk/HashmapMain_Types.v index 466119f8..95e5f35b 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Types.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Types.v @@ -14,8 +14,8 @@ Inductive hashmap_List_t (T : Type) := | Hashmap_List_Nil : hashmap_List_t T . -Arguments Hashmap_List_Cons {T} _ _ _. -Arguments Hashmap_List_Nil {T}. +Arguments Hashmap_List_Cons { _ }. +Arguments Hashmap_List_Nil { _ }. (** [hashmap_main::hashmap::HashMap] *) Record hashmap_HashMap_t (T : Type) := @@ -27,11 +27,11 @@ mkhashmap_HashMap_t { } . -Arguments mkhashmap_HashMap_t {T} _ _ _ _. -Arguments hashmap_HashMap_num_entries {T}. -Arguments hashmap_HashMap_max_load_factor {T}. -Arguments hashmap_HashMap_max_load {T}. -Arguments hashmap_HashMap_slots {T}. +Arguments mkhashmap_HashMap_t { _ }. +Arguments hashmap_HashMap_num_entries { _ }. +Arguments hashmap_HashMap_max_load_factor { _ }. +Arguments hashmap_HashMap_max_load { _ }. +Arguments hashmap_HashMap_slots { _ }. (** The state type used in the state-error monad *) Axiom state : Type. diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index 7cb1a642..03653f69 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -35,9 +35,9 @@ Definition mk_pair0 (x : u32) (y : u32) : result (u32 * u32) := (** [constants::Pair] *) Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. -Arguments mkPair_t {T1} {T2} _ _. -Arguments pair_x {T1} {T2}. -Arguments pair_y {T1} {T2}. +Arguments mkPair_t { _ _ }. +Arguments pair_x { _ _ }. +Arguments pair_y { _ _ }. (** [constants::mk_pair1]: forward function *) Definition mk_pair1 (x : u32) (y : u32) : result (Pair_t u32 u32) := @@ -65,8 +65,8 @@ Definition p3_c : Pair_t u32 u32 := p3_body%global. (** [constants::Wrap] *) Record Wrap_t (T : Type) := mkWrap_t { wrap_value : T; }. -Arguments mkWrap_t {T} _. -Arguments wrap_value {T}. +Arguments mkWrap_t { _ }. +Arguments wrap_value { _ }. (** [constants::Wrap::{0}::new]: forward function *) Definition wrap_new (T : Type) (value : T) : result (Wrap_t T) := diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index 180a1d68..1c0eab17 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -96,8 +96,8 @@ Inductive List_t (T : Type) := | List_Nil : List_t T . -Arguments List_Cons {T} _ _. -Arguments List_Nil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [loops::list_mem]: loop 0: forward function *) Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index e916ca4a..c7af496f 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -11,9 +11,9 @@ Module NoNestedBorrows. (** [no_nested_borrows::Pair] *) Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. -Arguments mkPair_t {T1} {T2} _ _. -Arguments pair_x {T1} {T2}. -Arguments pair_y {T1} {T2}. +Arguments mkPair_t { _ _ }. +Arguments pair_x { _ _ }. +Arguments pair_y { _ _ }. (** [no_nested_borrows::List] *) Inductive List_t (T : Type) := @@ -21,13 +21,13 @@ Inductive List_t (T : Type) := | List_Nil : List_t T . -Arguments List_Cons {T} _ _. -Arguments List_Nil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [no_nested_borrows::One] *) Inductive One_t (T1 : Type) := | One_One : T1 -> One_t T1. -Arguments One_One {T1} _. +Arguments One_One { _ }. (** [no_nested_borrows::EmptyEnum] *) Inductive EmptyEnum_t := | EmptyEnum_Empty : EmptyEnum_t. @@ -44,8 +44,8 @@ Inductive Sum_t (T1 T2 : Type) := | Sum_Right : T2 -> Sum_t T1 T2 . -Arguments Sum_Left {T1} {T2} _. -Arguments Sum_Right {T1} {T2} _. +Arguments Sum_Left { _ _ }. +Arguments Sum_Right { _ _ }. (** [no_nested_borrows::neg_test]: forward function *) Definition neg_test (x : i32) : result i32 := @@ -258,11 +258,11 @@ with NodeElem_t (T : Type) := | NodeElem_Nil : NodeElem_t T . -Arguments Tree_Leaf {T} _. -Arguments Tree_Node {T} _ _ _. +Arguments Tree_Leaf { _ }. +Arguments Tree_Node { _ }. -Arguments NodeElem_Cons {T} _ _. -Arguments NodeElem_Nil {T}. +Arguments NodeElem_Cons { _ }. +Arguments NodeElem_Nil { _ }. (** [no_nested_borrows::list_length]: forward function *) Fixpoint list_length (T : Type) (l : List_t T) : result u32 := @@ -425,8 +425,8 @@ mkStructWithTuple_t { } . -Arguments mkStructWithTuple_t {T1} {T2} _. -Arguments structWithTuple_p {T1} {T2}. +Arguments mkStructWithTuple_t { _ _ }. +Arguments structWithTuple_p { _ _ }. (** [no_nested_borrows::new_tuple1]: forward function *) Definition new_tuple1 : result (StructWithTuple_t u32 u32) := @@ -450,8 +450,8 @@ mkStructWithPair_t { } . -Arguments mkStructWithPair_t {T1} {T2} _. -Arguments structWithPair_p {T1} {T2}. +Arguments mkStructWithPair_t { _ _ }. +Arguments structWithPair_p { _ _ }. (** [no_nested_borrows::new_pair1]: forward function *) Definition new_pair1 : result (StructWithPair_t u32 u32) := diff --git a/tests/coq/misc/Paper.v b/tests/coq/misc/Paper.v index d397995b..d3852e6b 100644 --- a/tests/coq/misc/Paper.v +++ b/tests/coq/misc/Paper.v @@ -55,8 +55,8 @@ Inductive List_t (T : Type) := | List_Nil : List_t T . -Arguments List_Cons {T} _ _. -Arguments List_Nil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [paper::list_nth_mut]: forward function *) Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := diff --git a/tests/coq/misc/PoloniusList.v b/tests/coq/misc/PoloniusList.v index 4f804b55..4848444f 100644 --- a/tests/coq/misc/PoloniusList.v +++ b/tests/coq/misc/PoloniusList.v @@ -14,8 +14,8 @@ Inductive List_t (T : Type) := | List_Nil : List_t T . -Arguments List_Cons {T} _ _. -Arguments List_Nil {T}. +Arguments List_Cons { _ }. +Arguments List_Nil { _ }. (** [polonius_list::get_list_at_x]: forward function *) Fixpoint get_list_at_x (ls : List_t u32) (x : u32) : result (List_t u32) := diff --git a/tests/coq/traits/Primitives.v b/tests/coq/traits/Primitives.v new file mode 100644 index 00000000..85e38f01 --- /dev/null +++ b/tests/coq/traits/Primitives.v @@ -0,0 +1,822 @@ +Require Import Lia. +Require Coq.Strings.Ascii. +Require Coq.Strings.String. +Require Import Coq.Program.Equality. +Require Import Coq.ZArith.ZArith. +Require Import Coq.ZArith.Znat. +Require Import List. +Import ListNotations. + +Module Primitives. + + (* TODO: use more *) +Declare Scope Primitives_scope. + +(*** Result *) + +Inductive error := + | Failure + | OutOfFuel. + +Inductive result A := + | Return : A -> result A + | Fail_ : error -> result A. + +Arguments Return {_} a. +Arguments Fail_ {_}. + +Definition bind {A B} (m: result A) (f: A -> result B) : result B := + match m with + | Fail_ e => Fail_ e + | Return x => f x + end. + +Definition return_ {A: Type} (x: A) : result A := Return x. +Definition fail_ {A: Type} (e: error) : result A := Fail_ e. + +Notation "x <- c1 ; c2" := (bind c1 (fun x => c2)) + (at level 61, c1 at next level, right associativity). + +(** Monadic assert *) +Definition massert (b: bool) : result unit := + if b then Return tt else Fail_ Failure. + +(** Normalize and unwrap a successful result (used for globals) *) +Definition eval_result_refl {A} {x} (a: result A) (p: a = Return x) : A := + match a as r return (r = Return x -> A) with + | Return a' => fun _ => a' + | Fail_ e => fun p' => + False_rect _ (eq_ind (Fail_ e) + (fun e : result A => + match e with + | Return _ => False + | Fail_ e => True + end) + I (Return x) p') + end p. + +Notation "x %global" := (eval_result_refl x eq_refl) (at level 40). +Notation "x %return" := (eval_result_refl x eq_refl) (at level 40). + +(* Sanity check *) +Check (if true then Return (1 + 2) else Fail_ Failure)%global = 3. + +(*** Misc *) + +Definition string := Coq.Strings.String.string. +Definition char := Coq.Strings.Ascii.ascii. +Definition char_of_byte := Coq.Strings.Ascii.ascii_of_byte. + +Definition core_mem_replace (a : Type) (x : a) (y : a) : a := x . +Definition core_mem_replace_back (a : Type) (x : a) (y : a) : a := y . + +Record mut_raw_ptr (T : Type) := { mut_raw_ptr_v : T }. +Record const_raw_ptr (T : Type) := { const_raw_ptr_v : T }. + +(*** Scalars *) + +Definition i8_min : Z := -128%Z. +Definition i8_max : Z := 127%Z. +Definition i16_min : Z := -32768%Z. +Definition i16_max : Z := 32767%Z. +Definition i32_min : Z := -2147483648%Z. +Definition i32_max : Z := 2147483647%Z. +Definition i64_min : Z := -9223372036854775808%Z. +Definition i64_max : Z := 9223372036854775807%Z. +Definition i128_min : Z := -170141183460469231731687303715884105728%Z. +Definition i128_max : Z := 170141183460469231731687303715884105727%Z. +Definition u8_min : Z := 0%Z. +Definition u8_max : Z := 255%Z. +Definition u16_min : Z := 0%Z. +Definition u16_max : Z := 65535%Z. +Definition u32_min : Z := 0%Z. +Definition u32_max : Z := 4294967295%Z. +Definition u64_min : Z := 0%Z. +Definition u64_max : Z := 18446744073709551615%Z. +Definition u128_min : Z := 0%Z. +Definition u128_max : Z := 340282366920938463463374607431768211455%Z. + +(** The bounds of [isize] and [usize] vary with the architecture. *) +Axiom isize_min : Z. +Axiom isize_max : Z. +Definition usize_min : Z := 0%Z. +Axiom usize_max : Z. + +Open Scope Z_scope. + +(** We provide those lemmas to reason about the bounds of [isize] and [usize] *) +Axiom isize_min_bound : isize_min <= i32_min. +Axiom isize_max_bound : i32_max <= isize_max. +Axiom usize_max_bound : u32_max <= usize_max. + +Inductive scalar_ty := + | Isize + | I8 + | I16 + | I32 + | I64 + | I128 + | Usize + | U8 + | U16 + | U32 + | U64 + | U128 +. + +Definition scalar_min (ty: scalar_ty) : Z := + match ty with + | Isize => isize_min + | I8 => i8_min + | I16 => i16_min + | I32 => i32_min + | I64 => i64_min + | I128 => i128_min + | Usize => usize_min + | U8 => u8_min + | U16 => u16_min + | U32 => u32_min + | U64 => u64_min + | U128 => u128_min +end. + +Definition scalar_max (ty: scalar_ty) : Z := + match ty with + | Isize => isize_max + | I8 => i8_max + | I16 => i16_max + | I32 => i32_max + | I64 => i64_max + | I128 => i128_max + | Usize => usize_max + | U8 => u8_max + | U16 => u16_max + | U32 => u32_max + | U64 => u64_max + | U128 => u128_max +end. + +(** We use the following conservative bounds to make sure we can compute bound + checks in most situations *) +Definition scalar_min_cons (ty: scalar_ty) : Z := + match ty with + | Isize => i32_min + | Usize => u32_min + | _ => scalar_min ty +end. + +Definition scalar_max_cons (ty: scalar_ty) : Z := + match ty with + | Isize => i32_max + | Usize => u32_max + | _ => scalar_max ty +end. + +Lemma scalar_min_cons_valid : forall ty, scalar_min ty <= scalar_min_cons ty . +Proof. + destruct ty; unfold scalar_min_cons, scalar_min; try lia. + - pose isize_min_bound; lia. + - apply Z.le_refl. +Qed. + +Lemma scalar_max_cons_valid : forall ty, scalar_max ty >= scalar_max_cons ty . +Proof. + destruct ty; unfold scalar_max_cons, scalar_max; try lia. + - pose isize_max_bound; lia. + - pose usize_max_bound. lia. +Qed. + +Definition scalar (ty: scalar_ty) : Type := + { x: Z | scalar_min ty <= x <= scalar_max ty }. + +Definition to_Z {ty} (x: scalar ty) : Z := proj1_sig x. + +(** Bounds checks: we start by using the conservative bounds, to make sure we + can compute in most situations, then we use the real bounds (for [isize] + and [usize]). *) +Definition scalar_ge_min (ty: scalar_ty) (x: Z) : bool := + Z.leb (scalar_min_cons ty) x || Z.leb (scalar_min ty) x. + +Definition scalar_le_max (ty: scalar_ty) (x: Z) : bool := + Z.leb x (scalar_max_cons ty) || Z.leb x (scalar_max ty). + +Lemma scalar_ge_min_valid (ty: scalar_ty) (x: Z) : + scalar_ge_min ty x = true -> scalar_min ty <= x . +Proof. + unfold scalar_ge_min. + pose (scalar_min_cons_valid ty). + lia. +Qed. + +Lemma scalar_le_max_valid (ty: scalar_ty) (x: Z) : + scalar_le_max ty x = true -> x <= scalar_max ty . +Proof. + unfold scalar_le_max. + pose (scalar_max_cons_valid ty). + lia. +Qed. + +Definition scalar_in_bounds (ty: scalar_ty) (x: Z) : bool := + scalar_ge_min ty x && scalar_le_max ty x . + +Lemma scalar_in_bounds_valid (ty: scalar_ty) (x: Z) : + scalar_in_bounds ty x = true -> scalar_min ty <= x <= scalar_max ty . +Proof. + unfold scalar_in_bounds. + intros H. + destruct (scalar_ge_min ty x) eqn:Hmin. + - destruct (scalar_le_max ty x) eqn:Hmax. + + pose (scalar_ge_min_valid ty x Hmin). + pose (scalar_le_max_valid ty x Hmax). + lia. + + inversion H. + - inversion H. +Qed. + +Import Sumbool. + +Definition mk_scalar (ty: scalar_ty) (x: Z) : result (scalar ty) := + match sumbool_of_bool (scalar_in_bounds ty x) with + | left H => Return (exist _ x (scalar_in_bounds_valid _ _ H)) + | right _ => Fail_ Failure + end. + +Definition scalar_add {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (to_Z x + to_Z y). + +Definition scalar_sub {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (to_Z x - to_Z y). + +Definition scalar_mul {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (to_Z x * to_Z y). + +Definition scalar_div {ty} (x y: scalar ty) : result (scalar ty) := + if to_Z y =? 0 then Fail_ Failure else + mk_scalar ty (to_Z x / to_Z y). + +Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty (Z.rem (to_Z x) (to_Z y)). + +Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). + +(** Cast an integer from a [src_ty] to a [tgt_ty] *) +(* TODO: check the semantics of casts in Rust *) +Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := + mk_scalar tgt_ty (to_Z x). + +(** Comparisons *) +Definition scalar_leb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.leb (to_Z x) (to_Z y) . + +Definition scalar_ltb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.ltb (to_Z x) (to_Z y) . + +Definition scalar_geb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.geb (to_Z x) (to_Z y) . + +Definition scalar_gtb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.gtb (to_Z x) (to_Z y) . + +Definition scalar_eqb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + Z.eqb (to_Z x) (to_Z y) . + +Definition scalar_neqb {ty : scalar_ty} (x : scalar ty) (y : scalar ty) : bool := + negb (Z.eqb (to_Z x) (to_Z y)) . + + +(** The scalar types *) +Definition isize := scalar Isize. +Definition i8 := scalar I8. +Definition i16 := scalar I16. +Definition i32 := scalar I32. +Definition i64 := scalar I64. +Definition i128 := scalar I128. +Definition usize := scalar Usize. +Definition u8 := scalar U8. +Definition u16 := scalar U16. +Definition u32 := scalar U32. +Definition u64 := scalar U64. +Definition u128 := scalar U128. + +(** Negaion *) +Definition isize_neg := @scalar_neg Isize. +Definition i8_neg := @scalar_neg I8. +Definition i16_neg := @scalar_neg I16. +Definition i32_neg := @scalar_neg I32. +Definition i64_neg := @scalar_neg I64. +Definition i128_neg := @scalar_neg I128. + +(** Division *) +Definition isize_div := @scalar_div Isize. +Definition i8_div := @scalar_div I8. +Definition i16_div := @scalar_div I16. +Definition i32_div := @scalar_div I32. +Definition i64_div := @scalar_div I64. +Definition i128_div := @scalar_div I128. +Definition usize_div := @scalar_div Usize. +Definition u8_div := @scalar_div U8. +Definition u16_div := @scalar_div U16. +Definition u32_div := @scalar_div U32. +Definition u64_div := @scalar_div U64. +Definition u128_div := @scalar_div U128. + +(** Remainder *) +Definition isize_rem := @scalar_rem Isize. +Definition i8_rem := @scalar_rem I8. +Definition i16_rem := @scalar_rem I16. +Definition i32_rem := @scalar_rem I32. +Definition i64_rem := @scalar_rem I64. +Definition i128_rem := @scalar_rem I128. +Definition usize_rem := @scalar_rem Usize. +Definition u8_rem := @scalar_rem U8. +Definition u16_rem := @scalar_rem U16. +Definition u32_rem := @scalar_rem U32. +Definition u64_rem := @scalar_rem U64. +Definition u128_rem := @scalar_rem U128. + +(** Addition *) +Definition isize_add := @scalar_add Isize. +Definition i8_add := @scalar_add I8. +Definition i16_add := @scalar_add I16. +Definition i32_add := @scalar_add I32. +Definition i64_add := @scalar_add I64. +Definition i128_add := @scalar_add I128. +Definition usize_add := @scalar_add Usize. +Definition u8_add := @scalar_add U8. +Definition u16_add := @scalar_add U16. +Definition u32_add := @scalar_add U32. +Definition u64_add := @scalar_add U64. +Definition u128_add := @scalar_add U128. + +(** Substraction *) +Definition isize_sub := @scalar_sub Isize. +Definition i8_sub := @scalar_sub I8. +Definition i16_sub := @scalar_sub I16. +Definition i32_sub := @scalar_sub I32. +Definition i64_sub := @scalar_sub I64. +Definition i128_sub := @scalar_sub I128. +Definition usize_sub := @scalar_sub Usize. +Definition u8_sub := @scalar_sub U8. +Definition u16_sub := @scalar_sub U16. +Definition u32_sub := @scalar_sub U32. +Definition u64_sub := @scalar_sub U64. +Definition u128_sub := @scalar_sub U128. + +(** Multiplication *) +Definition isize_mul := @scalar_mul Isize. +Definition i8_mul := @scalar_mul I8. +Definition i16_mul := @scalar_mul I16. +Definition i32_mul := @scalar_mul I32. +Definition i64_mul := @scalar_mul I64. +Definition i128_mul := @scalar_mul I128. +Definition usize_mul := @scalar_mul Usize. +Definition u8_mul := @scalar_mul U8. +Definition u16_mul := @scalar_mul U16. +Definition u32_mul := @scalar_mul U32. +Definition u64_mul := @scalar_mul U64. +Definition u128_mul := @scalar_mul U128. + +(** Small utility *) +Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). + +(** Notations *) +Notation "x %isize" := ((mk_scalar Isize x)%return) (at level 9). +Notation "x %i8" := ((mk_scalar I8 x)%return) (at level 9). +Notation "x %i16" := ((mk_scalar I16 x)%return) (at level 9). +Notation "x %i32" := ((mk_scalar I32 x)%return) (at level 9). +Notation "x %i64" := ((mk_scalar I64 x)%return) (at level 9). +Notation "x %i128" := ((mk_scalar I128 x)%return) (at level 9). +Notation "x %usize" := ((mk_scalar Usize x)%return) (at level 9). +Notation "x %u8" := ((mk_scalar U8 x)%return) (at level 9). +Notation "x %u16" := ((mk_scalar U16 x)%return) (at level 9). +Notation "x %u32" := ((mk_scalar U32 x)%return) (at level 9). +Notation "x %u64" := ((mk_scalar U64 x)%return) (at level 9). +Notation "x %u128" := ((mk_scalar U128 x)%return) (at level 9). + +Notation "x s= y" := (scalar_eqb x y) (at level 80) : Primitives_scope. +Notation "x s<> y" := (scalar_neqb x y) (at level 80) : Primitives_scope. +Notation "x s<= y" := (scalar_leb x y) (at level 80) : Primitives_scope. +Notation "x s< y" := (scalar_ltb x y) (at level 80) : Primitives_scope. +Notation "x s>= y" := (scalar_geb x y) (at level 80) : Primitives_scope. +Notation "x s> y" := (scalar_gtb x y) (at level 80) : Primitives_scope. + +(** Constants *) +Definition core_u8_max := u8_max %u32. +Definition core_u16_max := u16_max %u32. +Definition core_u32_max := u32_max %u32. +Definition core_u64_max := u64_max %u64. +Definition core_u128_max := u64_max %u128. +Axiom core_usize_max : usize. (** TODO *) +Definition core_i8_max := i8_max %i32. +Definition core_i16_max := i16_max %i32. +Definition core_i32_max := i32_max %i32. +Definition core_i64_max := i64_max %i64. +Definition core_i128_max := i64_max %i128. +Axiom core_isize_max : isize. (** TODO *) + +(*** core::ops *) + +(* Trait declaration: [core::ops::index::Index] *) +Record core_ops_index_Index (Self Idx : Type) := mk_core_ops_index_Index { + core_ops_index_Index_Output : Type; + core_ops_index_Index_index : Self -> Idx -> result core_ops_index_Index_Output; +}. +Arguments mk_core_ops_index_Index {_ _}. +Arguments core_ops_index_Index_Output {_ _}. +Arguments core_ops_index_Index_index {_ _}. + +(* Trait declaration: [core::ops::index::IndexMut] *) +Record core_ops_index_IndexMut (Self Idx : Type) := mk_core_ops_index_IndexMut { + core_ops_index_IndexMut_indexInst : core_ops_index_Index Self Idx; + core_ops_index_IndexMut_index_mut : Self -> Idx -> result core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output); + core_ops_index_IndexMut_index_mut_back : Self -> Idx -> core_ops_index_IndexMut_indexInst.(core_ops_index_Index_Output) -> result Self; +}. +Arguments mk_core_ops_index_IndexMut {_ _}. +Arguments core_ops_index_IndexMut_indexInst {_ _}. +Arguments core_ops_index_IndexMut_index_mut {_ _}. +Arguments core_ops_index_IndexMut_index_mut_back {_ _}. + +(* Trait declaration [core::ops::deref::Deref] *) +Record core_ops_deref_Deref (Self : Type) := mk_core_ops_deref_Deref { + core_ops_deref_Deref_target : Type; + core_ops_deref_Deref_deref : Self -> result core_ops_deref_Deref_target; +}. +Arguments mk_core_ops_deref_Deref {_}. +Arguments core_ops_deref_Deref_target {_}. +Arguments core_ops_deref_Deref_deref {_}. + +(* Trait declaration [core::ops::deref::DerefMut] *) +Record core_ops_deref_DerefMut (Self : Type) := mk_core_ops_deref_DerefMut { + core_ops_deref_DerefMut_derefInst : core_ops_deref_Deref Self; + core_ops_deref_DerefMut_deref_mut : Self -> result core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target); + core_ops_deref_DerefMut_deref_mut_back : Self -> core_ops_deref_DerefMut_derefInst.(core_ops_deref_Deref_target) -> result Self; +}. +Arguments mk_core_ops_deref_DerefMut {_}. +Arguments core_ops_deref_DerefMut_derefInst {_}. +Arguments core_ops_deref_DerefMut_deref_mut {_}. +Arguments core_ops_deref_DerefMut_deref_mut_back {_}. + +Record core_ops_range_Range (T : Type) := mk_core_ops_range_Range { + core_ops_range_Range_start : T; + core_ops_range_Range_end_ : T; +}. +Arguments mk_core_ops_range_Range {_}. +Arguments core_ops_range_Range_start {_}. +Arguments core_ops_range_Range_end_ {_}. + +(*** [alloc] *) + +Definition alloc_boxed_Box_deref (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. +Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| + core_ops_deref_Deref_target := Self; + core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; +|}. + +(* Trait instance *) +Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; + core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; + core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; +|}. + + +(*** Arrays *) +Definition array T (n : usize) := { l: list T | Z.of_nat (length l) = to_Z n}. + +Lemma le_0_usize_max : 0 <= usize_max. +Proof. + pose (H := usize_max_bound). + unfold u32_max in H. + lia. +Qed. + +Lemma eqb_imp_eq (x y : Z) : Z.eqb x y = true -> x = y. +Proof. + lia. +Qed. + +(* TODO: finish the definitions *) +Axiom mk_array : forall (T : Type) (n : usize) (l : list T), array T n. + +(* For initialization *) +Axiom array_repeat : forall (T : Type) (n : usize) (x : T), array T n. + +Axiom array_index_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize), result T. +Axiom array_update_usize : forall (T : Type) (n : usize) (x : array T n) (i : usize) (nx : T), result (array T n). + +(*** Slice *) +Definition slice T := { l: list T | Z.of_nat (length l) <= usize_max}. + +Axiom slice_len : forall (T : Type) (s : slice T), usize. +Axiom slice_index_usize : forall (T : Type) (x : slice T) (i : usize), result T. +Axiom slice_update_usize : forall (T : Type) (x : slice T) (i : usize) (nx : T), result (slice T). + +(*** Subslices *) + +Axiom array_to_slice : forall (T : Type) (n : usize) (x : array T n), result (slice T). +Axiom array_from_slice : forall (T : Type) (n : usize) (x : array T n) (s : slice T), result (array T n). + +Axiom array_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize), result (slice T). +Axiom array_update_subslice: forall (T : Type) (n : usize) (x : array T n) (r : core_ops_range_Range usize) (ns : slice T), result (array T n). + +Axiom slice_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize), result (slice T). +Axiom slice_update_subslice: forall (T : Type) (x : slice T) (r : core_ops_range_Range usize) (ns : slice T), result (slice T). + +(*** Vectors *) + +Definition alloc_vec_Vec T := { l: list T | Z.of_nat (length l) <= usize_max }. + +Definition alloc_vec_Vec_to_list {T: Type} (v: alloc_vec_Vec T) : list T := proj1_sig v. + +Definition alloc_vec_Vec_length {T: Type} (v: alloc_vec_Vec T) : Z := Z.of_nat (length (alloc_vec_Vec_to_list v)). + +Definition alloc_vec_Vec_new (T: Type) : alloc_vec_Vec T := (exist _ [] le_0_usize_max). + +Lemma alloc_vec_Vec_len_in_usize {T} (v: alloc_vec_Vec T) : usize_min <= alloc_vec_Vec_length v <= usize_max. +Proof. + unfold alloc_vec_Vec_length, usize_min. + split. + - lia. + - apply (proj2_sig v). +Qed. + +Definition alloc_vec_Vec_len (T: Type) (v: alloc_vec_Vec T) : usize := + exist _ (alloc_vec_Vec_length v) (alloc_vec_Vec_len_in_usize v). + +Fixpoint list_update {A} (l: list A) (n: nat) (a: A) + : list A := + match l with + | [] => [] + | x :: t => match n with + | 0%nat => a :: t + | S m => x :: (list_update t m a) +end end. + +Definition alloc_vec_Vec_bind {A B} (v: alloc_vec_Vec A) (f: list A -> result (list B)) : result (alloc_vec_Vec B) := + l <- f (alloc_vec_Vec_to_list v) ; + match sumbool_of_bool (scalar_le_max Usize (Z.of_nat (length l))) with + | left H => Return (exist _ l (scalar_le_max_valid _ _ H)) + | right _ => Fail_ Failure + end. + +(* The **forward** function shouldn't be used *) +Definition alloc_vec_Vec_push_fwd (T: Type) (v: alloc_vec_Vec T) (x: T) : unit := tt. + +Definition alloc_vec_Vec_push (T: Type) (v: alloc_vec_Vec T) (x: T) : result (alloc_vec_Vec T) := + alloc_vec_Vec_bind v (fun l => Return (l ++ [x])). + +(* The **forward** function shouldn't be used *) +Definition alloc_vec_Vec_insert_fwd (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) : result unit := + if to_Z i + if to_Z i T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut : Self -> T -> result (option core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_mut_back : Self -> T -> option core_slice_index_SliceIndex_Output -> result T; + core_slice_index_SliceIndex_get_unchecked : Self -> const_raw_ptr T -> result (const_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_get_unchecked_mut : Self -> mut_raw_ptr T -> result (mut_raw_ptr core_slice_index_SliceIndex_Output); + core_slice_index_SliceIndex_index : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut : Self -> T -> result core_slice_index_SliceIndex_Output; + core_slice_index_SliceIndex_index_mut_back : Self -> T -> core_slice_index_SliceIndex_Output -> result T; +}. +Arguments mk_core_slice_index_SliceIndex {_ _}. +Arguments core_slice_index_SliceIndex_sealedInst {_ _}. +Arguments core_slice_index_SliceIndex_Output {_ _}. +Arguments core_slice_index_SliceIndex_get {_ _}. +Arguments core_slice_index_SliceIndex_get_mut {_ _}. +Arguments core_slice_index_SliceIndex_get_mut_back {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked {_ _}. +Arguments core_slice_index_SliceIndex_get_unchecked_mut {_ _}. +Arguments core_slice_index_SliceIndex_index {_ _}. +Arguments core_slice_index_SliceIndex_index_mut {_ _}. +Arguments core_slice_index_SliceIndex_index_mut_back {_ _}. + +(* [core::slice::index::[T]::index]: forward function *) +Definition core_slice_index_Slice_index + (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (s : slice T) (i : Idx) : result inst.(core_slice_index_SliceIndex_Output) := + x <- inst.(core_slice_index_SliceIndex_get) i s; + match x with + | None => Fail_ Failure + | Some x => Return x + end. + +(* [core::slice::index::Range:::get]: forward function *) +Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: forward function *) +Axiom core_slice_index_Range_get_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). + +(* [core::slice::index::Range::get_mut]: backward function 0 *) +Axiom core_slice_index_Range_get_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). + +(* [core::slice::index::Range::get_unchecked]: forward function *) +Definition core_slice_index_Range_get_unchecked + (T : Type) : + core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::get_unchecked_mut]: forward function *) +Definition core_slice_index_Range_get_unchecked_mut + (T : Type) : + core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := + (* Don't know what the model should be - for now we always fail to make + sure code which uses it fails *) + fun _ _ => Fail_ Failure. + +(* [core::slice::index::Range::index]: forward function *) +Axiom core_slice_index_Range_index : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: forward function *) +Axiom core_slice_index_Range_index_mut : + forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). + +(* [core::slice::index::Range::index_mut]: backward function 0 *) +Axiom core_slice_index_Range_index_mut_back : + forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). + +(* [core::slice::index::[T]::index_mut]: forward function *) +Axiom core_slice_index_Slice_index_mut : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> result inst.(core_slice_index_SliceIndex_Output). + +(* [core::slice::index::[T]::index_mut]: backward function 0 *) +Axiom core_slice_index_Slice_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)), + slice T -> Idx -> inst.(core_slice_index_SliceIndex_Output) -> result (slice T). + +(* [core::array::[T; N]::index]: forward function *) +Axiom core_array_Array_index : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: forward function *) +Axiom core_array_Array_index_mut : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx), result inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output). + +(* [core::array::[T; N]::index_mut]: backward function 0 *) +Axiom core_array_Array_index_mut_back : + forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) + (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::private_slice_index::Range] *) +Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. + +(* Trait implementation: [core::slice::index::Range] *) +Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := slice T; + core_slice_index_SliceIndex_get := core_slice_index_Range_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_Range_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (slice T) Idx := {| + core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) + (inst : core_ops_index_Index (slice T) Idx) : + core_ops_index_Index (array T N) Idx := {| + core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); + core_ops_index_Index_index := core_array_Array_index T Idx N inst; +|}. + +(* Trait implementation: [core::array::[T; N]] *) +Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) + (inst : core_ops_index_IndexMut (slice T) Idx) : + core_ops_index_IndexMut (array T N) Idx := {| + core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; + core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; +|}. + +(* [core::slice::index::usize::get]: forward function *) +Axiom core_slice_index_usize_get : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: forward function *) +Axiom core_slice_index_usize_get_mut : forall (T : Type), usize -> slice T -> result (option T). + +(* [core::slice::index::usize::get_mut]: backward function 0 *) +Axiom core_slice_index_usize_get_mut_back : + forall (T : Type), usize -> slice T -> option T -> result (slice T). + +(* [core::slice::index::usize::get_unchecked]: forward function *) +Axiom core_slice_index_usize_get_unchecked : + forall (T : Type), usize -> const_raw_ptr (slice T) -> result (const_raw_ptr T). + +(* [core::slice::index::usize::get_unchecked_mut]: forward function *) +Axiom core_slice_index_usize_get_unchecked_mut : + forall (T : Type), usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr T). + +(* [core::slice::index::usize::index]: forward function *) +Axiom core_slice_index_usize_index : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: forward function *) +Axiom core_slice_index_usize_index_mut : forall (T : Type), usize -> slice T -> result T. + +(* [core::slice::index::usize::index_mut]: backward function 0 *) +Axiom core_slice_index_usize_index_mut_back : + forall (T : Type), usize -> slice T -> T -> result (slice T). + +(* Trait implementation: [core::slice::index::private_slice_index::usize] *) +Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst + : core_slice_index_private_slice_index_Sealed usize := tt. + +(* Trait implementation: [core::slice::index::usize] *) +Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : + core_slice_index_SliceIndex usize (slice T) := {| + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_Output := T; + core_slice_index_SliceIndex_get := core_slice_index_usize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_usize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_usize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_usize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_usize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_usize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_usize_index_mut_back T; +|}. + +(* [alloc::vec::Vec::index]: forward function *) +Axiom alloc_vec_Vec_index : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: forward function *) +Axiom alloc_vec_Vec_index_mut : forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx), result inst.(core_slice_index_SliceIndex_Output). + +(* [alloc::vec::Vec::index_mut]: backward function 0 *) +Axiom alloc_vec_Vec_index_mut_back : + forall (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) + (Self : alloc_vec_Vec T) (i : Idx) (x : inst.(core_slice_index_SliceIndex_Output)), result (alloc_vec_Vec T). + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (alloc_vec_Vec T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := alloc_vec_Vec_index T Idx inst; +|}. + +(* Trait implementation: [alloc::vec::Vec] *) +Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_IndexMut (alloc_vec_Vec T) Idx := {| + core_ops_index_IndexMut_indexInst := alloc_vec_Vec_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_index_mut := alloc_vec_Vec_index_mut T Idx inst; + core_ops_index_IndexMut_index_mut_back := alloc_vec_Vec_index_mut_back T Idx inst; +|}. + +(*** Theorems *) + +Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_update_usize v i x. + +End Primitives. diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v new file mode 100644 index 00000000..e104fb66 --- /dev/null +++ b/tests/coq/traits/Traits.v @@ -0,0 +1,520 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [traits] *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module Traits. + +(** Trait declaration: [traits::BoolTrait] *) +Record BoolTrait_t (Self : Type) := mkBoolTrait_t { + BoolTrait_t_get_bool : Self -> result bool; +}. + +Arguments mkBoolTrait_t { _ }. +Arguments BoolTrait_t_get_bool { _ }. + +(** [traits::Bool::{0}::get_bool]: forward function *) +Definition bool_get_bool (self : bool) : result bool := + Return self. + +(** Trait implementation: [traits::Bool::{0}] *) +Definition Bool_BoolTraitInst : BoolTrait_t bool := {| + BoolTrait_t_get_bool := bool_get_bool; +|}. + +(** [traits::BoolTrait::ret_true]: forward function *) +Definition boolTrait_ret_true + {Self : Type} (self_clause : BoolTrait_t Self) (self : Self) : result bool := + Return true +. + +(** [traits::test_bool_trait_bool]: forward function *) +Definition test_bool_trait_bool (x : bool) : result bool := + b <- bool_get_bool x; + if b then boolTrait_ret_true Bool_BoolTraitInst x else Return false +. + +(** [traits::Option::{1}::get_bool]: forward function *) +Definition option_get_bool (T : Type) (self : option T) : result bool := + match self with | None => Return false | Some t => Return true end +. + +(** Trait implementation: [traits::Option::{1}] *) +Definition Option_BoolTraitInst (T : Type) : BoolTrait_t (option T) := {| + BoolTrait_t_get_bool := option_get_bool T; +|}. + +(** [traits::test_bool_trait_option]: forward function *) +Definition test_bool_trait_option (T : Type) (x : option T) : result bool := + b <- option_get_bool T x; + if b then boolTrait_ret_true (Option_BoolTraitInst T) x else Return false +. + +(** [traits::test_bool_trait]: forward function *) +Definition test_bool_trait + (T : Type) (inst : BoolTrait_t T) (x : T) : result bool := + inst.(BoolTrait_t_get_bool) x +. + +(** Trait declaration: [traits::ToU64] *) +Record ToU64_t (Self : Type) := mkToU64_t { + ToU64_t_to_u64 : Self -> result u64; +}. + +Arguments mkToU64_t { _ }. +Arguments ToU64_t_to_u64 { _ }. + +(** [traits::u64::{2}::to_u64]: forward function *) +Definition u64_to_u64 (self : u64) : result u64 := + Return self. + +(** Trait implementation: [traits::u64::{2}] *) +Definition u64_ToU64Inst : ToU64_t u64 := {| ToU64_t_to_u64 := u64_to_u64; |}. + +(** [traits::Tuple2::{3}::to_u64]: forward function *) +Definition tuple2_to_u64 + (A : Type) (inst : ToU64_t A) (self : (A * A)) : result u64 := + let (t, t0) := self in + i <- inst.(ToU64_t_to_u64) t; + i0 <- inst.(ToU64_t_to_u64) t0; + u64_add i i0 +. + +(** Trait implementation: [traits::Tuple2::{3}] *) +Definition Tuple2_ToU64Inst (A : Type) (inst : ToU64_t A) : ToU64_t (A * A) + := {| + ToU64_t_to_u64 := tuple2_to_u64 A inst; +|}. + +(** [traits::f]: forward function *) +Definition f (T : Type) (inst : ToU64_t T) (x : (T * T)) : result u64 := + tuple2_to_u64 T inst x +. + +(** [traits::g]: forward function *) +Definition g (T : Type) (inst : ToU64_t (T * T)) (x : (T * T)) : result u64 := + inst.(ToU64_t_to_u64) x +. + +(** [traits::h0]: forward function *) +Definition h0 (x : u64) : result u64 := + u64_to_u64 x. + +(** [traits::Wrapper] *) +Record Wrapper_t (T : Type) := mkWrapper_t { wrapper_x : T; }. + +Arguments mkWrapper_t { _ }. +Arguments wrapper_x { _ }. + +(** [traits::Wrapper::{4}::to_u64]: forward function *) +Definition wrapper_to_u64 + (T : Type) (inst : ToU64_t T) (self : Wrapper_t T) : result u64 := + inst.(ToU64_t_to_u64) self.(wrapper_x) +. + +(** Trait implementation: [traits::Wrapper::{4}] *) +Definition Wrapper_ToU64Inst (T : Type) (inst : ToU64_t T) : ToU64_t (Wrapper_t + T) := {| + ToU64_t_to_u64 := wrapper_to_u64 T inst; +|}. + +(** [traits::h1]: forward function *) +Definition h1 (x : Wrapper_t u64) : result u64 := + wrapper_to_u64 u64 u64_ToU64Inst x +. + +(** [traits::h2]: forward function *) +Definition h2 (T : Type) (inst : ToU64_t T) (x : Wrapper_t T) : result u64 := + wrapper_to_u64 T inst x +. + +(** Trait declaration: [traits::ToType] *) +Record ToType_t (Self T : Type) := mkToType_t { + ToType_t_to_type : Self -> result T; +}. + +Arguments mkToType_t { _ _ }. +Arguments ToType_t_to_type { _ _ }. + +(** [traits::u64::{5}::to_type]: forward function *) +Definition u64_to_type (self : u64) : result bool := + Return (self s> 0%u64). + +(** Trait implementation: [traits::u64::{5}] *) +Definition u64_ToTypeInst : ToType_t u64 bool := {| + ToType_t_to_type := u64_to_type; +|}. + +(** Trait declaration: [traits::OfType] *) +Record OfType_t (Self : Type) := mkOfType_t { + OfType_t_of_type : forall (T : Type) (inst : ToType_t T Self), T -> result + Self; +}. + +Arguments mkOfType_t { _ }. +Arguments OfType_t_of_type { _ }. + +(** [traits::h3]: forward function *) +Definition h3 + (T1 T2 : Type) (inst : OfType_t T1) (inst0 : ToType_t T2 T1) (y : T2) : + result T1 + := + inst.(OfType_t_of_type) T2 inst0 y +. + +(** Trait declaration: [traits::OfTypeBis] *) +Record OfTypeBis_t (Self T : Type) := mkOfTypeBis_t { + OfTypeBis_tOfTypeBis_t_parent_clause_0 : ToType_t T Self; + OfTypeBis_t_of_type : T -> result Self; +}. + +Arguments mkOfTypeBis_t { _ _ }. +Arguments OfTypeBis_tOfTypeBis_t_parent_clause_0 { _ _ }. +Arguments OfTypeBis_t_of_type { _ _ }. + +(** [traits::h4]: forward function *) +Definition h4 + (T1 T2 : Type) (inst : OfTypeBis_t T1 T2) (inst0 : ToType_t T2 T1) (y : T2) : + result T1 + := + inst.(OfTypeBis_t_of_type) y +. + +(** [traits::TestType] *) +Record TestType_t (T : Type) := mkTestType_t { testType_0 : T; }. + +Arguments mkTestType_t { _ }. +Arguments testType_0 { _ }. + +(** [traits::TestType::{6}::test::TestType1] *) +Record TestType_test_TestType1_t := +mkTestType_test_TestType1_t { + testType_test_TestType1_0 : u64; +} +. + +(** Trait declaration: [traits::TestType::{6}::test::TestTrait] *) +Record TestType_test_TestTrait_t (Self : Type) := mkTestType_test_TestTrait_t { + TestType_test_TestTrait_t_test : Self -> result bool; +}. + +Arguments mkTestType_test_TestTrait_t { _ }. +Arguments TestType_test_TestTrait_t_test { _ }. + +(** [traits::TestType::{6}::test::TestType1::{0}::test]: forward function *) +Definition testType_test_TestType1_test + (self : TestType_test_TestType1_t) : result bool := + Return (self.(testType_test_TestType1_0) s> 1%u64) +. + +(** Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] *) +Definition TestType_test_TestType1_TestType_test_TestTraitInst : + TestType_test_TestTrait_t TestType_test_TestType1_t := {| + TestType_test_TestTrait_t_test := testType_test_TestType1_test; +|}. + +(** [traits::TestType::{6}::test]: forward function *) +Definition testType_test + (T : Type) (inst : ToU64_t T) (self : TestType_t T) (x : T) : result bool := + x0 <- inst.(ToU64_t_to_u64) x; + if x0 s> 0%u64 + then testType_test_TestType1_test {| testType_test_TestType1_0 := 0%u64 |} + else Return false +. + +(** [traits::BoolWrapper] *) +Record BoolWrapper_t := mkBoolWrapper_t { boolWrapper_0 : bool; }. + +(** [traits::BoolWrapper::{7}::to_type]: forward function *) +Definition boolWrapper_to_type + (T : Type) (inst : ToType_t bool T) (self : BoolWrapper_t) : result T := + inst.(ToType_t_to_type) self.(boolWrapper_0) +. + +(** Trait implementation: [traits::BoolWrapper::{7}] *) +Definition BoolWrapper_ToTypeInst (T : Type) (inst : ToType_t bool T) : + ToType_t BoolWrapper_t T := {| + ToType_t_to_type := boolWrapper_to_type T inst; +|}. + +(** [traits::WithConstTy::LEN2] *) +Definition with_const_ty_len2_body : result usize := Return 32%usize. +Definition with_const_ty_len2_c : usize := with_const_ty_len2_body%global. + +(** Trait declaration: [traits::WithConstTy] *) +Record WithConstTy_t (Self : Type) (LEN : usize) := mkWithConstTy_t { + WithConstTy_tWithConstTy_t_LEN1 : usize; + WithConstTy_tWithConstTy_t_LEN2 : usize; + WithConstTy_tWithConstTy_t_V : Type; + WithConstTy_tWithConstTy_t_W : Type; + WithConstTy_tWithConstTy_t_W_clause_0 : ToU64_t WithConstTy_tWithConstTy_t_W; + WithConstTy_t_f : WithConstTy_tWithConstTy_t_W -> array u8 LEN -> result + WithConstTy_tWithConstTy_t_W; +}. + +Arguments mkWithConstTy_t { _ _ }. +Arguments WithConstTy_tWithConstTy_t_LEN1 { _ _ }. +Arguments WithConstTy_tWithConstTy_t_LEN2 { _ _ }. +Arguments WithConstTy_tWithConstTy_t_V { _ _ }. +Arguments WithConstTy_tWithConstTy_t_W { _ _ }. +Arguments WithConstTy_tWithConstTy_t_W_clause_0 { _ _ }. +Arguments WithConstTy_t_f { _ _ }. + +(** [traits::Bool::{8}::LEN1] *) +Definition bool_len1_body : result usize := Return 12%usize. +Definition bool_len1_c : usize := bool_len1_body%global. + +(** [traits::Bool::{8}::f]: merged forward/backward function + (there is a single backward function, and the forward function returns ()) *) +Definition bool_f (i : u64) (a : array u8 32%usize) : result u64 := + Return i. + +(** Trait implementation: [traits::Bool::{8}] *) +Definition Bool_WithConstTyInst : WithConstTy_t bool 32%usize := {| + WithConstTy_tWithConstTy_t_LEN1 := bool_len1_c; + WithConstTy_tWithConstTy_t_LEN2 := with_const_ty_len2_c; + WithConstTy_tWithConstTy_t_V := u8; + WithConstTy_tWithConstTy_t_W := u64; + WithConstTy_tWithConstTy_t_W_clause_0 := u64_ToU64Inst; + WithConstTy_t_f := bool_f; +|}. + +(** [traits::use_with_const_ty1]: forward function *) +Definition use_with_const_ty1 + (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) : result usize := + let i := inst.(WithConstTy_tWithConstTy_t_LEN1) in Return i +. + +(** [traits::use_with_const_ty2]: forward function *) +Definition use_with_const_ty2 + (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) + (w : inst.(WithConstTy_tWithConstTy_t_W)) : + result unit + := + Return tt +. + +(** [traits::use_with_const_ty3]: forward function *) +Definition use_with_const_ty3 + (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) + (x : inst.(WithConstTy_tWithConstTy_t_W)) : + result u64 + := + inst.(WithConstTy_tWithConstTy_t_W_clause_0).(ToU64_t_to_u64) x +. + +(** [traits::test_where1]: forward function *) +Definition test_where1 (T : Type) (_x : T) : result unit := + Return tt. + +(** [traits::test_where2]: forward function *) +Definition test_where2 + (T : Type) (inst : WithConstTy_t T 32%usize) (_x : u32) : result unit := + Return tt +. + +(** [alloc::string::String] *) +Axiom alloc_string_String_t : Type. + +(** Trait declaration: [traits::ParentTrait0] *) +Record ParentTrait0_t (Self : Type) := mkParentTrait0_t { + ParentTrait0_tParentTrait0_t_W : Type; + ParentTrait0_t_get_name : Self -> result alloc_string_String_t; + ParentTrait0_t_get_w : Self -> result ParentTrait0_tParentTrait0_t_W; +}. + +Arguments mkParentTrait0_t { _ }. +Arguments ParentTrait0_tParentTrait0_t_W { _ }. +Arguments ParentTrait0_t_get_name { _ }. +Arguments ParentTrait0_t_get_w { _ }. + +(** Trait declaration: [traits::ParentTrait1] *) +Record ParentTrait1_t (Self : Type) := mkParentTrait1_t{}. + +Arguments mkParentTrait1_t { _ }. + +(** Trait declaration: [traits::ChildTrait] *) +Record ChildTrait_t (Self : Type) := mkChildTrait_t { + ChildTrait_tChildTrait_t_parent_clause_0 : ParentTrait0_t Self; + ChildTrait_tChildTrait_t_parent_clause_1 : ParentTrait1_t Self; +}. + +Arguments mkChildTrait_t { _ }. +Arguments ChildTrait_tChildTrait_t_parent_clause_0 { _ }. +Arguments ChildTrait_tChildTrait_t_parent_clause_1 { _ }. + +(** [traits::test_child_trait1]: forward function *) +Definition test_child_trait1 + (T : Type) (inst : ChildTrait_t T) (x : T) : result alloc_string_String_t := + inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_name) x +. + +(** [traits::test_child_trait2]: forward function *) +Definition test_child_trait2 + (T : Type) (inst : ChildTrait_t T) (x : T) : + result + inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_tParentTrait0_t_W) + := + inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_w) x +. + +(** [traits::order1]: forward function *) +Definition order1 + (T U : Type) (inst : ParentTrait0_t T) (inst0 : ParentTrait0_t U) : + result unit + := + Return tt +. + +(** Trait declaration: [traits::ChildTrait1] *) +Record ChildTrait1_t (Self : Type) := mkChildTrait1_t { + ChildTrait1_tChildTrait1_t_parent_clause_0 : ParentTrait1_t Self; +}. + +Arguments mkChildTrait1_t { _ }. +Arguments ChildTrait1_tChildTrait1_t_parent_clause_0 { _ }. + +(** Trait implementation: [traits::usize::{9}] *) +Definition usize_ParentTrait1Inst : ParentTrait1_t usize := mkParentTrait1_t. + +(** Trait implementation: [traits::usize::{10}] *) +Definition usize_ChildTrait1Inst : ChildTrait1_t usize := {| + ChildTrait1_tChildTrait1_t_parent_clause_0 := usize_ParentTrait1Inst; +|}. + +(** Trait declaration: [traits::Iterator] *) +Record Iterator_t (Self : Type) := mkIterator_t { + Iterator_tIterator_t_Item : Type; +}. + +Arguments mkIterator_t { _ }. +Arguments Iterator_tIterator_t_Item { _ }. + +(** Trait declaration: [traits::IntoIterator] *) +Record IntoIterator_t (Self : Type) := mkIntoIterator_t { + IntoIterator_tIntoIterator_t_Item : Type; + IntoIterator_tIntoIterator_t_IntoIter : Type; + IntoIterator_tIntoIterator_t_IntoIter_clause_0 : Iterator_t + IntoIterator_tIntoIterator_t_IntoIter; + IntoIterator_t_into_iter : Self -> result + IntoIterator_tIntoIterator_t_IntoIter; +}. + +Arguments mkIntoIterator_t { _ }. +Arguments IntoIterator_tIntoIterator_t_Item { _ }. +Arguments IntoIterator_tIntoIterator_t_IntoIter { _ }. +Arguments IntoIterator_tIntoIterator_t_IntoIter_clause_0 { _ }. +Arguments IntoIterator_t_into_iter { _ }. + +(** Trait declaration: [traits::FromResidual] *) +Record FromResidual_t (Self T : Type) := mkFromResidual_t{}. + +Arguments mkFromResidual_t { _ _ }. + +(** Trait declaration: [traits::Try] *) +Record Try_t (Self : Type) := mkTry_t { + Try_tTry_t_Residual : Type; + Try_tTry_t_parent_clause_0 : FromResidual_t Self Try_tTry_t_Residual; +}. + +Arguments mkTry_t { _ }. +Arguments Try_tTry_t_Residual { _ }. +Arguments Try_tTry_t_parent_clause_0 { _ }. + +(** Trait declaration: [traits::WithTarget] *) +Record WithTarget_t (Self : Type) := mkWithTarget_t { + WithTarget_tWithTarget_t_Target : Type; +}. + +Arguments mkWithTarget_t { _ }. +Arguments WithTarget_tWithTarget_t_Target { _ }. + +(** Trait declaration: [traits::ParentTrait2] *) +Record ParentTrait2_t (Self : Type) := mkParentTrait2_t { + ParentTrait2_tParentTrait2_t_U : Type; + ParentTrait2_tParentTrait2_t_U_clause_0 : WithTarget_t + ParentTrait2_tParentTrait2_t_U; +}. + +Arguments mkParentTrait2_t { _ }. +Arguments ParentTrait2_tParentTrait2_t_U { _ }. +Arguments ParentTrait2_tParentTrait2_t_U_clause_0 { _ }. + +(** Trait declaration: [traits::ChildTrait2] *) +Record ChildTrait2_t (Self : Type) := mkChildTrait2_t { + ChildTrait2_tChildTrait2_t_parent_clause_0 : ParentTrait2_t Self; + ChildTrait2_t_convert : + (ChildTrait2_tChildTrait2_t_parent_clause_0).(ParentTrait2_tParentTrait2_t_U) + -> result + (ChildTrait2_tChildTrait2_t_parent_clause_0).(ParentTrait2_tParentTrait2_t_U_clause_0).(WithTarget_tWithTarget_t_Target); +}. + +Arguments mkChildTrait2_t { _ }. +Arguments ChildTrait2_tChildTrait2_t_parent_clause_0 { _ }. +Arguments ChildTrait2_t_convert { _ }. + +(** Trait implementation: [traits::u32::{11}] *) +Definition u32_WithTargetInst : WithTarget_t u32 := {| + WithTarget_tWithTarget_t_Target := u32; +|}. + +(** Trait implementation: [traits::u32::{12}] *) +Definition u32_ParentTrait2Inst : ParentTrait2_t u32 := {| + ParentTrait2_tParentTrait2_t_U := u32; + ParentTrait2_tParentTrait2_t_U_clause_0 := u32_WithTargetInst; +|}. + +(** [traits::u32::{13}::convert]: forward function *) +Definition u32_convert (x : u32) : result u32 := + Return x. + +(** Trait implementation: [traits::u32::{13}] *) +Definition u32_ChildTrait2Inst : ChildTrait2_t u32 := {| + ChildTrait2_tChildTrait2_t_parent_clause_0 := u32_ParentTrait2Inst; + ChildTrait2_t_convert := u32_convert; +|}. + +(** [traits::incr_u32]: forward function *) +Definition incr_u32 (x : u32) : result u32 := + u32_add x 1%u32. + +(** Trait declaration: [traits::CFnOnce] *) +Record CFnOnce_t (Self Args : Type) := mkCFnOnce_t { + CFnOnce_tCFnOnce_t_Output : Type; + CFnOnce_t_call_once : Self -> Args -> result CFnOnce_tCFnOnce_t_Output; +}. + +Arguments mkCFnOnce_t { _ _ }. +Arguments CFnOnce_tCFnOnce_t_Output { _ _ }. +Arguments CFnOnce_t_call_once { _ _ }. + +(** Trait declaration: [traits::CFnMut] *) +Record CFnMut_t (Self Args : Type) := mkCFnMut_t { + CFnMut_tCFnMut_t_parent_clause_0 : CFnOnce_t Self Args; + CFnMut_t_call_mut : Self -> Args -> result + (CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output); + CFnMut_t_call_mut_back : Self -> Args -> + (CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output) -> result + Self; +}. + +Arguments mkCFnMut_t { _ _ }. +Arguments CFnMut_tCFnMut_t_parent_clause_0 { _ _ }. +Arguments CFnMut_t_call_mut { _ _ }. +Arguments CFnMut_t_call_mut_back { _ _ }. + +(** Trait declaration: [traits::CFn] *) +Record CFn_t (Self Args : Type) := mkCFn_t { + CFn_tCFn_t_parent_clause_0 : CFnMut_t Self Args; + CFn_t_call_mut : Self -> Args -> result + (CFn_tCFn_t_parent_clause_0).(CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output); +}. + +Arguments mkCFn_t { _ _ }. +Arguments CFn_tCFn_t_parent_clause_0 { _ _ }. +Arguments CFn_t_call_mut { _ _ }. + +End Traits . diff --git a/tests/coq/traits/_CoqProject b/tests/coq/traits/_CoqProject index d573657e..5b6199fc 100644 --- a/tests/coq/traits/_CoqProject +++ b/tests/coq/traits/_CoqProject @@ -3,3 +3,5 @@ -arg -w -arg all +Traits.v +Primitives.v -- cgit v1.2.3 From 00705bba68fed61d3b0bcde2c5fe0ecc83880870 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 18:37:07 +0100 Subject: Update the failing proofs --- backends/fstar/Primitives.fst | 18 +- backends/lean/Base/Primitives/Vec.lean | 26 +- backends/lean/Base/Progress/Progress.lean | 2 +- tests/fstar/array/Array.Opaque.fsti | 24 - tests/fstar/array/Primitives.fst | 18 +- tests/fstar/betree/Primitives.fst | 18 +- tests/fstar/betree_back_stateful/Primitives.fst | 18 +- tests/fstar/hashmap/Hashmap.Properties.fst | 1648 ++++++++++---------- tests/fstar/hashmap/Hashmap.Properties.fsti | 100 +- tests/fstar/hashmap/Primitives.fst | 18 +- .../hashmap_on_disk/HashmapMain.Properties.fst | 20 +- tests/fstar/hashmap_on_disk/Primitives.fst | 18 +- tests/fstar/misc/Loops.fst | 784 ---------- tests/fstar/misc/Primitives.fst | 18 +- tests/fstar/traits/Primitives.fst | 18 +- tests/lean/Hashmap/Properties.lean | 11 +- 16 files changed, 1049 insertions(+), 1710 deletions(-) delete mode 100644 tests/fstar/array/Array.Opaque.fsti delete mode 100644 tests/fstar/misc/Loops.fst diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 71d75c11..3297803c 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index e1b7e87b..bbed6082 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -81,7 +81,7 @@ theorem Vec.insert_spec {α : Type u} (v: Vec α) (i: Usize) (x: α) ∃ nv, v.insert α i x = ret nv ∧ nv.val = v.val.update i.val x := by simp [insert, *] -def Vec.index_usize (α : Type u) (v: Vec α) (i: Usize) : Result α := +def Vec.index_usize {α : Type u} (v: Vec α) (i: Usize) : Result α := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some x => ret x @@ -94,13 +94,13 @@ def Vec.index_usize (α : Type u) (v: Vec α) (i: Usize) : Result α := @[pspec] theorem Vec.index_usize_spec {α : Type u} [Inhabited α] (v: Vec α) (i: Usize) (hbound : i.val < v.length) : - ∃ x, v.index_usize α i = ret x ∧ x = v.val.index i.val := by + ∃ x, v.index_usize i = ret x ∧ x = v.val.index i.val := by simp only [index_usize] -- TODO: dependent rewrite have h := List.indexOpt_eq_index v.val i.val (by scalar_tac) (by simp [*]) simp [*] -def Vec.update_usize (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := +def Vec.update_usize {α : Type u} (v: Vec α) (i: Usize) (x: α) : Result (Vec α) := match v.val.indexOpt i.val with | none => fail .arrayOutOfBounds | some _ => @@ -109,7 +109,7 @@ def Vec.update_usize (α : Type u) (v: Vec α) (i: Usize) (x: α) : Result (Vec @[pspec] theorem Vec.update_usize_spec {α : Type u} (v: Vec α) (i: Usize) (x : α) (hbound : i.val < v.length) : - ∃ nv, v.update_usize α i x = ret nv ∧ + ∃ nv, v.update_usize i x = ret nv ∧ nv.val = v.val.update i.val x := by simp only [update_usize] @@ -151,6 +151,24 @@ def Vec.coreopsindexIndexMutInst (T I : Type) index_mut_back := Vec.index_mut_back T I inst } +@[simp] +theorem Vec.index_slice_index {α : Type} (v : Vec α) (i : Usize) : + Vec.index α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i = + Vec.index_usize v i := + sorry + +@[simp] +theorem Vec.index_mut_slice_index {α : Type} (v : Vec α) (i : Usize) : + Vec.index_mut α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i = + Vec.index_usize v i := + sorry + +@[simp] +theorem Vec.index_mut_back_slice_index {α : Type} (v : Vec α) (i : Usize) (x : α) : + Vec.index_mut_back α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i x = + Vec.update_usize v i x := + sorry + end alloc.vec end Primitives diff --git a/backends/lean/Base/Progress/Progress.lean b/backends/lean/Base/Progress/Progress.lean index 24c6f912..ba63f09d 100644 --- a/backends/lean/Base/Progress/Progress.lean +++ b/backends/lean/Base/Progress/Progress.lean @@ -409,7 +409,7 @@ namespace Test `α : Type u` where u is quantified, while here we use `α : Type 0` -/ example {α : Type} (v: Vec α) (i: Usize) (x : α) (hbounds : i.val < v.length) : - ∃ nv, v.update_usize α i x = ret nv ∧ + ∃ nv, v.update_usize i x = ret nv ∧ nv.val = v.val.update i.val x := by progress simp [*] diff --git a/tests/fstar/array/Array.Opaque.fsti b/tests/fstar/array/Array.Opaque.fsti deleted file mode 100644 index 484cb9ee..00000000 --- a/tests/fstar/array/Array.Opaque.fsti +++ /dev/null @@ -1,24 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [array]: external function declarations *) -module Array.Opaque -open Primitives -include Array.Types - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [core::array::[T; N]::{15}::index]: forward function *) -val core_array_[T; N]_index_fwd - (t i : Type0) (n : usize) (inst : core_ops_index_Index (slice t) i) : - array t n -> i -> result inst.core_ops_index_Index_Output - -(** [core::array::[T; N]::{16}::index_mut]: forward function *) -val core_array_[T; N]_index_mut_fwd - (t i : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) i) : - array t n -> i -> result inst.index_inst.core_ops_index_Index_Output - -(** [core::array::[T; N]::{16}::index_mut]: backward function 0 *) -val core_array_[T; N]_index_mut_back - (t i : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) i) : - array t n -> i -> inst.index_inst.core_ops_index_Index_Output -> result - (array t n) - diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/fstar/hashmap/Hashmap.Properties.fst b/tests/fstar/hashmap/Hashmap.Properties.fst index 49d96cd5..def520f0 100644 --- a/tests/fstar/hashmap/Hashmap.Properties.fst +++ b/tests/fstar/hashmap/Hashmap.Properties.fst @@ -272,7 +272,7 @@ type pos_usize = x:usize{x > 0} type binding (t : Type0) = key & t -type slots_t (t : Type0) = vec (list_t t) +type slots_t (t : Type0) = alloc_vec_Vec (list_t t) /// We represent hash maps as associative lists type assoc_list (t : Type0) = list (binding t) @@ -280,8 +280,8 @@ type assoc_list (t : Type0) = list (binding t) /// Representation function for [list_t] let rec list_t_v (#t : Type0) (ls : list_t t) : assoc_list t = match ls with - | ListNil -> [] - | ListCons k v tl -> (k,v) :: list_t_v tl + | List_Nil -> [] + | List_Cons k v tl -> (k,v) :: list_t_v tl let list_t_len (#t : Type0) (ls : list_t t) : nat = length (list_t_v ls) let list_t_index (#t : Type0) (ls : list_t t) (i : nat{i < list_t_len ls}) : binding t = @@ -305,30 +305,30 @@ let slots_t_al_v (#t : Type0) (slots : slots_t t) : assoc_list t = /// list per slot). This is the representation we use most, internally. Note that /// we later introduce a [map_s] representation, which is the one used in the /// lemmas shown to the user. -type hash_map_s t = list (slot_s t) +type hashMap_s t = list (slot_s t) // TODO: why not always have the condition on the length? // 'nes': "non-empty slots" -type hash_map_s_nes (t : Type0) : Type0 = - hm:hash_map_s t{is_pos_usize (length hm)} +type hashMap_s_nes (t : Type0) : Type0 = + hm:hashMap_s t{is_pos_usize (length hm)} -/// Representation function for [hash_map_t] as a list of slots -let hash_map_t_v (#t : Type0) (hm : hash_map_t t) : hash_map_s t = - map list_t_v hm.hash_map_slots +/// Representation function for [hashMap_t] as a list of slots +let hashMap_t_v (#t : Type0) (hm : hashMap_t t) : hashMap_s t = + map list_t_v hm.slots -/// Representation function for [hash_map_t] as an associative list -let hash_map_t_al_v (#t : Type0) (hm : hash_map_t t) : assoc_list t = - flatten (hash_map_t_v hm) +/// Representation function for [hashMap_t] as an associative list +let hashMap_t_al_v (#t : Type0) (hm : hashMap_t t) : assoc_list t = + flatten (hashMap_t_v hm) // 'nes': "non-empty slots" -type hash_map_t_nes (t : Type0) : Type0 = - hm:hash_map_t t{is_pos_usize (length hm.hash_map_slots)} +type hashMap_t_nes (t : Type0) : Type0 = + hm:hashMap_t t{is_pos_usize (length hm.slots)} -let hash_key (k : key) : hash = - Return?.v (hash_key_fwd k) +let hash_key_s (k : key) : hash = + Return?.v (hash_key k) let hash_mod_key (k : key) (len : usize{len > 0}) : hash = - (hash_key k) % len + (hash_key_s k) % len let not_same_key (#t : Type0) (k : key) (b : binding t) : bool = fst b <> k let same_key (#t : Type0) (k : key) (b : binding t) : bool = fst b = k @@ -339,8 +339,8 @@ let same_hash_mod_key (#t : Type0) (len : usize{len > 0}) (h : nat) (b : binding let binding_neq (#t : Type0) (b0 b1 : binding t) : bool = fst b0 <> fst b1 -let hash_map_t_len_s (#t : Type0) (hm : hash_map_t t) : nat = - hm.hash_map_num_entries +let hashMap_t_len_s (#t : Type0) (hm : hashMap_t t) : nat = + hm.num_entries let assoc_list_find (#t : Type0) (k : key) (slot : assoc_list t) : option t = match find (same_key k) slot with @@ -354,26 +354,26 @@ let slot_t_find_s (#t : Type0) (k : key) (slot : list_t t) : option t = slot_s_find k (slot_t_v slot) // This is a simpler version of the "find" function, which captures the essence -// of what happens and operates on [hash_map_s]. -let hash_map_s_find - (#t : Type0) (hm : hash_map_s_nes t) +// of what happens and operates on [hashMap_s]. +let hashMap_s_find + (#t : Type0) (hm : hashMap_s_nes t) (k : key) : option t = let i = hash_mod_key k (length hm) in let slot = index hm i in slot_s_find k slot -let hash_map_s_len - (#t : Type0) (hm : hash_map_s t) : +let hashMap_s_len + (#t : Type0) (hm : hashMap_s t) : nat = length (flatten hm) -// Same as above, but operates on [hash_map_t] +// Same as above, but operates on [hashMap_t] // Note that we don't reuse the above function on purpose: converting to a -// [hash_map_s] then looking up an element is not the same as what we +// [hashMap_s] then looking up an element is not the same as what we // wrote below. -let hash_map_t_find_s - (#t : Type0) (hm : hash_map_t t{length hm.hash_map_slots > 0}) (k : key) : option t = - let slots = hm.hash_map_slots in +let hashMap_t_find_s + (#t : Type0) (hm : hashMap_t t{length hm.slots > 0}) (k : key) : option t = + let slots = hm.slots in let i = hash_mod_key k (length slots) in let slot = index slots i in slot_t_find_s k slot @@ -404,74 +404,74 @@ let slots_t_inv (#t : Type0) (slots : slots_t t{length slots <= usize_max}) : Ty {:pattern index slots i} slot_t_inv (length slots) i (index slots i) -let hash_map_s_inv (#t : Type0) (hm : hash_map_s t) : Type0 = +let hashMap_s_inv (#t : Type0) (hm : hashMap_s t) : Type0 = length hm <= usize_max /\ length hm > 0 /\ slots_s_inv hm /// Base invariant for the hashmap (the complete invariant can be temporarily /// broken between the moment we inserted an element and the moment we resize) -let hash_map_t_base_inv (#t : Type0) (hm : hash_map_t t) : Type0 = - let al = hash_map_t_al_v hm in +let hashMap_t_base_inv (#t : Type0) (hm : hashMap_t t) : Type0 = + let al = hashMap_t_al_v hm in // [num_entries] correctly tracks the number of entries in the table // Note that it gives us that the length of the slots array is <= usize_max: // [> length <= usize_max - // (because hash_map_num_entries has type `usize`) - hm.hash_map_num_entries = length al /\ + // (because hashMap_num_entries has type `usize`) + hm.num_entries = length al /\ // Slots invariant - slots_t_inv hm.hash_map_slots /\ + slots_t_inv hm.slots /\ // The capacity must be > 0 (otherwise we can't resize, because we // multiply the capacity by two!) - length hm.hash_map_slots > 0 /\ + length hm.slots > 0 /\ // Load computation begin - let capacity = length hm.hash_map_slots in - let (dividend, divisor) = hm.hash_map_max_load_factor in + let capacity = length hm.slots in + let (dividend, divisor) = hm.max_load_factor in 0 < dividend /\ dividend < divisor /\ capacity * dividend >= divisor /\ - hm.hash_map_max_load = (capacity * dividend) / divisor + hm.max_load = (capacity * dividend) / divisor end /// We often need to frame some values -let hash_map_t_same_params (#t : Type0) (hm0 hm1 : hash_map_t t) : Type0 = - length hm0.hash_map_slots = length hm1.hash_map_slots /\ - hm0.hash_map_max_load = hm1.hash_map_max_load /\ - hm0.hash_map_max_load_factor = hm1.hash_map_max_load_factor +let hashMap_t_same_params (#t : Type0) (hm0 hm1 : hashMap_t t) : Type0 = + length hm0.slots = length hm1.slots /\ + hm0.max_load = hm1.max_load /\ + hm0.max_load_factor = hm1.max_load_factor /// The following invariants, etc. are meant to be revealed to the user through /// the .fsti. /// Invariant for the hashmap -let hash_map_t_inv (#t : Type0) (hm : hash_map_t t) : Type0 = +let hashMap_t_inv (#t : Type0) (hm : hashMap_t t) : Type0 = // Base invariant - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // The hash map is either: not overloaded, or we can't resize it begin - let (dividend, divisor) = hm.hash_map_max_load_factor in - hm.hash_map_num_entries <= hm.hash_map_max_load - || length hm.hash_map_slots * 2 * dividend > usize_max + let (dividend, divisor) = hm.max_load_factor in + hm.num_entries <= hm.max_load + || length hm.slots * 2 * dividend > usize_max end (*** .fsti *) /// We reveal slightly different version of the above functions to the user -let len_s (#t : Type0) (hm : hash_map_t t) : nat = hash_map_t_len_s hm +let len_s (#t : Type0) (hm : hashMap_t t) : nat = hashMap_t_len_s hm -/// This version doesn't take any precondition (contrary to [hash_map_t_find_s]) -let find_s (#t : Type0) (hm : hash_map_t t) (k : key) : option t = - if length hm.hash_map_slots = 0 then None - else hash_map_t_find_s hm k +/// This version doesn't take any precondition (contrary to [hashMap_t_find_s]) +let find_s (#t : Type0) (hm : hashMap_t t) (k : key) : option t = + if length hm.slots = 0 then None + else hashMap_t_find_s hm k (*** Overloading *) -let hash_map_not_overloaded_lem #t hm = () +let hashMap_not_overloaded_lem #t hm = () (*** allocate_slots *) /// Auxiliary lemma val slots_t_all_nil_inv_lem - (#t : Type0) (slots : vec (list_t t){length slots <= usize_max}) : - Lemma (requires (forall (i:nat{i < length slots}). index slots i == ListNil)) + (#t : Type0) (slots : alloc_vec_Vec (list_t t){length slots <= usize_max}) : + Lemma (requires (forall (i:nat{i < length slots}). index slots i == List_Nil)) (ensures (slots_t_inv slots)) #push-options "--fuel 1" @@ -479,8 +479,8 @@ let slots_t_all_nil_inv_lem #t slots = () #pop-options val slots_t_al_v_all_nil_is_empty_lem - (#t : Type0) (slots : vec (list_t t)) : - Lemma (requires (forall (i:nat{i < length slots}). index slots i == ListNil)) + (#t : Type0) (slots : alloc_vec_Vec (list_t t)) : + Lemma (requires (forall (i:nat{i < length slots}). index slots i == List_Nil)) (ensures (slots_t_al_v slots == [])) #push-options "--fuel 1" @@ -492,44 +492,44 @@ let rec slots_t_al_v_all_nil_is_empty_lem #t slots = slots_t_al_v_all_nil_is_empty_lem #t slots'; assert(slots_t_al_v slots == list_t_v s @ slots_t_al_v slots'); assert(slots_t_al_v slots == list_t_v s); - assert(index slots 0 == ListNil) + assert(index slots 0 == List_Nil) #pop-options /// [allocate_slots] -val hash_map_allocate_slots_fwd_lem - (t : Type0) (slots : vec (list_t t)) (n : usize) : +val hashMap_allocate_slots_lem + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : Lemma (requires (length slots + n <= usize_max)) (ensures ( - match hash_map_allocate_slots_fwd t slots n with + match hashMap_allocate_slots t slots n with | Fail _ -> False | Return slots' -> length slots' = length slots + n /\ // We leave the already allocated slots unchanged (forall (i:nat{i < length slots}). index slots' i == index slots i) /\ // We allocate n additional empty slots - (forall (i:nat{length slots <= i /\ i < length slots'}). index slots' i == ListNil))) - (decreases (hash_map_allocate_slots_loop_decreases t slots n)) + (forall (i:nat{length slots <= i /\ i < length slots'}). index slots' i == List_Nil))) + (decreases (hashMap_allocate_slots_loop_decreases t slots n)) #push-options "--fuel 1" -let rec hash_map_allocate_slots_fwd_lem t slots n = +let rec hashMap_allocate_slots_lem t slots n = begin match n with | 0 -> () | _ -> - begin match vec_push_back (list_t t) slots ListNil with + begin match alloc_vec_Vec_push (list_t t) slots List_Nil with | Fail _ -> () | Return slots1 -> begin match usize_sub n 1 with | Fail _ -> () | Return i -> - hash_map_allocate_slots_fwd_lem t slots1 i; - begin match hash_map_allocate_slots_fwd t slots1 i with + hashMap_allocate_slots_lem t slots1 i; + begin match hashMap_allocate_slots t slots1 i with | Fail _ -> () | Return slots2 -> assert(length slots1 = length slots + 1); - assert(slots1 == slots @ [ListNil]); // Triggers patterns - assert(index slots1 (length slots) == index [ListNil] 0); // Triggers patterns - assert(index slots1 (length slots) == ListNil) + assert(slots1 == slots @ [List_Nil]); // Triggers patterns + assert(index slots1 (length slots) == index [List_Nil] 0); // Triggers patterns + assert(index slots1 (length slots) == List_Nil) end end end @@ -538,7 +538,7 @@ let rec hash_map_allocate_slots_fwd_lem t slots n = (*** new_with_capacity *) /// Under proper conditions, [new_with_capacity] doesn't fail and returns an empty hash map. -val hash_map_new_with_capacity_fwd_lem +val hashMap_new_with_capacity_lem (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : Lemma @@ -549,31 +549,31 @@ val hash_map_new_with_capacity_fwd_lem capacity * max_load_dividend >= max_load_divisor /\ capacity * max_load_dividend <= usize_max)) (ensures ( - match hash_map_new_with_capacity_fwd t capacity max_load_dividend max_load_divisor with + match hashMap_new_with_capacity t capacity max_load_dividend max_load_divisor with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The parameters are correct - hm.hash_map_max_load_factor = (max_load_dividend, max_load_divisor) /\ - hm.hash_map_max_load = (capacity * max_load_dividend) / max_load_divisor /\ + hm.max_load_factor = (max_load_dividend, max_load_divisor) /\ + hm.max_load = (capacity * max_load_dividend) / max_load_divisor /\ // The hash map has the specified capacity - we need to reveal this - // otherwise the pre of [hash_map_t_find_s] is not satisfied. - length hm.hash_map_slots = capacity /\ + // otherwise the pre of [hashMap_t_find_s] is not satisfied. + length hm.slots = capacity /\ // The hash map has 0 values - hash_map_t_len_s hm = 0 /\ + hashMap_t_len_s hm = 0 /\ // It contains no bindings - (forall k. hash_map_t_find_s hm k == None) /\ + (forall k. hashMap_t_find_s hm k == None) /\ // We need this low-level property for the invariant - (forall(i:nat{i < length hm.hash_map_slots}). index hm.hash_map_slots i == ListNil))) + (forall(i:nat{i < length hm.slots}). index hm.slots i == List_Nil))) #push-options "--z3rlimit 50 --fuel 1" -let hash_map_new_with_capacity_fwd_lem (t : Type0) (capacity : usize) +let hashMap_new_with_capacity_lem (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) = - let v = vec_new (list_t t) in + let v = alloc_vec_Vec_new (list_t t) in assert(length v = 0); - hash_map_allocate_slots_fwd_lem t v capacity; - begin match hash_map_allocate_slots_fwd t v capacity with + hashMap_allocate_slots_lem t v capacity; + begin match hashMap_allocate_slots t v capacity with | Fail _ -> assert(False) | Return v0 -> begin match usize_mul capacity max_load_dividend with @@ -582,9 +582,9 @@ let hash_map_new_with_capacity_fwd_lem (t : Type0) (capacity : usize) begin match usize_div i max_load_divisor with | Fail _ -> assert(False) | Return i0 -> - let hm = Mkhash_map_t 0 (max_load_dividend, max_load_divisor) i0 v0 in + let hm = MkhashMap_t 0 (max_load_dividend, max_load_divisor) i0 v0 in slots_t_all_nil_inv_lem v0; - slots_t_al_v_all_nil_is_empty_lem hm.hash_map_slots + slots_t_al_v_all_nil_is_empty_lem hm.slots end end end @@ -593,65 +593,65 @@ let hash_map_new_with_capacity_fwd_lem (t : Type0) (capacity : usize) (*** new *) /// [new] doesn't fail and returns an empty hash map -val hash_map_new_fwd_lem_aux (t : Type0) : +val hashMap_new_lem_aux (t : Type0) : Lemma (ensures ( - match hash_map_new_fwd t with + match hashMap_new t with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The hash map has 0 values - hash_map_t_len_s hm = 0 /\ + hashMap_t_len_s hm = 0 /\ // It contains no bindings - (forall k. hash_map_t_find_s hm k == None))) + (forall k. hashMap_t_find_s hm k == None))) #push-options "--fuel 1" -let hash_map_new_fwd_lem_aux t = - hash_map_new_with_capacity_fwd_lem t 32 4 5; - match hash_map_new_with_capacity_fwd t 32 4 5 with +let hashMap_new_lem_aux t = + hashMap_new_with_capacity_lem t 32 4 5; + match hashMap_new_with_capacity t 32 4 5 with | Fail _ -> () | Return hm -> () #pop-options /// The lemma we reveal in the .fsti -let hash_map_new_fwd_lem t = hash_map_new_fwd_lem_aux t +let hashMap_new_lem t = hashMap_new_lem_aux t (*** clear *) /// [clear]: the loop doesn't fail and simply clears the slots starting at index i #push-options "--fuel 1" -let rec hash_map_clear_loop_fwd_back_lem - (t : Type0) (slots : vec (list_t t)) (i : usize) : +let rec hashMap_clear_loop_lem + (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : Lemma (ensures ( - match hash_map_clear_loop_fwd_back t slots i with + match hashMap_clear_loop t slots i with | Fail _ -> False | Return slots' -> // The length is preserved length slots' == length slots /\ // The slots before i are left unchanged (forall (j:nat{j < i /\ j < length slots}). index slots' j == index slots j) /\ - // The slots after i are set to ListNil - (forall (j:nat{i <= j /\ j < length slots}). index slots' j == ListNil))) - (decreases (hash_map_clear_loop_decreases t slots i)) + // The slots after i are set to List_Nil + (forall (j:nat{i <= j /\ j < length slots}). index slots' j == List_Nil))) + (decreases (hashMap_clear_loop_decreases t slots i)) = - let i0 = vec_len (list_t t) slots in + let i0 = alloc_vec_Vec_len (list_t t) slots in let b = i < i0 in if b then - begin match vec_index_mut_back (list_t t) slots i ListNil with + begin match alloc_vec_Vec_update_usize slots i List_Nil with | Fail _ -> () | Return v -> begin match usize_add i 1 with | Fail _ -> () | Return i1 -> - hash_map_clear_loop_fwd_back_lem t v i1; - begin match hash_map_clear_loop_fwd_back t v i1 with + hashMap_clear_loop_lem t v i1; + begin match hashMap_clear_loop t v i1 with | Fail _ -> () | Return slots1 -> assert(length slots1 == length slots); - assert(forall (j:nat{i+1 <= j /\ j < length slots}). index slots1 j == ListNil); - assert(index slots1 i == ListNil) + assert(forall (j:nat{i+1 <= j /\ j < length slots}). index slots1 j == List_Nil); + assert(index slots1 i == List_Nil) end end end @@ -659,80 +659,80 @@ let rec hash_map_clear_loop_fwd_back_lem #pop-options /// [clear] doesn't fail and turns the hash map into an empty map -val hash_map_clear_fwd_back_lem_aux - (#t : Type0) (self : hash_map_t t) : +val hashMap_clear_lem_aux + (#t : Type0) (self : hashMap_t t) : Lemma - (requires (hash_map_t_base_inv self)) + (requires (hashMap_t_base_inv self)) (ensures ( - match hash_map_clear_fwd_back t self with + match hashMap_clear t self with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // We preserved the parameters - hash_map_t_same_params hm self /\ + hashMap_t_same_params hm self /\ // The hash map has 0 values - hash_map_t_len_s hm = 0 /\ + hashMap_t_len_s hm = 0 /\ // It contains no bindings - (forall k. hash_map_t_find_s hm k == None))) + (forall k. hashMap_t_find_s hm k == None))) // Being lazy: fuel 1 helps a lot... #push-options "--fuel 1" -let hash_map_clear_fwd_back_lem_aux #t self = - let p = self.hash_map_max_load_factor in - let i = self.hash_map_max_load in - let v = self.hash_map_slots in - hash_map_clear_loop_fwd_back_lem t v 0; - begin match hash_map_clear_loop_fwd_back t v 0 with +let hashMap_clear_lem_aux #t self = + let p = self.max_load_factor in + let i = self.max_load in + let v = self.slots in + hashMap_clear_loop_lem t v 0; + begin match hashMap_clear_loop t v 0 with | Fail _ -> () | Return slots1 -> slots_t_al_v_all_nil_is_empty_lem slots1; - let hm1 = Mkhash_map_t 0 p i slots1 in - assert(hash_map_t_base_inv hm1); - assert(hash_map_t_inv hm1) + let hm1 = MkhashMap_t 0 p i slots1 in + assert(hashMap_t_base_inv hm1); + assert(hashMap_t_inv hm1) end #pop-options -let hash_map_clear_fwd_back_lem #t self = hash_map_clear_fwd_back_lem_aux #t self +let hashMap_clear_lem #t self = hashMap_clear_lem_aux #t self (*** len *) /// [len]: we link it to a non-failing function. /// Rk.: we might want to make an analysis to not use an error monad to translate /// functions which statically can't fail. -let hash_map_len_fwd_lem #t self = () +let hashMap_len_lem #t self = () (*** insert_in_list *) (**** insert_in_list'fwd *) -/// [insert_in_list_fwd]: returns true iff the key is not in the list (functional version) -val hash_map_insert_in_list_fwd_lem +/// [insert_in_list]: returns true iff the key is not in the list (functional version) +val hashMap_insert_in_list_lem (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (ensures ( - match hash_map_insert_in_list_fwd t key value ls with + match hashMap_insert_in_list t key value ls with | Fail _ -> False | Return b -> b <==> (slot_t_find_s key ls == None))) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) #push-options "--fuel 1" -let rec hash_map_insert_in_list_fwd_lem t key value ls = +let rec hashMap_insert_in_list_lem t key value ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_insert_in_list_fwd_lem t key value ls0; - match hash_map_insert_in_list_fwd t key value ls0 with + hashMap_insert_in_list_lem t key value ls0; + match hashMap_insert_in_list t key value ls0 with | Fail _ -> () | Return b0 -> () end - | ListNil -> + | List_Nil -> assert(list_t_v ls == []); assert_norm(find (same_key #t key) [] == None) end @@ -748,7 +748,7 @@ let rec hash_map_insert_in_list_fwd_lem t key value ls = /// We write a helper which "captures" what [insert_in_list] does. /// We then reason about this helper to prove the high-level properties we want /// (functional properties, preservation of invariants, etc.). -let hash_map_insert_in_list_s +let hashMap_insert_in_list_s (#t : Type0) (key : usize) (value : t) (ls : list (binding t)) : list (binding t) = // Check if there is already a binding for the key @@ -761,86 +761,86 @@ let hash_map_insert_in_list_s find_update (same_key key) ls (key,value) /// [insert_in_list]: if the key is not in the map, appends a new bindings (functional version) -val hash_map_insert_in_list_back_lem_append_s +val hashMap_insert_in_list_back_lem_append_s (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( slot_t_find_s key ls == None)) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> list_t_v ls' == list_t_v ls @ [(key,value)])) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) #push-options "--fuel 1" -let rec hash_map_insert_in_list_back_lem_append_s t key value ls = +let rec hashMap_insert_in_list_back_lem_append_s t key value ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_insert_in_list_back_lem_append_s t key value ls0; - match hash_map_insert_in_list_back t key value ls0 with + hashMap_insert_in_list_back_lem_append_s t key value ls0; + match hashMap_insert_in_list_back t key value ls0 with | Fail _ -> () | Return l -> () end - | ListNil -> () + | List_Nil -> () end #pop-options /// [insert_in_list]: if the key is in the map, we update the binding (functional version) -val hash_map_insert_in_list_back_lem_update_s +val hashMap_insert_in_list_back_lem_update_s (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( Some? (find (same_key key) (list_t_v ls)))) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> list_t_v ls' == find_update (same_key key) (list_t_v ls) (key,value))) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) #push-options "--fuel 1" -let rec hash_map_insert_in_list_back_lem_update_s t key value ls = +let rec hashMap_insert_in_list_back_lem_update_s t key value ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_insert_in_list_back_lem_update_s t key value ls0; - match hash_map_insert_in_list_back t key value ls0 with + hashMap_insert_in_list_back_lem_update_s t key value ls0; + match hashMap_insert_in_list_back t key value ls0 with | Fail _ -> () | Return l -> () end - | ListNil -> () + | List_Nil -> () end #pop-options /// Put everything together -val hash_map_insert_in_list_back_lem_s +val hashMap_insert_in_list_back_lem_s (t : Type0) (key : usize) (value : t) (ls : list_t t) : Lemma (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> - list_t_v ls' == hash_map_insert_in_list_s key value (list_t_v ls))) + list_t_v ls' == hashMap_insert_in_list_s key value (list_t_v ls))) -let hash_map_insert_in_list_back_lem_s t key value ls = +let hashMap_insert_in_list_back_lem_s t key value ls = match find (same_key key) (list_t_v ls) with - | None -> hash_map_insert_in_list_back_lem_append_s t key value ls - | Some _ -> hash_map_insert_in_list_back_lem_update_s t key value ls + | None -> hashMap_insert_in_list_back_lem_append_s t key value ls + | Some _ -> hashMap_insert_in_list_back_lem_update_s t key value ls (**** Invariants of insert_in_list_s *) /// Auxiliary lemmas -/// We work on [hash_map_insert_in_list_s], the "high-level" version of [insert_in_list'back]. +/// We work on [hashMap_insert_in_list_s], the "high-level" version of [insert_in_list'back]. /// /// Note that in F* we can't have recursive proofs inside of other proofs, contrary /// to Coq, which makes it a bit cumbersome to prove auxiliary results like the @@ -893,14 +893,14 @@ let rec slot_s_inv_not_find_append_end_inv_lem t len key value ls = #pop-options /// [insert_in_list]: if the key is not in the map, appends a new bindings -val hash_map_insert_in_list_s_lem_append +val hashMap_insert_in_list_s_lem_append (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list (binding t)) : Lemma (requires ( slot_s_inv len (hash_mod_key key len) ls /\ slot_s_find key ls == None)) (ensures ( - let ls' = hash_map_insert_in_list_s key value ls in + let ls' = hashMap_insert_in_list_s key value ls in ls' == ls @ [(key,value)] /\ // The invariant is preserved slot_s_inv len (hash_mod_key key len) ls' /\ @@ -909,20 +909,20 @@ val hash_map_insert_in_list_s_lem_append // The other bindings are preserved (forall k'. k' <> key ==> slot_s_find k' ls' == slot_s_find k' ls))) -let hash_map_insert_in_list_s_lem_append t len key value ls = +let hashMap_insert_in_list_s_lem_append t len key value ls = slot_s_inv_not_find_append_end_inv_lem t len key value ls /// [insert_in_list]: if the key is not in the map, appends a new bindings (quantifiers) /// Rk.: we don't use this lemma. /// TODO: remove? -val hash_map_insert_in_list_back_lem_append +val hashMap_insert_in_list_back_lem_append (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( slot_t_inv len (hash_mod_key key len) ls /\ slot_t_find_s key ls == None)) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> list_t_v ls' == list_t_v ls @ [(key,value)] /\ @@ -933,9 +933,9 @@ val hash_map_insert_in_list_back_lem_append // The other bindings are preserved (forall k'. k' <> key ==> slot_t_find_s k' ls' == slot_t_find_s k' ls))) -let hash_map_insert_in_list_back_lem_append t len key value ls = - hash_map_insert_in_list_back_lem_s t key value ls; - hash_map_insert_in_list_s_lem_append t len key value (list_t_v ls) +let hashMap_insert_in_list_back_lem_append t len key value ls = + hashMap_insert_in_list_back_lem_s t key value ls; + hashMap_insert_in_list_s_lem_append t len key value (list_t_v ls) (** Auxiliary lemmas: update case *) @@ -1013,14 +1013,14 @@ let rec slot_s_inv_find_append_end_inv_lem t len key value ls = #pop-options /// [insert_in_list]: if the key is in the map, update the bindings -val hash_map_insert_in_list_s_lem_update +val hashMap_insert_in_list_s_lem_update (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list (binding t)) : Lemma (requires ( slot_s_inv len (hash_mod_key key len) ls /\ Some? (slot_s_find key ls))) (ensures ( - let ls' = hash_map_insert_in_list_s key value ls in + let ls' = hashMap_insert_in_list_s key value ls in ls' == find_update (same_key key) ls (key,value) /\ // The invariant is preserved slot_s_inv len (hash_mod_key key len) ls' /\ @@ -1029,20 +1029,20 @@ val hash_map_insert_in_list_s_lem_update // The other bindings are preserved (forall k'. k' <> key ==> slot_s_find k' ls' == slot_s_find k' ls))) -let hash_map_insert_in_list_s_lem_update t len key value ls = +let hashMap_insert_in_list_s_lem_update t len key value ls = slot_s_inv_find_append_end_inv_lem t len key value ls /// [insert_in_list]: if the key is in the map, update the bindings /// TODO: not used: remove? -val hash_map_insert_in_list_back_lem_update +val hashMap_insert_in_list_back_lem_update (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list_t t) : Lemma (requires ( slot_t_inv len (hash_mod_key key len) ls /\ Some? (slot_t_find_s key ls))) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> let als = list_t_v ls in @@ -1054,20 +1054,20 @@ val hash_map_insert_in_list_back_lem_update // The other bindings are preserved (forall k'. k' <> key ==> slot_t_find_s k' ls' == slot_t_find_s k' ls))) -let hash_map_insert_in_list_back_lem_update t len key value ls = - hash_map_insert_in_list_back_lem_s t key value ls; - hash_map_insert_in_list_s_lem_update t len key value (list_t_v ls) +let hashMap_insert_in_list_back_lem_update t len key value ls = + hashMap_insert_in_list_back_lem_s t key value ls; + hashMap_insert_in_list_s_lem_update t len key value (list_t_v ls) (** Final lemmas about [insert_in_list] *) /// High-level version -val hash_map_insert_in_list_s_lem +val hashMap_insert_in_list_s_lem (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list (binding t)) : Lemma (requires ( slot_s_inv len (hash_mod_key key len) ls)) (ensures ( - let ls' = hash_map_insert_in_list_s key value ls in + let ls' = hashMap_insert_in_list_s key value ls in // The invariant is preserved slot_s_inv len (hash_mod_key key len) ls' /\ // [key] maps to [value] @@ -1079,22 +1079,22 @@ val hash_map_insert_in_list_s_lem | None -> length ls' = length ls + 1 | Some _ -> length ls' = length ls))) -let hash_map_insert_in_list_s_lem t len key value ls = +let hashMap_insert_in_list_s_lem t len key value ls = match slot_s_find key ls with | None -> assert_norm(length [(key,value)] = 1); - hash_map_insert_in_list_s_lem_append t len key value ls + hashMap_insert_in_list_s_lem_append t len key value ls | Some _ -> - hash_map_insert_in_list_s_lem_update t len key value ls + hashMap_insert_in_list_s_lem_update t len key value ls /// [insert_in_list] /// TODO: not used: remove? -val hash_map_insert_in_list_back_lem +val hashMap_insert_in_list_back_lem (t : Type0) (len : usize{len > 0}) (key : usize) (value : t) (ls : list_t t) : Lemma (requires (slot_t_inv len (hash_mod_key key len) ls)) (ensures ( - match hash_map_insert_in_list_back t key value ls with + match hashMap_insert_in_list_back t key value ls with | Fail _ -> False | Return ls' -> // The invariant is preserved @@ -1111,127 +1111,127 @@ val hash_map_insert_in_list_back_lem | Some _ -> list_t_v ls' == find_update (same_key key) (list_t_v ls) (key,value) /\ list_t_len ls' = list_t_len ls))) - (decreases (hash_map_insert_in_list_loop_decreases t key value ls)) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) -let hash_map_insert_in_list_back_lem t len key value ls = - hash_map_insert_in_list_back_lem_s t key value ls; - hash_map_insert_in_list_s_lem t len key value (list_t_v ls) +let hashMap_insert_in_list_back_lem t len key value ls = + hashMap_insert_in_list_back_lem_s t key value ls; + hashMap_insert_in_list_s_lem t len key value (list_t_v ls) (*** insert_no_resize *) (**** Refinement proof *) /// Same strategy as for [insert_in_list]: we introduce a high-level version of /// the function, and reason about it. -/// We work on [hash_map_s] (we use a higher-level view of the hash-map, but +/// We work on [hashMap_s] (we use a higher-level view of the hash-map, but /// not too high). /// A high-level version of insert, which doesn't check if the table is saturated -let hash_map_insert_no_fail_s - (#t : Type0) (hm : hash_map_s_nes t) +let hashMap_insert_no_fail_s + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : - hash_map_s t = + hashMap_s t = let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - let slot' = hash_map_insert_in_list_s key value slot in + let slot' = hashMap_insert_in_list_s key value slot in let hm' = list_update hm i slot' in hm' -// TODO: at some point I used hash_map_s_nes and it broke proofs...x -let hash_map_insert_no_resize_s - (#t : Type0) (hm : hash_map_s_nes t) +// TODO: at some point I used hashMap_s_nes and it broke proofs...x +let hashMap_insert_no_resize_s + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : - result (hash_map_s t) = + result (hashMap_s t) = // Check if the table is saturated (too many entries, and we need to insert one) let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then Fail Failure - else Return (hash_map_insert_no_fail_s hm key value) + if None? (hashMap_s_find hm key) && num_entries = usize_max then Fail Failure + else Return (hashMap_insert_no_fail_s hm key value) -/// Prove that [hash_map_insert_no_resize_s] is refined by -/// [hash_map_insert_no_resize'fwd_back] -val hash_map_insert_no_resize_fwd_back_lem_s - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : +/// Prove that [hashMap_insert_no_resize_s] is refined by +/// [hashMap_insert_no_resize'fwd_back] +val hashMap_insert_no_resize_lem_s + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : Lemma (requires ( - hash_map_t_base_inv self /\ - hash_map_s_len (hash_map_t_v self) = hash_map_t_len_s self)) + hashMap_t_base_inv self /\ + hashMap_s_len (hashMap_t_v self) = hashMap_t_len_s self)) (ensures ( begin - match hash_map_insert_no_resize_fwd_back t self key value, - hash_map_insert_no_resize_s (hash_map_t_v self) key value + match hashMap_insert_no_resize t self key value, + hashMap_insert_no_resize_s (hashMap_t_v self) key value with | Fail _, Fail _ -> True | Return hm, Return hm_v -> - hash_map_t_base_inv hm /\ - hash_map_t_same_params hm self /\ - hash_map_t_v hm == hm_v /\ - hash_map_s_len hm_v == hash_map_t_len_s hm + hashMap_t_base_inv hm /\ + hashMap_t_same_params hm self /\ + hashMap_t_v hm == hm_v /\ + hashMap_s_len hm_v == hashMap_t_len_s hm | _ -> False end)) -let hash_map_insert_no_resize_fwd_back_lem_s t self key value = - begin match hash_key_fwd key with +let hashMap_insert_no_resize_lem_s t self key value = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let p = self.hash_map_max_load_factor in - let i1 = self.hash_map_max_load in - let v = self.hash_map_slots in - let i2 = vec_len (list_t t) v in + let i0 = self.num_entries in + let p = self.max_load_factor in + let i1 = self.max_load in + let v = self.slots in + let i2 = alloc_vec_Vec_len (list_t t) v in let len = length v in begin match usize_rem i i2 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - // Checking that: list_t_v (index ...) == index (hash_map_t_v ...) ... - assert(list_t_v l == index (hash_map_t_v self) hash_mod); - hash_map_insert_in_list_fwd_lem t key value l; - match hash_map_insert_in_list_fwd t key value l with + // Checking that: list_t_v (index ...) == index (hashMap_t_v ...) ... + assert(list_t_v l == index (hashMap_t_v self) hash_mod); + hashMap_insert_in_list_lem t key value l; + match hashMap_insert_in_list t key value l with | Fail _ -> () | Return b -> assert(b = None? (slot_s_find key (list_t_v l))); - hash_map_insert_in_list_back_lem t len key value l; + hashMap_insert_in_list_back_lem t len key value l; if b then begin match usize_add i0 1 with | Fail _ -> () | Return i3 -> begin - match hash_map_insert_in_list_back t key value l with + match hashMap_insert_in_list_back t key value l with | Fail _ -> () | Return l0 -> - begin match vec_index_mut_back (list_t t) v hash_mod l0 with + begin match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> - let self_v = hash_map_t_v self in - let hm = Mkhash_map_t i3 p i1 v0 in - let hm_v = hash_map_t_v hm in + let self_v = hashMap_t_v self in + let hm = MkhashMap_t i3 p i1 v0 in + let hm_v = hashMap_t_v hm in assert(hm_v == list_update self_v hash_mod (list_t_v l0)); assert_norm(length [(key,value)] = 1); assert(length (list_t_v l0) = length (list_t_v l) + 1); length_flatten_update self_v hash_mod (list_t_v l0); - assert(hash_map_s_len hm_v = hash_map_t_len_s hm) + assert(hashMap_s_len hm_v = hashMap_t_len_s hm) end end end else begin - match hash_map_insert_in_list_back t key value l with + match hashMap_insert_in_list_back t key value l with | Fail _ -> () | Return l0 -> - begin match vec_index_mut_back (list_t t) v hash_mod l0 with + begin match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> - let self_v = hash_map_t_v self in - let hm = Mkhash_map_t i0 p i1 v0 in - let hm_v = hash_map_t_v hm in + let self_v = hashMap_t_v self in + let hm = MkhashMap_t i0 p i1 v0 in + let hm_v = hashMap_t_v hm in assert(hm_v == list_update self_v hash_mod (list_t_v l0)); assert(length (list_t_v l0) = length (list_t_v l)); length_flatten_update self_v hash_mod (list_t_v l0); - assert(hash_map_s_len hm_v = hash_map_t_len_s hm) + assert(hashMap_s_len hm_v = hashMap_t_len_s hm) end end end @@ -1241,108 +1241,108 @@ let hash_map_insert_no_resize_fwd_back_lem_s t self key value = (**** insert_{no_fail,no_resize}: invariants *) -let hash_map_s_updated_binding - (#t : Type0) (hm : hash_map_s_nes t) - (key : usize) (opt_value : option t) (hm' : hash_map_s_nes t) : Type0 = +let hashMap_s_updated_binding + (#t : Type0) (hm : hashMap_s_nes t) + (key : usize) (opt_value : option t) (hm' : hashMap_s_nes t) : Type0 = // [key] maps to [value] - hash_map_s_find hm' key == opt_value /\ + hashMap_s_find hm' key == opt_value /\ // The other bindings are preserved - (forall k'. k' <> key ==> hash_map_s_find hm' k' == hash_map_s_find hm k') + (forall k'. k' <> key ==> hashMap_s_find hm' k' == hashMap_s_find hm k') -let insert_post (#t : Type0) (hm : hash_map_s_nes t) - (key : usize) (value : t) (hm' : hash_map_s_nes t) : Type0 = +let insert_post (#t : Type0) (hm : hashMap_s_nes t) + (key : usize) (value : t) (hm' : hashMap_s_nes t) : Type0 = // The invariant is preserved - hash_map_s_inv hm' /\ + hashMap_s_inv hm' /\ // [key] maps to [value] and the other bindings are preserved - hash_map_s_updated_binding hm key (Some value) hm' /\ + hashMap_s_updated_binding hm key (Some value) hm' /\ // The length is incremented, iff we inserted a new key - (match hash_map_s_find hm key with - | None -> hash_map_s_len hm' = hash_map_s_len hm + 1 - | Some _ -> hash_map_s_len hm' = hash_map_s_len hm) + (match hashMap_s_find hm key with + | None -> hashMap_s_len hm' = hashMap_s_len hm + 1 + | Some _ -> hashMap_s_len hm' = hashMap_s_len hm) -val hash_map_insert_no_fail_s_lem - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_insert_no_fail_s_lem + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : Lemma - (requires (hash_map_s_inv hm)) + (requires (hashMap_s_inv hm)) (ensures ( - let hm' = hash_map_insert_no_fail_s hm key value in + let hm' = hashMap_insert_no_fail_s hm key value in insert_post hm key value hm')) -let hash_map_insert_no_fail_s_lem #t hm key value = +let hashMap_insert_no_fail_s_lem #t hm key value = let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - hash_map_insert_in_list_s_lem t len key value slot; - let slot' = hash_map_insert_in_list_s key value slot in + hashMap_insert_in_list_s_lem t len key value slot; + let slot' = hashMap_insert_in_list_s key value slot in length_flatten_update hm i slot' -val hash_map_insert_no_resize_s_lem - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_insert_no_resize_s_lem + (#t : Type0) (hm : hashMap_s_nes t) (key : usize) (value : t) : Lemma - (requires (hash_map_s_inv hm)) + (requires (hashMap_s_inv hm)) (ensures ( - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> // Can fail only if we need to create a new binding in // an already saturated map - hash_map_s_len hm = usize_max /\ - None? (hash_map_s_find hm key) + hashMap_s_len hm = usize_max /\ + None? (hashMap_s_find hm key) | Return hm' -> insert_post hm key value hm')) -let hash_map_insert_no_resize_s_lem #t hm key value = +let hashMap_insert_no_resize_s_lem #t hm key value = let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then () - else hash_map_insert_no_fail_s_lem hm key value + if None? (hashMap_s_find hm key) && num_entries = usize_max then () + else hashMap_insert_no_fail_s_lem hm key value (**** find after insert *) /// Lemmas about what happens if we call [find] after an insertion -val hash_map_insert_no_resize_s_get_same_lem - (#t : Type0) (hm : hash_map_s t) +val hashMap_insert_no_resize_s_get_same_lem + (#t : Type0) (hm : hashMap_s t) (key : usize) (value : t) : - Lemma (requires (hash_map_s_inv hm)) + Lemma (requires (hashMap_s_inv hm)) (ensures ( - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> True | Return hm' -> - hash_map_s_find hm' key == Some value)) + hashMap_s_find hm' key == Some value)) -let hash_map_insert_no_resize_s_get_same_lem #t hm key value = +let hashMap_insert_no_resize_s_get_same_lem #t hm key value = let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then () + if None? (hashMap_s_find hm key) && num_entries = usize_max then () else begin - let hm' = Return?.v (hash_map_insert_no_resize_s hm key value) in + let hm' = Return?.v (hashMap_insert_no_resize_s hm key value) in let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - hash_map_insert_in_list_s_lem t len key value slot + hashMap_insert_in_list_s_lem t len key value slot end -val hash_map_insert_no_resize_s_get_diff_lem - (#t : Type0) (hm : hash_map_s t) +val hashMap_insert_no_resize_s_get_diff_lem + (#t : Type0) (hm : hashMap_s t) (key : usize) (value : t) (key' : usize{key' <> key}) : - Lemma (requires (hash_map_s_inv hm)) + Lemma (requires (hashMap_s_inv hm)) (ensures ( - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> True | Return hm' -> - hash_map_s_find hm' key' == hash_map_s_find hm key')) + hashMap_s_find hm' key' == hashMap_s_find hm key')) -let hash_map_insert_no_resize_s_get_diff_lem #t hm key value key' = +let hashMap_insert_no_resize_s_get_diff_lem #t hm key value key' = let num_entries = length (flatten hm) in - if None? (hash_map_s_find hm key) && num_entries = usize_max then () + if None? (hashMap_s_find hm key) && num_entries = usize_max then () else begin - let hm' = Return?.v (hash_map_insert_no_resize_s hm key value) in + let hm' = Return?.v (hashMap_insert_no_resize_s hm key value) in let len = length hm in let i = hash_mod_key key len in let slot = index hm i in - hash_map_insert_in_list_s_lem t len key value slot; + hashMap_insert_in_list_s_lem t len key value slot; let i' = hash_mod_key key' len in if i <> i' then () else @@ -1354,116 +1354,116 @@ let hash_map_insert_no_resize_s_get_diff_lem #t hm key value key' = (*** move_elements_from_list *) -/// Having a great time here: if we use `result (hash_map_s_res t)` as the -/// return type for [hash_map_move_elements_from_list_s] instead of having this -/// awkward match, the proof of [hash_map_move_elements_fwd_back_lem_refin] fails. +/// Having a great time here: if we use `result (hashMap_s_res t)` as the +/// return type for [hashMap_move_elements_from_list_s] instead of having this +/// awkward match, the proof of [hashMap_move_elements_lem_refin] fails. /// I guess it comes from F*'s poor subtyping. -/// Followingly, I'm not taking any chance and using [result_hash_map_s] +/// Followingly, I'm not taking any chance and using [result_hashMap_s] /// everywhere. -type result_hash_map_s_nes (t : Type0) : Type0 = - res:result (hash_map_s t) { +type result_hashMap_s_nes (t : Type0) : Type0 = + res:result (hashMap_s t) { match res with | Fail _ -> True | Return hm -> is_pos_usize (length hm) } -let rec hash_map_move_elements_from_list_s - (#t : Type0) (hm : hash_map_s_nes t) +let rec hashMap_move_elements_from_list_s + (#t : Type0) (hm : hashMap_s_nes t) (ls : slot_s t) : - // Do *NOT* use `result (hash_map_s t)` - Tot (result_hash_map_s_nes t) + // Do *NOT* use `result (hashMap_s t)` + Tot (result_hashMap_s_nes t) (decreases ls) = match ls with | [] -> Return hm | (key, value) :: ls' -> - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail e -> Fail e | Return hm' -> - hash_map_move_elements_from_list_s hm' ls' + hashMap_move_elements_from_list_s hm' ls' /// Refinement lemma -val hash_map_move_elements_from_list_fwd_back_lem - (t : Type0) (ntable : hash_map_t_nes t) (ls : list_t t) : - Lemma (requires (hash_map_t_base_inv ntable)) +val hashMap_move_elements_from_list_lem + (t : Type0) (ntable : hashMap_t_nes t) (ls : list_t t) : + Lemma (requires (hashMap_t_base_inv ntable)) (ensures ( - match hash_map_move_elements_from_list_fwd_back t ntable ls, - hash_map_move_elements_from_list_s (hash_map_t_v ntable) (slot_t_v ls) + match hashMap_move_elements_from_list t ntable ls, + hashMap_move_elements_from_list_s (hashMap_t_v ntable) (slot_t_v ls) with | Fail _, Fail _ -> True | Return hm', Return hm_v -> - hash_map_t_base_inv hm' /\ - hash_map_t_v hm' == hm_v /\ - hash_map_t_same_params hm' ntable + hashMap_t_base_inv hm' /\ + hashMap_t_v hm' == hm_v /\ + hashMap_t_same_params hm' ntable | _ -> False)) - (decreases (hash_map_move_elements_from_list_loop_decreases t ntable ls)) + (decreases (hashMap_move_elements_from_list_loop_decreases t ntable ls)) #push-options "--fuel 1" -let rec hash_map_move_elements_from_list_fwd_back_lem t ntable ls = +let rec hashMap_move_elements_from_list_lem t ntable ls = begin match ls with - | ListCons k v tl -> + | List_Cons k v tl -> assert(list_t_v ls == (k, v) :: list_t_v tl); let ls_v = list_t_v ls in let (_,_) :: tl_v = ls_v in - hash_map_insert_no_resize_fwd_back_lem_s t ntable k v; - begin match hash_map_insert_no_resize_fwd_back t ntable k v with + hashMap_insert_no_resize_lem_s t ntable k v; + begin match hashMap_insert_no_resize t ntable k v with | Fail _ -> () | Return h -> - let h_v = Return?.v (hash_map_insert_no_resize_s (hash_map_t_v ntable) k v) in - assert(hash_map_t_v h == h_v); - hash_map_move_elements_from_list_fwd_back_lem t h tl; - begin match hash_map_move_elements_from_list_fwd_back t h tl with + let h_v = Return?.v (hashMap_insert_no_resize_s (hashMap_t_v ntable) k v) in + assert(hashMap_t_v h == h_v); + hashMap_move_elements_from_list_lem t h tl; + begin match hashMap_move_elements_from_list t h tl with | Fail _ -> () | Return h0 -> () end end - | ListNil -> () + | List_Nil -> () end #pop-options (*** move_elements *) (**** move_elements: refinement 0 *) -/// The proof for [hash_map_move_elements_fwd_back_lem_refin] broke so many times +/// The proof for [hashMap_move_elements_lem_refin] broke so many times /// (while it is supposed to be super simple!) that we decided to add one refinement /// level, to really do things step by step... /// Doing this refinement layer made me notice that maybe the problem came from -/// the fact that at some point we have to prove `list_t_v ListNil == []`: I +/// the fact that at some point we have to prove `list_t_v List_Nil == []`: I /// added the corresponding assert to help Z3 and everything became stable. /// I finally didn't use this "simple" refinement lemma, but I still keep it here -/// because it allows for easy comparisons with [hash_map_move_elements_s]. +/// because it allows for easy comparisons with [hashMap_move_elements_s]. -/// [hash_map_move_elements_fwd] refines this function, which is actually almost +/// [hashMap_move_elements] refines this function, which is actually almost /// the same (just a little bit shorter and cleaner, and has a pre). /// /// The way I wrote the high-level model is the following: -/// - I copy-pasted the definition of [hash_map_move_elements_fwd], wrote the -/// signature which links this new definition to [hash_map_move_elements_fwd] and +/// - I copy-pasted the definition of [hashMap_move_elements], wrote the +/// signature which links this new definition to [hashMap_move_elements] and /// checked that the proof passed /// - I gradually simplified it, while making sure the proof still passes #push-options "--fuel 1" -let rec hash_map_move_elements_s_simpl - (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) +let rec hashMap_move_elements_s_simpl + (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize{i <= length slots /\ length slots <= usize_max}) : - Pure (result ((hash_map_t t) & (vec (list_t t)))) + Pure (result ((hashMap_t t) & (alloc_vec_Vec (list_t t)))) (requires (True)) (ensures (fun res -> - match res, hash_map_move_elements_fwd_back t ntable slots i with + match res, hashMap_move_elements t ntable slots i with | Fail _, Fail _ -> True | Return (ntable1, slots1), Return (ntable2, slots2) -> ntable1 == ntable2 /\ slots1 == slots2 | _ -> False)) - (decreases (hash_map_move_elements_loop_decreases t ntable slots i)) + (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) = if i < length slots then let slot = index slots i in - begin match hash_map_move_elements_from_list_fwd_back t ntable slot with + begin match hashMap_move_elements_from_list t ntable slot with | Fail e -> Fail e | Return hm' -> - let slots' = list_update slots i ListNil in - hash_map_move_elements_s_simpl t hm' slots' (i+1) + let slots' = list_update slots i List_Nil in + hashMap_move_elements_s_simpl t hm' slots' (i+1) end else Return (ntable, slots) #pop-options @@ -1476,71 +1476,71 @@ let rec hash_map_move_elements_s_simpl // Note that we ignore the returned slots (we thus don't return a pair: // only the new hash map in which we moved the elements from the slots): // this returned value is not used. -let rec hash_map_move_elements_s - (#t : Type0) (hm : hash_map_s_nes t) +let rec hashMap_move_elements_s + (#t : Type0) (hm : hashMap_s_nes t) (slots : slots_s t) (i : usize{i <= length slots /\ length slots <= usize_max}) : - Tot (result_hash_map_s_nes t) + Tot (result_hashMap_s_nes t) (decreases (length slots - i)) = let len = length slots in if i < len then begin let slot = index slots i in - match hash_map_move_elements_from_list_s hm slot with + match hashMap_move_elements_from_list_s hm slot with | Fail e -> Fail e | Return hm' -> let slots' = list_update slots i [] in - hash_map_move_elements_s hm' slots' (i+1) + hashMap_move_elements_s hm' slots' (i+1) end else Return hm -val hash_map_move_elements_fwd_back_lem_refin - (t : Type0) (ntable : hash_map_t t) - (slots : vec (list_t t)) (i : usize{i <= length slots}) : +val hashMap_move_elements_lem_refin + (t : Type0) (ntable : hashMap_t t) + (slots : alloc_vec_Vec (list_t t)) (i : usize{i <= length slots}) : Lemma (requires ( - hash_map_t_base_inv ntable)) + hashMap_t_base_inv ntable)) (ensures ( - match hash_map_move_elements_fwd_back t ntable slots i, - hash_map_move_elements_s (hash_map_t_v ntable) (slots_t_v slots) i + match hashMap_move_elements t ntable slots i, + hashMap_move_elements_s (hashMap_t_v ntable) (slots_t_v slots) i with | Fail _, Fail _ -> True // We will prove later that this is not possible | Return (ntable', _), Return ntable'_v -> - hash_map_t_base_inv ntable' /\ - hash_map_t_v ntable' == ntable'_v /\ - hash_map_t_same_params ntable' ntable + hashMap_t_base_inv ntable' /\ + hashMap_t_v ntable' == ntable'_v /\ + hashMap_t_same_params ntable' ntable | _ -> False)) (decreases (length slots - i)) #restart-solver #push-options "--fuel 1" -let rec hash_map_move_elements_fwd_back_lem_refin t ntable slots i = - assert(hash_map_t_base_inv ntable); - let i0 = vec_len (list_t t) slots in +let rec hashMap_move_elements_lem_refin t ntable slots i = + assert(hashMap_t_base_inv ntable); + let i0 = alloc_vec_Vec_len (list_t t) slots in let b = i < i0 in if b then - begin match vec_index_mut_fwd (list_t t) slots i with + begin match alloc_vec_Vec_index_usize slots i with | Fail _ -> () | Return l -> - let l0 = mem_replace_fwd (list_t t) l ListNil in + let l0 = core_mem_replace (list_t t) l List_Nil in assert(l0 == l); - hash_map_move_elements_from_list_fwd_back_lem t ntable l0; - begin match hash_map_move_elements_from_list_fwd_back t ntable l0 with + hashMap_move_elements_from_list_lem t ntable l0; + begin match hashMap_move_elements_from_list t ntable l0 with | Fail _ -> () | Return h -> - let l1 = mem_replace_back (list_t t) l ListNil in - assert(l1 == ListNil); - assert(slot_t_v #t ListNil == []); // THIS IS IMPORTANT - begin match vec_index_mut_back (list_t t) slots i l1 with + let l1 = core_mem_replace_back (list_t t) l List_Nil in + assert(l1 == List_Nil); + assert(slot_t_v #t List_Nil == []); // THIS IS IMPORTANT + begin match alloc_vec_Vec_update_usize slots i l1 with | Fail _ -> () | Return v -> begin match usize_add i 1 with | Fail _ -> () | Return i1 -> - hash_map_move_elements_fwd_back_lem_refin t h v i1; - begin match hash_map_move_elements_fwd_back t h v i1 with + hashMap_move_elements_lem_refin t h v i1; + begin match hashMap_move_elements t h v i1 with | Fail _ -> - assert(Fail? (hash_map_move_elements_fwd_back t ntable slots i)); + assert(Fail? (hashMap_move_elements t ntable slots i)); () | Return (ntable', v0) -> () end @@ -1560,19 +1560,19 @@ let rec hash_map_move_elements_fwd_back_lem_refin t ntable slots i = /// [ntable] is the hash map to which we move the elements /// [slots] is the current hash map, from which we remove the elements, and seen /// as a "flat" associative list (and not a list of lists) -/// This is actually exactly [hash_map_move_elements_from_list_s]... -let rec hash_map_move_elements_s_flat - (#t : Type0) (ntable : hash_map_s_nes t) +/// This is actually exactly [hashMap_move_elements_from_list_s]... +let rec hashMap_move_elements_s_flat + (#t : Type0) (ntable : hashMap_s_nes t) (slots : assoc_list t) : - Tot (result_hash_map_s_nes t) + Tot (result_hashMap_s_nes t) (decreases slots) = match slots with | [] -> Return ntable | (k,v) :: slots' -> - match hash_map_insert_no_resize_s ntable k v with + match hashMap_insert_no_resize_s ntable k v with | Fail e -> Fail e | Return ntable' -> - hash_map_move_elements_s_flat ntable' slots' + hashMap_move_elements_s_flat ntable' slots' /// The refinment lemmas /// First, auxiliary helpers. @@ -1656,42 +1656,42 @@ let rec flatten_nil_prefix_as_flatten_i #a l i = /// The proof is trivial, the functions are the same. /// Just keeping two definitions to allow changes... -val hash_map_move_elements_from_list_s_as_flat_lem - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_move_elements_from_list_s_as_flat_lem + (#t : Type0) (hm : hashMap_s_nes t) (ls : slot_s t) : Lemma (ensures ( - hash_map_move_elements_from_list_s hm ls == - hash_map_move_elements_s_flat hm ls)) + hashMap_move_elements_from_list_s hm ls == + hashMap_move_elements_s_flat hm ls)) (decreases ls) #push-options "--fuel 1" -let rec hash_map_move_elements_from_list_s_as_flat_lem #t hm ls = +let rec hashMap_move_elements_from_list_s_as_flat_lem #t hm ls = match ls with | [] -> () | (key, value) :: ls' -> - match hash_map_insert_no_resize_s hm key value with + match hashMap_insert_no_resize_s hm key value with | Fail _ -> () | Return hm' -> - hash_map_move_elements_from_list_s_as_flat_lem hm' ls' + hashMap_move_elements_from_list_s_as_flat_lem hm' ls' #pop-options -/// Composition of two calls to [hash_map_move_elements_s_flat] -let hash_map_move_elements_s_flat_comp - (#t : Type0) (hm : hash_map_s_nes t) (slot0 slot1 : slot_s t) : - Tot (result_hash_map_s_nes t) = - match hash_map_move_elements_s_flat hm slot0 with +/// Composition of two calls to [hashMap_move_elements_s_flat] +let hashMap_move_elements_s_flat_comp + (#t : Type0) (hm : hashMap_s_nes t) (slot0 slot1 : slot_s t) : + Tot (result_hashMap_s_nes t) = + match hashMap_move_elements_s_flat hm slot0 with | Fail e -> Fail e - | Return hm1 -> hash_map_move_elements_s_flat hm1 slot1 + | Return hm1 -> hashMap_move_elements_s_flat hm1 slot1 /// High-level desc: /// move_elements (move_elements hm slot0) slo1 == move_elements hm (slot0 @ slot1) -val hash_map_move_elements_s_flat_append_lem - (#t : Type0) (hm : hash_map_s_nes t) (slot0 slot1 : slot_s t) : +val hashMap_move_elements_s_flat_append_lem + (#t : Type0) (hm : hashMap_s_nes t) (slot0 slot1 : slot_s t) : Lemma (ensures ( - match hash_map_move_elements_s_flat_comp hm slot0 slot1, - hash_map_move_elements_s_flat hm (slot0 @ slot1) + match hashMap_move_elements_s_flat_comp hm slot0 slot1, + hashMap_move_elements_s_flat hm (slot0 @ slot1) with | Fail _, Fail _ -> True | Return hm1, Return hm2 -> hm1 == hm2 @@ -1699,14 +1699,14 @@ val hash_map_move_elements_s_flat_append_lem (decreases (slot0)) #push-options "--fuel 1" -let rec hash_map_move_elements_s_flat_append_lem #t hm slot0 slot1 = +let rec hashMap_move_elements_s_flat_append_lem #t hm slot0 slot1 = match slot0 with | [] -> () | (k,v) :: slot0' -> - match hash_map_insert_no_resize_s hm k v with + match hashMap_insert_no_resize_s hm k v with | Fail _ -> () | Return hm' -> - hash_map_move_elements_s_flat_append_lem hm' slot0' slot1 + hashMap_move_elements_s_flat_append_lem hm' slot0' slot1 #pop-options val flatten_i_same_suffix (#a : Type) (l0 l1 : list (list a)) (i : nat) : @@ -1726,16 +1726,16 @@ let rec flatten_i_same_suffix #a l0 l1 i = #pop-options /// Refinement lemma: -/// [hash_map_move_elements_s] refines [hash_map_move_elements_s_flat] +/// [hashMap_move_elements_s] refines [hashMap_move_elements_s_flat] /// (actually the functions are equal on all inputs). -val hash_map_move_elements_s_lem_refin_flat - (#t : Type0) (hm : hash_map_s_nes t) +val hashMap_move_elements_s_lem_refin_flat + (#t : Type0) (hm : hashMap_s_nes t) (slots : slots_s t) (i : nat{i <= length slots /\ length slots <= usize_max}) : Lemma (ensures ( - match hash_map_move_elements_s hm slots i, - hash_map_move_elements_s_flat hm (flatten_i slots i) + match hashMap_move_elements_s hm slots i, + hashMap_move_elements_s_flat hm (flatten_i slots i) with | Fail _, Fail _ -> True | Return hm, Return hm' -> hm == hm' @@ -1743,22 +1743,22 @@ val hash_map_move_elements_s_lem_refin_flat (decreases (length slots - i)) #push-options "--fuel 1" -let rec hash_map_move_elements_s_lem_refin_flat #t hm slots i = +let rec hashMap_move_elements_s_lem_refin_flat #t hm slots i = let len = length slots in if i < len then begin let slot = index slots i in - hash_map_move_elements_from_list_s_as_flat_lem hm slot; - match hash_map_move_elements_from_list_s hm slot with + hashMap_move_elements_from_list_s_as_flat_lem hm slot; + match hashMap_move_elements_from_list_s hm slot with | Fail _ -> assert(flatten_i slots i == slot @ flatten_i slots (i+1)); - hash_map_move_elements_s_flat_append_lem hm slot (flatten_i slots (i+1)); - assert(Fail? (hash_map_move_elements_s_flat hm (flatten_i slots i))) + hashMap_move_elements_s_flat_append_lem hm slot (flatten_i slots (i+1)); + assert(Fail? (hashMap_move_elements_s_flat hm (flatten_i slots i))) | Return hm' -> let slots' = list_update slots i [] in flatten_i_same_suffix slots slots' (i+1); - hash_map_move_elements_s_lem_refin_flat hm' slots' (i+1); - hash_map_move_elements_s_flat_append_lem hm slot (flatten_i slots' (i+1)); + hashMap_move_elements_s_lem_refin_flat hm' slots' (i+1); + hashMap_move_elements_s_flat_append_lem hm slot (flatten_i slots' (i+1)); () end else () @@ -1769,21 +1769,21 @@ let assoc_list_inv (#t : Type0) (al : assoc_list t) : Type0 = pairwise_rel binding_neq al let disjoint_hm_al_on_key - (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) (k : key) : Type0 = - match hash_map_s_find hm k, assoc_list_find k al with + (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) (k : key) : Type0 = + match hashMap_s_find hm k, assoc_list_find k al with | Some _, None | None, Some _ | None, None -> True | Some _, Some _ -> False /// Playing a dangerous game here: using forall quantifiers -let disjoint_hm_al (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) : Type0 = +let disjoint_hm_al (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) : Type0 = forall (k:key). disjoint_hm_al_on_key hm al k let find_in_union_hm_al - (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) (k : key) : + (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) (k : key) : option t = - match hash_map_s_find hm k with + match hashMap_s_find hm k with | Some b -> Some b | None -> assoc_list_find k al @@ -1799,58 +1799,58 @@ let rec for_all_binding_neq_find_lem #t k v al = | b :: al' -> for_all_binding_neq_find_lem k v al' #pop-options -val hash_map_move_elements_s_flat_lem - (#t : Type0) (hm : hash_map_s_nes t) (al : assoc_list t) : +val hashMap_move_elements_s_flat_lem + (#t : Type0) (hm : hashMap_s_nes t) (al : assoc_list t) : Lemma (requires ( // Invariants - hash_map_s_inv hm /\ + hashMap_s_inv hm /\ assoc_list_inv al /\ // The two are disjoint disjoint_hm_al hm al /\ // We can add all the elements to the hashmap - hash_map_s_len hm + length al <= usize_max)) + hashMap_s_len hm + length al <= usize_max)) (ensures ( - match hash_map_move_elements_s_flat hm al with + match hashMap_move_elements_s_flat hm al with | Fail _ -> False // We can't fail | Return hm' -> // The invariant is preserved - hash_map_s_inv hm' /\ + hashMap_s_inv hm' /\ // The new hash map is the union of the two maps - (forall (k:key). hash_map_s_find hm' k == find_in_union_hm_al hm al k) /\ - hash_map_s_len hm' = hash_map_s_len hm + length al)) + (forall (k:key). hashMap_s_find hm' k == find_in_union_hm_al hm al k) /\ + hashMap_s_len hm' = hashMap_s_len hm + length al)) (decreases al) #restart-solver #push-options "--z3rlimit 200 --fuel 1" -let rec hash_map_move_elements_s_flat_lem #t hm al = +let rec hashMap_move_elements_s_flat_lem #t hm al = match al with | [] -> () | (k,v) :: al' -> - hash_map_insert_no_resize_s_lem hm k v; - match hash_map_insert_no_resize_s hm k v with + hashMap_insert_no_resize_s_lem hm k v; + match hashMap_insert_no_resize_s hm k v with | Fail _ -> () | Return hm' -> - assert(hash_map_s_inv hm'); + assert(hashMap_s_inv hm'); assert(assoc_list_inv al'); let disjoint_lem (k' : key) : Lemma (disjoint_hm_al_on_key hm' al' k') [SMTPat (disjoint_hm_al_on_key hm' al' k')] = if k' = k then begin - assert(hash_map_s_find hm' k' == Some v); + assert(hashMap_s_find hm' k' == Some v); for_all_binding_neq_find_lem k v al'; assert(assoc_list_find k' al' == None) end else begin - assert(hash_map_s_find hm' k' == hash_map_s_find hm k'); + assert(hashMap_s_find hm' k' == hashMap_s_find hm k'); assert(assoc_list_find k' al' == assoc_list_find k' al) end in assert(disjoint_hm_al hm' al'); - assert(hash_map_s_len hm' + length al' <= usize_max); - hash_map_move_elements_s_flat_lem hm' al' + assert(hashMap_s_len hm' + length al' <= usize_max); + hashMap_move_elements_s_flat_lem hm' al' #pop-options /// We need to prove that the invariants on the "low-level" representations of @@ -1866,18 +1866,18 @@ let slots_t_inv_implies_slots_s_inv #t slots = // Problem is: I can never really predict for sure with F*... () -val hash_map_t_base_inv_implies_hash_map_s_inv - (#t : Type0) (hm : hash_map_t t) : - Lemma (requires (hash_map_t_base_inv hm)) - (ensures (hash_map_s_inv (hash_map_t_v hm))) +val hashMap_t_base_inv_implies_hashMap_s_inv + (#t : Type0) (hm : hashMap_t t) : + Lemma (requires (hashMap_t_base_inv hm)) + (ensures (hashMap_s_inv (hashMap_t_v hm))) -let hash_map_t_base_inv_implies_hash_map_s_inv #t hm = () // same as previous +let hashMap_t_base_inv_implies_hashMap_s_inv #t hm = () // same as previous /// Introducing a "partial" version of the hash map invariant, which operates on /// a suffix of the hash map. -let partial_hash_map_s_inv +let partial_hashMap_s_inv (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s t{offset + length hm <= usize_max}) : Type0 = + (hm : hashMap_s t{offset + length hm <= usize_max}) : Type0 = forall(i:nat{i < length hm}). {:pattern index hm i} slot_s_inv len (offset + i) (index hm i) /// Auxiliary lemma. @@ -1887,13 +1887,13 @@ val binding_in_previous_slot_implies_neq (#t : Type0) (len : usize{len > 0}) (i : usize) (b : binding t) (offset : usize{i < offset}) - (slots : hash_map_s t{offset + length slots <= usize_max}) : + (slots : hashMap_s t{offset + length slots <= usize_max}) : Lemma (requires ( // The binding comes from a slot not in [slots] hash_mod_key (fst b) len = i /\ // The slots are the well-formed suffix of a hash map - partial_hash_map_s_inv len offset slots)) + partial_hashMap_s_inv len offset slots)) (ensures ( for_all (binding_neq b) (flatten slots))) (decreases slots) @@ -1924,17 +1924,17 @@ let rec binding_in_previous_slot_implies_neq #t len i b offset slots = for_all_append (binding_neq b) s (flatten slots') #pop-options -val partial_hash_map_s_inv_implies_assoc_list_lem +val partial_hashMap_s_inv_implies_assoc_list_lem (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s t{offset + length hm <= usize_max}) : + (hm : hashMap_s t{offset + length hm <= usize_max}) : Lemma (requires ( - partial_hash_map_s_inv len offset hm)) + partial_hashMap_s_inv len offset hm)) (ensures (assoc_list_inv (flatten hm))) (decreases (length hm + length (flatten hm))) #push-options "--fuel 1" -let rec partial_hash_map_s_inv_implies_assoc_list_lem #t len offset hm = +let rec partial_hashMap_s_inv_implies_assoc_list_lem #t len offset hm = match hm with | [] -> () | slot :: hm' -> @@ -1943,8 +1943,8 @@ let rec partial_hash_map_s_inv_implies_assoc_list_lem #t len offset hm = match slot with | [] -> assert(flatten hm == flatten hm'); - assert(partial_hash_map_s_inv len (offset+1) hm'); // Triggers instantiations - partial_hash_map_s_inv_implies_assoc_list_lem len (offset+1) hm' + assert(partial_hashMap_s_inv len (offset+1) hm'); // Triggers instantiations + partial_hashMap_s_inv_implies_assoc_list_lem len (offset+1) hm' | x :: slot' -> assert(flatten (slot' :: hm') == slot' @ flatten hm'); let hm'' = slot' :: hm' in @@ -1953,45 +1953,45 @@ let rec partial_hash_map_s_inv_implies_assoc_list_lem #t len offset hm = assert(index hm 0 == slot); // Triggers instantiations assert(slot_s_inv len offset slot); assert(slot_s_inv len offset slot'); - assert(partial_hash_map_s_inv len offset hm''); - partial_hash_map_s_inv_implies_assoc_list_lem len offset (slot' :: hm'); + assert(partial_hashMap_s_inv len offset hm''); + partial_hashMap_s_inv_implies_assoc_list_lem len offset (slot' :: hm'); // Proving that the key in `x` is different from all the other keys in // the flattened map assert(for_all (binding_neq x) slot'); for_all_append (binding_neq x) slot' (flatten hm'); - assert(partial_hash_map_s_inv len (offset+1) hm'); + assert(partial_hashMap_s_inv len (offset+1) hm'); binding_in_previous_slot_implies_neq #t len offset x (offset+1) hm'; assert(for_all (binding_neq x) (flatten hm')); assert(for_all (binding_neq x) (flatten (slot' :: hm'))) #pop-options -val hash_map_s_inv_implies_assoc_list_lem - (#t : Type0) (hm : hash_map_s t) : - Lemma (requires (hash_map_s_inv hm)) +val hashMap_s_inv_implies_assoc_list_lem + (#t : Type0) (hm : hashMap_s t) : + Lemma (requires (hashMap_s_inv hm)) (ensures (assoc_list_inv (flatten hm))) -let hash_map_s_inv_implies_assoc_list_lem #t hm = - partial_hash_map_s_inv_implies_assoc_list_lem (length hm) 0 hm +let hashMap_s_inv_implies_assoc_list_lem #t hm = + partial_hashMap_s_inv_implies_assoc_list_lem (length hm) 0 hm -val hash_map_t_base_inv_implies_assoc_list_lem - (#t : Type0) (hm : hash_map_t t): - Lemma (requires (hash_map_t_base_inv hm)) - (ensures (assoc_list_inv (hash_map_t_al_v hm))) +val hashMap_t_base_inv_implies_assoc_list_lem + (#t : Type0) (hm : hashMap_t t): + Lemma (requires (hashMap_t_base_inv hm)) + (ensures (assoc_list_inv (hashMap_t_al_v hm))) -let hash_map_t_base_inv_implies_assoc_list_lem #t hm = - hash_map_s_inv_implies_assoc_list_lem (hash_map_t_v hm) +let hashMap_t_base_inv_implies_assoc_list_lem #t hm = + hashMap_s_inv_implies_assoc_list_lem (hashMap_t_v hm) /// For some reason, we can't write the below [forall] directly in the [ensures] /// clause of the next lemma: it makes Z3 fails even with a huge rlimit. /// I have no idea what's going on. -let hash_map_is_assoc_list - (#t : Type0) (ntable : hash_map_t t{length ntable.hash_map_slots > 0}) +let hashMap_is_assoc_list + (#t : Type0) (ntable : hashMap_t t{length ntable.slots > 0}) (al : assoc_list t) : Type0 = - (forall (k:key). hash_map_t_find_s ntable k == assoc_list_find k al) + (forall (k:key). hashMap_t_find_s ntable k == assoc_list_find k al) -let partial_hash_map_s_find +let partial_hashMap_s_find (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s_nes t{offset + length hm = len}) + (hm : hashMap_s_nes t{offset + length hm = len}) (k : key{hash_mod_key k len >= offset}) : option t = let i = hash_mod_key k len in let slot = index hm (i - offset) in @@ -2021,13 +2021,13 @@ val key_in_previous_slot_implies_not_found (#t : Type0) (len : usize{len > 0}) (k : key) (offset : usize) - (slots : hash_map_s t{offset + length slots = len}) : + (slots : hashMap_s t{offset + length slots = len}) : Lemma (requires ( // The binding comes from a slot not in [slots] hash_mod_key k len < offset /\ // The slots are the well-formed suffix of a hash map - partial_hash_map_s_inv len offset slots)) + partial_hashMap_s_inv len offset slots)) (ensures ( assoc_list_find k (flatten slots) == None)) (decreases slots) @@ -2045,19 +2045,19 @@ let rec key_in_previous_slot_implies_not_found #t len k offset slots = key_in_previous_slot_implies_not_found len k (offset+1) slots' #pop-options -val partial_hash_map_s_is_assoc_list_lem +val partial_hashMap_s_is_assoc_list_lem (#t : Type0) (len : usize{len > 0}) (offset : usize) - (hm : hash_map_s_nes t{offset + length hm = len}) + (hm : hashMap_s_nes t{offset + length hm = len}) (k : key{hash_mod_key k len >= offset}) : Lemma (requires ( - partial_hash_map_s_inv len offset hm)) + partial_hashMap_s_inv len offset hm)) (ensures ( - partial_hash_map_s_find len offset hm k == assoc_list_find k (flatten hm))) + partial_hashMap_s_find len offset hm k == assoc_list_find k (flatten hm))) (decreases hm) #push-options "--fuel 1" -let rec partial_hash_map_s_is_assoc_list_lem #t len offset hm k = +let rec partial_hashMap_s_is_assoc_list_lem #t len offset hm k = match hm with | [] -> () | slot :: hm' -> @@ -2066,7 +2066,7 @@ let rec partial_hash_map_s_is_assoc_list_lem #t len offset hm k = if i = 0 then begin // We must look in the current slot - assert(partial_hash_map_s_find len offset hm k == slot_s_find k slot); + assert(partial_hashMap_s_find len offset hm k == slot_s_find k slot); find_append (same_key k) slot (flatten hm'); assert(forall (i:nat{i < length hm'}). index hm' i == index hm (i+1)); // Triggers instantiations key_in_previous_slot_implies_not_found #t len k (offset+1) hm'; @@ -2085,64 +2085,64 @@ let rec partial_hash_map_s_is_assoc_list_lem #t len offset hm k = else begin // We must ignore the current slot - assert(partial_hash_map_s_find len offset hm k == - partial_hash_map_s_find len (offset+1) hm' k); + assert(partial_hashMap_s_find len offset hm k == + partial_hashMap_s_find len (offset+1) hm' k); find_append (same_key k) slot (flatten hm'); assert(index hm 0 == slot); // Triggers instantiations not_same_hash_key_not_found_in_slot #t len k offset slot; assert(forall (i:nat{i < length hm'}). index hm' i == index hm (i+1)); // Triggers instantiations - partial_hash_map_s_is_assoc_list_lem #t len (offset+1) hm' k + partial_hashMap_s_is_assoc_list_lem #t len (offset+1) hm' k end #pop-options -val hash_map_is_assoc_list_lem (#t : Type0) (hm : hash_map_t t) : - Lemma (requires (hash_map_t_base_inv hm)) - (ensures (hash_map_is_assoc_list hm (hash_map_t_al_v hm))) +val hashMap_is_assoc_list_lem (#t : Type0) (hm : hashMap_t t) : + Lemma (requires (hashMap_t_base_inv hm)) + (ensures (hashMap_is_assoc_list hm (hashMap_t_al_v hm))) -let hash_map_is_assoc_list_lem #t hm = +let hashMap_is_assoc_list_lem #t hm = let aux (k:key) : - Lemma (hash_map_t_find_s hm k == assoc_list_find k (hash_map_t_al_v hm)) - [SMTPat (hash_map_t_find_s hm k)] = - let hm_v = hash_map_t_v hm in + Lemma (hashMap_t_find_s hm k == assoc_list_find k (hashMap_t_al_v hm)) + [SMTPat (hashMap_t_find_s hm k)] = + let hm_v = hashMap_t_v hm in let len = length hm_v in - partial_hash_map_s_is_assoc_list_lem #t len 0 hm_v k + partial_hashMap_s_is_assoc_list_lem #t len 0 hm_v k in () /// The final lemma about [move_elements]: calling it on an empty hash table moves /// all the elements to this empty table. -val hash_map_move_elements_fwd_back_lem - (t : Type0) (ntable : hash_map_t t) (slots : vec (list_t t)) : +val hashMap_move_elements_lem + (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) : Lemma (requires ( let al = flatten (slots_t_v slots) in - hash_map_t_base_inv ntable /\ + hashMap_t_base_inv ntable /\ length al <= usize_max /\ assoc_list_inv al /\ // The table is empty - hash_map_t_len_s ntable = 0 /\ - (forall (k:key). hash_map_t_find_s ntable k == None))) + hashMap_t_len_s ntable = 0 /\ + (forall (k:key). hashMap_t_find_s ntable k == None))) (ensures ( let al = flatten (slots_t_v slots) in - match hash_map_move_elements_fwd_back t ntable slots 0, - hash_map_move_elements_s_flat (hash_map_t_v ntable) al + match hashMap_move_elements t ntable slots 0, + hashMap_move_elements_s_flat (hashMap_t_v ntable) al with | Return (ntable', _), Return ntable'_v -> // The invariant is preserved - hash_map_t_base_inv ntable' /\ + hashMap_t_base_inv ntable' /\ // We preserved the parameters - hash_map_t_same_params ntable' ntable /\ + hashMap_t_same_params ntable' ntable /\ // The table has the same number of slots - length ntable'.hash_map_slots = length ntable.hash_map_slots /\ + length ntable'.slots = length ntable.slots /\ // The count is good - hash_map_t_len_s ntable' = length al /\ + hashMap_t_len_s ntable' = length al /\ // The table can be linked to its model (we need this only to reveal // "pretty" functional lemmas to the user in the fsti - so that we // can write lemmas with SMT patterns - this is very F* specific) - hash_map_t_v ntable' == ntable'_v /\ + hashMap_t_v ntable' == ntable'_v /\ // The new table contains exactly all the bindings from the slots - // Rk.: see the comment for [hash_map_is_assoc_list] - hash_map_is_assoc_list ntable' al + // Rk.: see the comment for [hashMap_is_assoc_list] + hashMap_is_assoc_list ntable' al | _ -> False // We can only succeed )) @@ -2154,41 +2154,41 @@ val hash_map_move_elements_fwd_back_lem // lack of ifuel (this kind of proofs is annoying, really). #restart-solver #push-options "--z3rlimit 100" -let hash_map_move_elements_fwd_back_lem t ntable slots = - let ntable_v = hash_map_t_v ntable in +let hashMap_move_elements_lem t ntable slots = + let ntable_v = hashMap_t_v ntable in let slots_v = slots_t_v slots in let al = flatten slots_v in - hash_map_move_elements_fwd_back_lem_refin t ntable slots 0; + hashMap_move_elements_lem_refin t ntable slots 0; begin - match hash_map_move_elements_fwd_back t ntable slots 0, - hash_map_move_elements_s ntable_v slots_v 0 + match hashMap_move_elements t ntable slots 0, + hashMap_move_elements_s ntable_v slots_v 0 with | Fail _, Fail _ -> () | Return (ntable', _), Return ntable'_v -> - assert(hash_map_t_base_inv ntable'); - assert(hash_map_t_v ntable' == ntable'_v) + assert(hashMap_t_base_inv ntable'); + assert(hashMap_t_v ntable' == ntable'_v) | _ -> assert(False) end; - hash_map_move_elements_s_lem_refin_flat ntable_v slots_v 0; + hashMap_move_elements_s_lem_refin_flat ntable_v slots_v 0; begin - match hash_map_move_elements_s ntable_v slots_v 0, - hash_map_move_elements_s_flat ntable_v (flatten_i slots_v 0) + match hashMap_move_elements_s ntable_v slots_v 0, + hashMap_move_elements_s_flat ntable_v (flatten_i slots_v 0) with | Fail _, Fail _ -> () | Return hm, Return hm' -> assert(hm == hm') | _ -> assert(False) end; flatten_0_is_flatten slots_v; // flatten_i slots_v 0 == flatten slots_v - hash_map_move_elements_s_flat_lem ntable_v al; - match hash_map_move_elements_fwd_back t ntable slots 0, - hash_map_move_elements_s_flat ntable_v al + hashMap_move_elements_s_flat_lem ntable_v al; + match hashMap_move_elements t ntable slots 0, + hashMap_move_elements_s_flat ntable_v al with | Return (ntable', _), Return ntable'_v -> - assert(hash_map_t_base_inv ntable'); - assert(length ntable'.hash_map_slots = length ntable.hash_map_slots); - assert(hash_map_t_len_s ntable' = length al); - assert(hash_map_t_v ntable' == ntable'_v); - assert(hash_map_is_assoc_list ntable' al) + assert(hashMap_t_base_inv ntable'); + assert(length ntable'.slots = length ntable.slots); + assert(hashMap_t_len_s ntable' = length al); + assert(hashMap_t_v ntable' == ntable'_v); + assert(hashMap_is_assoc_list ntable' al) | _ -> assert(False) #pop-options @@ -2197,47 +2197,47 @@ let hash_map_move_elements_fwd_back_lem t ntable slots = /// High-level model 1. /// This is one is slightly "crude": we just simplify a bit the function. -let hash_map_try_resize_s_simpl +let hashMap_try_resize_s_simpl (#t : Type0) - (hm : hash_map_t t) : - Pure (result (hash_map_t t)) + (hm : hashMap_t t) : + Pure (result (hashMap_t t)) (requires ( - let (divid, divis) = hm.hash_map_max_load_factor in + let (divid, divis) = hm.max_load_factor in divid > 0 /\ divis > 0)) (ensures (fun _ -> True)) = - let capacity = length hm.hash_map_slots in - let (divid, divis) = hm.hash_map_max_load_factor in + let capacity = length hm.slots in + let (divid, divis) = hm.max_load_factor in if capacity <= (usize_max / 2) / divid then let ncapacity : usize = capacity * 2 in - begin match hash_map_new_with_capacity_fwd t ncapacity divid divis with + begin match hashMap_new_with_capacity t ncapacity divid divis with | Fail e -> Fail e | Return ntable -> - match hash_map_move_elements_fwd_back t ntable hm.hash_map_slots 0 with + match hashMap_move_elements t ntable hm.slots 0 with | Fail e -> Fail e | Return (ntable', _) -> let hm = - { hm with hash_map_slots = ntable'.hash_map_slots; - hash_map_max_load = ntable'.hash_map_max_load } + { hm with slots = ntable'.slots; + max_load = ntable'.max_load } in Return hm end else Return hm -val hash_map_try_resize_fwd_back_lem_refin - (t : Type0) (self : hash_map_t t) : +val hashMap_try_resize_lem_refin + (t : Type0) (self : hashMap_t t) : Lemma (requires ( - let (divid, divis) = self.hash_map_max_load_factor in + let (divid, divis) = self.max_load_factor in divid > 0 /\ divis > 0)) (ensures ( - match hash_map_try_resize_fwd_back t self, - hash_map_try_resize_s_simpl self + match hashMap_try_resize t self, + hashMap_try_resize_s_simpl self with | Fail _, Fail _ -> True | Return hm1, Return hm2 -> hm1 == hm2 | _ -> False)) -let hash_map_try_resize_fwd_back_lem_refin t self = () +let hashMap_try_resize_lem_refin t self = () /// Isolating arithmetic proofs @@ -2342,78 +2342,78 @@ let new_max_load_lem len capacity divid divis = assert(nmax_load >= max_load + 1) #pop-options -val hash_map_try_resize_s_simpl_lem (#t : Type0) (hm : hash_map_t t) : +val hashMap_try_resize_s_simpl_lem (#t : Type0) (hm : hashMap_t t) : Lemma (requires ( // The base invariant is satisfied - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // However, the "full" invariant is broken, as we call [try_resize] // only if the current number of entries is > the max load. // // There are two situations: // - either we just reached the max load // - or we were already saturated and can't resize - (let (dividend, divisor) = hm.hash_map_max_load_factor in - hm.hash_map_num_entries == hm.hash_map_max_load + 1 \/ - length hm.hash_map_slots * 2 * dividend > usize_max) + (let (dividend, divisor) = hm.max_load_factor in + hm.num_entries == hm.max_load + 1 \/ + length hm.slots * 2 * dividend > usize_max) )) (ensures ( - match hash_map_try_resize_s_simpl hm with + match hashMap_try_resize_s_simpl hm with | Fail _ -> False | Return hm' -> // The full invariant is now satisfied (the full invariant is "base // invariant" + the map is not overloaded (or can't be resized because // already too big) - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // It contains the same bindings as the initial map - (forall (k:key). hash_map_t_find_s hm' k == hash_map_t_find_s hm k))) + (forall (k:key). hashMap_t_find_s hm' k == hashMap_t_find_s hm k))) #restart-solver #push-options "--z3rlimit 400" -let hash_map_try_resize_s_simpl_lem #t hm = - let capacity = length hm.hash_map_slots in - let (divid, divis) = hm.hash_map_max_load_factor in +let hashMap_try_resize_s_simpl_lem #t hm = + let capacity = length hm.slots in + let (divid, divis) = hm.max_load_factor in if capacity <= (usize_max / 2) / divid then begin let ncapacity : usize = capacity * 2 in assert(ncapacity * divid <= usize_max); - assert(hash_map_t_len_s hm = hm.hash_map_max_load + 1); - new_max_load_lem (hash_map_t_len_s hm) capacity divid divis; - hash_map_new_with_capacity_fwd_lem t ncapacity divid divis; - match hash_map_new_with_capacity_fwd t ncapacity divid divis with + assert(hashMap_t_len_s hm = hm.max_load + 1); + new_max_load_lem (hashMap_t_len_s hm) capacity divid divis; + hashMap_new_with_capacity_lem t ncapacity divid divis; + match hashMap_new_with_capacity t ncapacity divid divis with | Fail _ -> () | Return ntable -> - let slots = hm.hash_map_slots in + let slots = hm.slots in let al = flatten (slots_t_v slots) in - // Proving that: length al = hm.hash_map_num_entries + // Proving that: length al = hm.num_entries assert(al == flatten (map slot_t_v slots)); assert(al == flatten (map list_t_v slots)); - assert(hash_map_t_al_v hm == flatten (hash_map_t_v hm)); - assert(hash_map_t_al_v hm == flatten (map list_t_v hm.hash_map_slots)); - assert(al == hash_map_t_al_v hm); - assert(hash_map_t_base_inv ntable); - assert(length al = hm.hash_map_num_entries); + assert(hashMap_t_al_v hm == flatten (hashMap_t_v hm)); + assert(hashMap_t_al_v hm == flatten (map list_t_v hm.slots)); + assert(al == hashMap_t_al_v hm); + assert(hashMap_t_base_inv ntable); + assert(length al = hm.num_entries); assert(length al <= usize_max); - hash_map_t_base_inv_implies_assoc_list_lem hm; + hashMap_t_base_inv_implies_assoc_list_lem hm; assert(assoc_list_inv al); - assert(hash_map_t_len_s ntable = 0); - assert(forall (k:key). hash_map_t_find_s ntable k == None); - hash_map_move_elements_fwd_back_lem t ntable hm.hash_map_slots; - match hash_map_move_elements_fwd_back t ntable hm.hash_map_slots 0 with + assert(hashMap_t_len_s ntable = 0); + assert(forall (k:key). hashMap_t_find_s ntable k == None); + hashMap_move_elements_lem t ntable hm.slots; + match hashMap_move_elements t ntable hm.slots 0 with | Fail _ -> () | Return (ntable', _) -> - hash_map_is_assoc_list_lem hm; - assert(hash_map_is_assoc_list hm (hash_map_t_al_v hm)); + hashMap_is_assoc_list_lem hm; + assert(hashMap_is_assoc_list hm (hashMap_t_al_v hm)); let hm' = - { hm with hash_map_slots = ntable'.hash_map_slots; - hash_map_max_load = ntable'.hash_map_max_load } + { hm with slots = ntable'.slots; + max_load = ntable'.max_load } in - assert(hash_map_t_base_inv ntable'); - assert(hash_map_t_base_inv hm'); - assert(hash_map_t_len_s hm' = hash_map_t_len_s hm); - new_max_load_lem (hash_map_t_len_s hm') capacity divid divis; - assert(hash_map_t_len_s hm' <= hm'.hash_map_max_load); // Requires a lemma - assert(hash_map_t_inv hm') + assert(hashMap_t_base_inv ntable'); + assert(hashMap_t_base_inv hm'); + assert(hashMap_t_len_s hm' = hashMap_t_len_s hm); + new_max_load_lem (hashMap_t_len_s hm') capacity divid divis; + assert(hashMap_t_len_s hm' <= hm'.max_load); // Requires a lemma + assert(hashMap_t_inv hm') end else begin @@ -2422,203 +2422,203 @@ let hash_map_try_resize_s_simpl_lem #t hm = end #pop-options -let hash_map_t_same_bindings (#t : Type0) (hm hm' : hash_map_t_nes t) : Type0 = - forall (k:key). hash_map_t_find_s hm k == hash_map_t_find_s hm' k +let hashMap_t_same_bindings (#t : Type0) (hm hm' : hashMap_t_nes t) : Type0 = + forall (k:key). hashMap_t_find_s hm k == hashMap_t_find_s hm' k /// The final lemma about [try_resize] -val hash_map_try_resize_fwd_back_lem (#t : Type0) (hm : hash_map_t t) : +val hashMap_try_resize_lem (#t : Type0) (hm : hashMap_t t) : Lemma (requires ( - hash_map_t_base_inv hm /\ + hashMap_t_base_inv hm /\ // However, the "full" invariant is broken, as we call [try_resize] // only if the current number of entries is > the max load. // // There are two situations: // - either we just reached the max load // - or we were already saturated and can't resize - (let (dividend, divisor) = hm.hash_map_max_load_factor in - hm.hash_map_num_entries == hm.hash_map_max_load + 1 \/ - length hm.hash_map_slots * 2 * dividend > usize_max))) + (let (dividend, divisor) = hm.max_load_factor in + hm.num_entries == hm.max_load + 1 \/ + length hm.slots * 2 * dividend > usize_max))) (ensures ( - match hash_map_try_resize_fwd_back t hm with + match hashMap_try_resize t hm with | Fail _ -> False | Return hm' -> // The full invariant is now satisfied (the full invariant is "base // invariant" + the map is not overloaded (or can't be resized because // already too big) - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // The length is the same - hash_map_t_len_s hm' = hash_map_t_len_s hm /\ + hashMap_t_len_s hm' = hashMap_t_len_s hm /\ // It contains the same bindings as the initial map - hash_map_t_same_bindings hm' hm)) + hashMap_t_same_bindings hm' hm)) -let hash_map_try_resize_fwd_back_lem #t hm = - hash_map_try_resize_fwd_back_lem_refin t hm; - hash_map_try_resize_s_simpl_lem hm +let hashMap_try_resize_lem #t hm = + hashMap_try_resize_lem_refin t hm; + hashMap_try_resize_s_simpl_lem hm (*** insert *) /// The high-level model (very close to the original function: we don't need something /// very high level, just to clean it a bit) -let hash_map_insert_s - (#t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - result (hash_map_t t) = - match hash_map_insert_no_resize_fwd_back t self key value with +let hashMap_insert_s + (#t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + result (hashMap_t t) = + match hashMap_insert_no_resize t self key value with | Fail e -> Fail e | Return hm' -> - if hash_map_t_len_s hm' > hm'.hash_map_max_load then - hash_map_try_resize_fwd_back t hm' + if hashMap_t_len_s hm' > hm'.max_load then + hashMap_try_resize t hm' else Return hm' -val hash_map_insert_fwd_back_lem_refin - (t : Type0) (self : hash_map_t t) (key : usize) (value : t) : +val hashMap_insert_lem_refin + (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : Lemma (requires True) (ensures ( - match hash_map_insert_fwd_back t self key value, - hash_map_insert_s self key value + match hashMap_insert t self key value, + hashMap_insert_s self key value with | Fail _, Fail _ -> True | Return hm1, Return hm2 -> hm1 == hm2 | _ -> False)) -let hash_map_insert_fwd_back_lem_refin t self key value = () +let hashMap_insert_lem_refin t self key value = () /// Helper -let hash_map_insert_fwd_back_bindings_lem - (t : Type0) (self : hash_map_t_nes t) (key : usize) (value : t) - (hm' hm'' : hash_map_t_nes t) : +let hashMap_insert_bindings_lem + (t : Type0) (self : hashMap_t_nes t) (key : usize) (value : t) + (hm' hm'' : hashMap_t_nes t) : Lemma (requires ( - hash_map_s_updated_binding (hash_map_t_v self) key - (Some value) (hash_map_t_v hm') /\ - hash_map_t_same_bindings hm' hm'')) + hashMap_s_updated_binding (hashMap_t_v self) key + (Some value) (hashMap_t_v hm') /\ + hashMap_t_same_bindings hm' hm'')) (ensures ( - hash_map_s_updated_binding (hash_map_t_v self) key - (Some value) (hash_map_t_v hm''))) + hashMap_s_updated_binding (hashMap_t_v self) key + (Some value) (hashMap_t_v hm''))) = () -val hash_map_insert_fwd_back_lem_aux - (#t : Type0) (self : hash_map_t t) (key : usize) (value : t) : - Lemma (requires (hash_map_t_inv self)) +val hashMap_insert_lem_aux + (#t : Type0) (self : hashMap_t t) (key : usize) (value : t) : + Lemma (requires (hashMap_t_inv self)) (ensures ( - match hash_map_insert_fwd_back t self key value with + match hashMap_insert t self key value with | Fail _ -> // We can fail only if: // - the key is not in the map and we need to add it // - we are already saturated - hash_map_t_len_s self = usize_max /\ - None? (hash_map_t_find_s self key) + hashMap_t_len_s self = usize_max /\ + None? (hashMap_t_find_s self key) | Return hm' -> // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // [key] maps to [value] and the other bindings are preserved - hash_map_s_updated_binding (hash_map_t_v self) key (Some value) (hash_map_t_v hm') /\ + hashMap_s_updated_binding (hashMap_t_v self) key (Some value) (hashMap_t_v hm') /\ // The length is incremented, iff we inserted a new key - (match hash_map_t_find_s self key with - | None -> hash_map_t_len_s hm' = hash_map_t_len_s self + 1 - | Some _ -> hash_map_t_len_s hm' = hash_map_t_len_s self))) + (match hashMap_t_find_s self key with + | None -> hashMap_t_len_s hm' = hashMap_t_len_s self + 1 + | Some _ -> hashMap_t_len_s hm' = hashMap_t_len_s self))) #restart-solver #push-options "--z3rlimit 200" -let hash_map_insert_fwd_back_lem_aux #t self key value = - hash_map_insert_no_resize_fwd_back_lem_s t self key value; - hash_map_insert_no_resize_s_lem (hash_map_t_v self) key value; - match hash_map_insert_no_resize_fwd_back t self key value with +let hashMap_insert_lem_aux #t self key value = + hashMap_insert_no_resize_lem_s t self key value; + hashMap_insert_no_resize_s_lem (hashMap_t_v self) key value; + match hashMap_insert_no_resize t self key value with | Fail _ -> () | Return hm' -> - // Expanding the post of [hash_map_insert_no_resize_fwd_back_lem_s] - let self_v = hash_map_t_v self in - let hm'_v = Return?.v (hash_map_insert_no_resize_s self_v key value) in - assert(hash_map_t_base_inv hm'); - assert(hash_map_t_same_params hm' self); - assert(hash_map_t_v hm' == hm'_v); - assert(hash_map_s_len hm'_v == hash_map_t_len_s hm'); - // Expanding the post of [hash_map_insert_no_resize_s_lem] + // Expanding the post of [hashMap_insert_no_resize_lem_s] + let self_v = hashMap_t_v self in + let hm'_v = Return?.v (hashMap_insert_no_resize_s self_v key value) in + assert(hashMap_t_base_inv hm'); + assert(hashMap_t_same_params hm' self); + assert(hashMap_t_v hm' == hm'_v); + assert(hashMap_s_len hm'_v == hashMap_t_len_s hm'); + // Expanding the post of [hashMap_insert_no_resize_s_lem] assert(insert_post self_v key value hm'_v); // Expanding [insert_post] - assert(hash_map_s_inv hm'_v); + assert(hashMap_s_inv hm'_v); assert( - match hash_map_s_find self_v key with - | None -> hash_map_s_len hm'_v = hash_map_s_len self_v + 1 - | Some _ -> hash_map_s_len hm'_v = hash_map_s_len self_v); - if hash_map_t_len_s hm' > hm'.hash_map_max_load then + match hashMap_s_find self_v key with + | None -> hashMap_s_len hm'_v = hashMap_s_len self_v + 1 + | Some _ -> hashMap_s_len hm'_v = hashMap_s_len self_v); + if hashMap_t_len_s hm' > hm'.max_load then begin - hash_map_try_resize_fwd_back_lem hm'; - // Expanding the post of [hash_map_try_resize_fwd_back_lem] - let hm'' = Return?.v (hash_map_try_resize_fwd_back t hm') in - assert(hash_map_t_inv hm''); - let hm''_v = hash_map_t_v hm'' in - assert(forall k. hash_map_t_find_s hm'' k == hash_map_t_find_s hm' k); - assert(hash_map_t_len_s hm'' = hash_map_t_len_s hm'); // TODO + hashMap_try_resize_lem hm'; + // Expanding the post of [hashMap_try_resize_lem] + let hm'' = Return?.v (hashMap_try_resize t hm') in + assert(hashMap_t_inv hm''); + let hm''_v = hashMap_t_v hm'' in + assert(forall k. hashMap_t_find_s hm'' k == hashMap_t_find_s hm' k); + assert(hashMap_t_len_s hm'' = hashMap_t_len_s hm'); // TODO // Proving the post - assert(hash_map_t_inv hm''); - hash_map_insert_fwd_back_bindings_lem t self key value hm' hm''; + assert(hashMap_t_inv hm''); + hashMap_insert_bindings_lem t self key value hm' hm''; assert( - match hash_map_t_find_s self key with - | None -> hash_map_t_len_s hm'' = hash_map_t_len_s self + 1 - | Some _ -> hash_map_t_len_s hm'' = hash_map_t_len_s self) + match hashMap_t_find_s self key with + | None -> hashMap_t_len_s hm'' = hashMap_t_len_s self + 1 + | Some _ -> hashMap_t_len_s hm'' = hashMap_t_len_s self) end else () #pop-options -let hash_map_insert_fwd_back_lem #t self key value = - hash_map_insert_fwd_back_lem_aux #t self key value +let hashMap_insert_lem #t self key value = + hashMap_insert_lem_aux #t self key value (*** contains_key *) (**** contains_key_in_list *) -val hash_map_contains_key_in_list_fwd_lem +val hashMap_contains_key_in_list_lem (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_contains_key_in_list_fwd t key ls with + match hashMap_contains_key_in_list t key ls with | Fail _ -> False | Return b -> b = Some? (slot_t_find_s key ls))) #push-options "--fuel 1" -let rec hash_map_contains_key_in_list_fwd_lem #t key ls = +let rec hashMap_contains_key_in_list_lem #t key ls = match ls with - | ListCons ckey x ls0 -> + | List_Cons ckey x ls0 -> let b = ckey = key in if b then () else begin - hash_map_contains_key_in_list_fwd_lem key ls0; - match hash_map_contains_key_in_list_fwd t key ls0 with + hashMap_contains_key_in_list_lem key ls0; + match hashMap_contains_key_in_list t key ls0 with | Fail _ -> () | Return b0 -> () end - | ListNil -> () + | List_Nil -> () #pop-options (**** contains_key *) -val hash_map_contains_key_fwd_lem_aux - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_contains_key_lem_aux + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (ensures ( - match hash_map_contains_key_fwd t self key with + match hashMap_contains_key t self key with | Fail _ -> False - | Return b -> b = Some? (hash_map_t_find_s self key))) + | Return b -> b = Some? (hashMap_t_find_s self key))) -let hash_map_contains_key_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_contains_key_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let v = self.hash_map_slots in - let i0 = vec_len (list_t t) v in + let v = self.slots in + let i0 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i0 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> - hash_map_contains_key_in_list_fwd_lem key l; - begin match hash_map_contains_key_in_list_fwd t key l with + hashMap_contains_key_in_list_lem key l; + begin match hashMap_contains_key_in_list t key l with | Fail _ -> () | Return b -> () end @@ -2627,66 +2627,66 @@ let hash_map_contains_key_fwd_lem_aux #t self key = end /// The lemma in the .fsti -let hash_map_contains_key_fwd_lem #t self key = - hash_map_contains_key_fwd_lem_aux #t self key +let hashMap_contains_key_lem #t self key = + hashMap_contains_key_lem_aux #t self key (*** get *) (**** get_in_list *) -val hash_map_get_in_list_fwd_lem +val hashMap_get_in_list_lem (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_get_in_list_fwd t key ls, slot_t_find_s key ls with + match hashMap_get_in_list t key ls, slot_t_find_s key ls with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) #push-options "--fuel 1" -let rec hash_map_get_in_list_fwd_lem #t key ls = +let rec hashMap_get_in_list_lem #t key ls = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_get_in_list_fwd_lem key ls0; - match hash_map_get_in_list_fwd t key ls0 with + hashMap_get_in_list_lem key ls0; + match hashMap_get_in_list t key ls0 with | Fail _ -> () | Return x -> () end - | ListNil -> () + | List_Nil -> () end #pop-options (**** get *) -val hash_map_get_fwd_lem_aux - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_get_lem_aux + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (ensures ( - match hash_map_get_fwd t self key, hash_map_t_find_s self key with + match hashMap_get t self key, hashMap_t_find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) -let hash_map_get_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_get_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let v = self.hash_map_slots in - let i0 = vec_len (list_t t) v in + let v = self.slots in + let i0 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i0 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_get_in_list_fwd_lem key l; - match hash_map_get_in_list_fwd t key l with + hashMap_get_in_list_lem key l; + match hashMap_get_in_list t key l with | Fail _ -> () | Return x -> () end @@ -2695,66 +2695,66 @@ let hash_map_get_fwd_lem_aux #t self key = end /// .fsti -let hash_map_get_fwd_lem #t self key = hash_map_get_fwd_lem_aux #t self key +let hashMap_get_lem #t self key = hashMap_get_lem_aux #t self key (*** get_mut'fwd *) (**** get_mut_in_list'fwd *) -val hash_map_get_mut_in_list_loop_fwd_lem +val hashMap_get_mut_in_list_loop_lem (#t : Type0) (ls : list_t t) (key : usize) : Lemma (ensures ( - match hash_map_get_mut_in_list_loop_fwd t ls key, slot_t_find_s key ls with + match hashMap_get_mut_in_list_loop t ls key, slot_t_find_s key ls with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) #push-options "--fuel 1" -let rec hash_map_get_mut_in_list_loop_fwd_lem #t ls key = +let rec hashMap_get_mut_in_list_loop_lem #t ls key = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b then () else begin - hash_map_get_mut_in_list_loop_fwd_lem ls0 key; - match hash_map_get_mut_in_list_loop_fwd t ls0 key with + hashMap_get_mut_in_list_loop_lem ls0 key; + match hashMap_get_mut_in_list_loop t ls0 key with | Fail _ -> () | Return x -> () end - | ListNil -> () + | List_Nil -> () end #pop-options (**** get_mut'fwd *) -val hash_map_get_mut_fwd_lem_aux - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_get_mut_lem_aux + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (ensures ( - match hash_map_get_mut_fwd t self key, hash_map_t_find_s self key with + match hashMap_get_mut t self key, hashMap_t_find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) -let hash_map_get_mut_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_get_mut_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let v = self.hash_map_slots in - let i0 = vec_len (list_t t) v in + let v = self.slots in + let i0 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i0 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_get_mut_in_list_loop_fwd_lem l key; - match hash_map_get_mut_in_list_loop_fwd t l key with + hashMap_get_mut_in_list_loop_lem l key; + match hashMap_get_mut_in_list_loop t l key with | Fail _ -> () | Return x -> () end @@ -2762,78 +2762,78 @@ let hash_map_get_mut_fwd_lem_aux #t self key = end end -let hash_map_get_mut_fwd_lem #t self key = - hash_map_get_mut_fwd_lem_aux #t self key +let hashMap_get_mut_lem #t self key = + hashMap_get_mut_lem_aux #t self key (*** get_mut'back *) (**** get_mut_in_list'back *) -val hash_map_get_mut_in_list_loop_back_lem +val hashMap_get_mut_in_list_loop_back_lem (#t : Type0) (ls : list_t t) (key : usize) (ret : t) : Lemma (requires (Some? (slot_t_find_s key ls))) (ensures ( - match hash_map_get_mut_in_list_loop_back t ls key ret with + match hashMap_get_mut_in_list_loop_back t ls key ret with | Fail _ -> False | Return ls' -> list_t_v ls' == find_update (same_key key) (list_t_v ls) (key,ret) | _ -> False)) #push-options "--fuel 1" -let rec hash_map_get_mut_in_list_loop_back_lem #t ls key ret = +let rec hashMap_get_mut_in_list_loop_back_lem #t ls key ret = begin match ls with - | ListCons ckey cvalue ls0 -> + | List_Cons ckey cvalue ls0 -> let b = ckey = key in if b - then let ls1 = ListCons ckey ret ls0 in () + then let ls1 = List_Cons ckey ret ls0 in () else begin - hash_map_get_mut_in_list_loop_back_lem ls0 key ret; - match hash_map_get_mut_in_list_loop_back t ls0 key ret with + hashMap_get_mut_in_list_loop_back_lem ls0 key ret; + match hashMap_get_mut_in_list_loop_back t ls0 key ret with | Fail _ -> () - | Return l -> let ls1 = ListCons ckey cvalue l in () + | Return l -> let ls1 = List_Cons ckey cvalue l in () end - | ListNil -> () + | List_Nil -> () end #pop-options (**** get_mut'back *) /// Refinement lemma -val hash_map_get_mut_back_lem_refin - (#t : Type0) (self : hash_map_t t{length self.hash_map_slots > 0}) +val hashMap_get_mut_back_lem_refin + (#t : Type0) (self : hashMap_t t{length self.slots > 0}) (key : usize) (ret : t) : Lemma - (requires (Some? (hash_map_t_find_s self key))) + (requires (Some? (hashMap_t_find_s self key))) (ensures ( - match hash_map_get_mut_back t self key ret with + match hashMap_get_mut_back t self key ret with | Fail _ -> False | Return hm' -> - hash_map_t_v hm' == hash_map_insert_no_fail_s (hash_map_t_v self) key ret)) + hashMap_t_v hm' == hashMap_insert_no_fail_s (hashMap_t_v self) key ret)) -let hash_map_get_mut_back_lem_refin #t self key ret = - begin match hash_key_fwd key with +let hashMap_get_mut_back_lem_refin #t self key ret = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let p = self.hash_map_max_load_factor in - let i1 = self.hash_map_max_load in - let v = self.hash_map_slots in - let i2 = vec_len (list_t t) v in + let i0 = self.num_entries in + let p = self.max_load_factor in + let i1 = self.max_load in + let v = self.slots in + let i2 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i2 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_get_mut_in_list_loop_back_lem l key ret; - match hash_map_get_mut_in_list_loop_back t l key ret with + hashMap_get_mut_in_list_loop_back_lem l key ret; + match hashMap_get_mut_in_list_loop_back t l key ret with | Fail _ -> () | Return l0 -> - begin match vec_index_mut_back (list_t t) v hash_mod l0 with + begin match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () - | Return v0 -> let self0 = Mkhash_map_t i0 p i1 v0 in () + | Return v0 -> let self0 = MkhashMap_t i0 p i1 v0 in () end end end @@ -2841,102 +2841,102 @@ let hash_map_get_mut_back_lem_refin #t self key ret = end /// Final lemma -val hash_map_get_mut_back_lem_aux - (#t : Type0) (hm : hash_map_t t) +val hashMap_get_mut_back_lem_aux + (#t : Type0) (hm : hashMap_t t) (key : usize) (ret : t) : Lemma (requires ( - hash_map_t_inv hm /\ - Some? (hash_map_t_find_s hm key))) + hashMap_t_inv hm /\ + Some? (hashMap_t_find_s hm key))) (ensures ( - match hash_map_get_mut_back t hm key ret with + match hashMap_get_mut_back t hm key ret with | Fail _ -> False | Return hm' -> // Functional spec - hash_map_t_v hm' == hash_map_insert_no_fail_s (hash_map_t_v hm) key ret /\ + hashMap_t_v hm' == hashMap_insert_no_fail_s (hashMap_t_v hm) key ret /\ // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // The length is preserved - hash_map_t_len_s hm' = hash_map_t_len_s hm /\ + hashMap_t_len_s hm' = hashMap_t_len_s hm /\ // [key] maps to [value] - hash_map_t_find_s hm' key == Some ret /\ + hashMap_t_find_s hm' key == Some ret /\ // The other bindings are preserved - (forall k'. k' <> key ==> hash_map_t_find_s hm' k' == hash_map_t_find_s hm k'))) + (forall k'. k' <> key ==> hashMap_t_find_s hm' k' == hashMap_t_find_s hm k'))) -let hash_map_get_mut_back_lem_aux #t hm key ret = - let hm_v = hash_map_t_v hm in - hash_map_get_mut_back_lem_refin hm key ret; - match hash_map_get_mut_back t hm key ret with +let hashMap_get_mut_back_lem_aux #t hm key ret = + let hm_v = hashMap_t_v hm in + hashMap_get_mut_back_lem_refin hm key ret; + match hashMap_get_mut_back t hm key ret with | Fail _ -> assert(False) | Return hm' -> - hash_map_insert_no_fail_s_lem hm_v key ret + hashMap_insert_no_fail_s_lem hm_v key ret /// .fsti -let hash_map_get_mut_back_lem #t hm key ret = hash_map_get_mut_back_lem_aux hm key ret +let hashMap_get_mut_back_lem #t hm key ret = hashMap_get_mut_back_lem_aux hm key ret (*** remove'fwd *) -val hash_map_remove_from_list_fwd_lem +val hashMap_remove_from_list_lem (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_remove_from_list_fwd t key ls with + match hashMap_remove_from_list t key ls with | Fail _ -> False | Return opt_x -> opt_x == slot_t_find_s key ls /\ (Some? opt_x ==> length (slot_t_v ls) > 0))) #push-options "--fuel 1" -let rec hash_map_remove_from_list_fwd_lem #t key ls = +let rec hashMap_remove_from_list_lem #t key ls = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> let b = ckey = key in if b then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> () - | ListNil -> () + | List_Cons i cvalue tl0 -> () + | List_Nil -> () end else begin - hash_map_remove_from_list_fwd_lem key tl; - match hash_map_remove_from_list_fwd t key tl with + hashMap_remove_from_list_lem key tl; + match hashMap_remove_from_list t key tl with | Fail _ -> () | Return opt -> () end - | ListNil -> () + | List_Nil -> () end #pop-options -val hash_map_remove_fwd_lem_aux - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_lem_aux + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma (requires ( // We need the invariant to prove that upon decrementing the entries counter, // the counter doesn't become negative - hash_map_t_inv self)) + hashMap_t_inv self)) (ensures ( - match hash_map_remove_fwd t self key with + match hashMap_remove t self key with | Fail _ -> False - | Return opt_x -> opt_x == hash_map_t_find_s self key)) + | Return opt_x -> opt_x == hashMap_t_find_s self key)) -let hash_map_remove_fwd_lem_aux #t self key = - begin match hash_key_fwd key with +let hashMap_remove_lem_aux #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let v = self.hash_map_slots in - let i1 = vec_len (list_t t) v in + let i0 = self.num_entries in + let v = self.slots in + let i1 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i1 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_remove_from_list_fwd_lem key l; - match hash_map_remove_from_list_fwd t key l with + hashMap_remove_from_list_lem key l; + match hashMap_remove_from_list t key l with | Fail _ -> () | Return x -> begin match x with @@ -2945,7 +2945,7 @@ let hash_map_remove_fwd_lem_aux #t self key = begin assert(l == index v hash_mod); assert(length (list_t_v #t l) > 0); - length_flatten_index (hash_map_t_v self) hash_mod; + length_flatten_index (hashMap_t_v self) hash_mod; match usize_sub i0 1 with | Fail _ -> () | Return _ -> () @@ -2957,27 +2957,27 @@ let hash_map_remove_fwd_lem_aux #t self key = end /// .fsti -let hash_map_remove_fwd_lem #t self key = hash_map_remove_fwd_lem_aux #t self key +let hashMap_remove_lem #t self key = hashMap_remove_lem_aux #t self key (*** remove'back *) (**** Refinement proofs *) /// High-level model for [remove_from_list'back] -let hash_map_remove_from_list_s +let hashMap_remove_from_list_s (#t : Type0) (key : usize) (ls : slot_s t) : slot_s t = filter_one (not_same_key key) ls /// Refinement lemma -val hash_map_remove_from_list_back_lem_refin +val hashMap_remove_from_list_back_lem_refin (#t : Type0) (key : usize) (ls : list_t t) : Lemma (ensures ( - match hash_map_remove_from_list_back t key ls with + match hashMap_remove_from_list_back t key ls with | Fail _ -> False | Return ls' -> - list_t_v ls' == hash_map_remove_from_list_s key (list_t_v ls) /\ + list_t_v ls' == hashMap_remove_from_list_s key (list_t_v ls) /\ // The length is decremented, iff the key was in the slot (let len = length (list_t_v ls) in let len' = length (list_t_v ls') in @@ -2986,89 +2986,89 @@ val hash_map_remove_from_list_back_lem_refin | Some _ -> len = len' + 1))) #push-options "--fuel 1" -let rec hash_map_remove_from_list_back_lem_refin #t key ls = +let rec hashMap_remove_from_list_back_lem_refin #t key ls = begin match ls with - | ListCons ckey x tl -> + | List_Cons ckey x tl -> let b = ckey = key in if b then - let mv_ls = mem_replace_fwd (list_t t) (ListCons ckey x tl) ListNil in + let mv_ls = core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in begin match mv_ls with - | ListCons i cvalue tl0 -> () - | ListNil -> () + | List_Cons i cvalue tl0 -> () + | List_Nil -> () end else begin - hash_map_remove_from_list_back_lem_refin key tl; - match hash_map_remove_from_list_back t key tl with + hashMap_remove_from_list_back_lem_refin key tl; + match hashMap_remove_from_list_back t key tl with | Fail _ -> () - | Return l -> let ls0 = ListCons ckey x l in () + | Return l -> let ls0 = List_Cons ckey x l in () end - | ListNil -> () + | List_Nil -> () end #pop-options /// High-level model for [remove_from_list'back] -let hash_map_remove_s - (#t : Type0) (self : hash_map_s_nes t) (key : usize) : - hash_map_s t = +let hashMap_remove_s + (#t : Type0) (self : hashMap_s_nes t) (key : usize) : + hashMap_s t = let len = length self in let hash = hash_mod_key key len in let slot = index self hash in - let slot' = hash_map_remove_from_list_s key slot in + let slot' = hashMap_remove_from_list_s key slot in list_update self hash slot' /// Refinement lemma -val hash_map_remove_back_lem_refin - (#t : Type0) (self : hash_map_t_nes t) (key : usize) : +val hashMap_remove_back_lem_refin + (#t : Type0) (self : hashMap_t_nes t) (key : usize) : Lemma (requires ( // We need the invariant to prove that upon decrementing the entries counter, // the counter doesn't become negative - hash_map_t_inv self)) + hashMap_t_inv self)) (ensures ( - match hash_map_remove_back t self key with + match hashMap_remove_back t self key with | Fail _ -> False | Return hm' -> - hash_map_t_same_params hm' self /\ - hash_map_t_v hm' == hash_map_remove_s (hash_map_t_v self) key /\ + hashMap_t_same_params hm' self /\ + hashMap_t_v hm' == hashMap_remove_s (hashMap_t_v self) key /\ // The length is decremented iff the key was in the map - (let len = hash_map_t_len_s self in - let len' = hash_map_t_len_s hm' in - match hash_map_t_find_s self key with + (let len = hashMap_t_len_s self in + let len' = hashMap_t_len_s hm' in + match hashMap_t_find_s self key with | None -> len = len' | Some _ -> len = len' + 1))) -let hash_map_remove_back_lem_refin #t self key = - begin match hash_key_fwd key with +let hashMap_remove_back_lem_refin #t self key = + begin match hash_key key with | Fail _ -> () | Return i -> - let i0 = self.hash_map_num_entries in - let p = self.hash_map_max_load_factor in - let i1 = self.hash_map_max_load in - let v = self.hash_map_slots in - let i2 = vec_len (list_t t) v in + let i0 = self.num_entries in + let p = self.max_load_factor in + let i1 = self.max_load in + let v = self.slots in + let i2 = alloc_vec_Vec_len (list_t t) v in begin match usize_rem i i2 with | Fail _ -> () | Return hash_mod -> - begin match vec_index_mut_fwd (list_t t) v hash_mod with + begin match alloc_vec_Vec_index_usize v hash_mod with | Fail _ -> () | Return l -> begin - hash_map_remove_from_list_fwd_lem key l; - match hash_map_remove_from_list_fwd t key l with + hashMap_remove_from_list_lem key l; + match hashMap_remove_from_list t key l with | Fail _ -> () | Return x -> begin match x with | None -> begin - hash_map_remove_from_list_back_lem_refin key l; - match hash_map_remove_from_list_back t key l with + hashMap_remove_from_list_back_lem_refin key l; + match hashMap_remove_from_list_back t key l with | Fail _ -> () | Return l0 -> begin length_flatten_update (slots_t_v v) hash_mod (list_t_v l0); - match vec_index_mut_back (list_t t) v hash_mod l0 with + match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> () end @@ -3077,18 +3077,18 @@ let hash_map_remove_back_lem_refin #t self key = begin assert(l == index v hash_mod); assert(length (list_t_v #t l) > 0); - length_flatten_index (hash_map_t_v self) hash_mod; + length_flatten_index (hashMap_t_v self) hash_mod; match usize_sub i0 1 with | Fail _ -> () | Return i3 -> begin - hash_map_remove_from_list_back_lem_refin key l; - match hash_map_remove_from_list_back t key l with + hashMap_remove_from_list_back_lem_refin key l; + match hashMap_remove_from_list_back t key l with | Fail _ -> () | Return l0 -> begin length_flatten_update (slots_t_v v) hash_mod (list_t_v l0); - match vec_index_mut_back (list_t t) v hash_mod l0 with + match alloc_vec_Vec_update_usize v hash_mod l0 with | Fail _ -> () | Return v0 -> () end @@ -3102,12 +3102,12 @@ let hash_map_remove_back_lem_refin #t self key = (**** Invariants, high-level properties *) -val hash_map_remove_from_list_s_lem +val hashMap_remove_from_list_s_lem (#t : Type0) (k : usize) (slot : slot_s t) (len : usize{len > 0}) (i : usize) : Lemma (requires (slot_s_inv len i slot)) (ensures ( - let slot' = hash_map_remove_from_list_s k slot in + let slot' = hashMap_remove_from_list_s k slot in slot_s_inv len i slot' /\ slot_s_find k slot' == None /\ (forall (k':key{k' <> k}). slot_s_find k' slot' == slot_s_find k' slot) /\ @@ -3117,14 +3117,14 @@ val hash_map_remove_from_list_s_lem )) #push-options "--fuel 1" -let rec hash_map_remove_from_list_s_lem #t key slot len i = +let rec hashMap_remove_from_list_s_lem #t key slot len i = match slot with | [] -> () | (k',v) :: slot' -> if k' <> key then begin - hash_map_remove_from_list_s_lem key slot' len i; - let slot'' = hash_map_remove_from_list_s key slot' in + hashMap_remove_from_list_s_lem key slot' len i; + let slot'' = hashMap_remove_from_list_s key slot' in assert(for_all (same_hash_mod_key len i) ((k',v)::slot'')); assert(for_all (binding_neq (k',v)) slot'); // Triggers instanciation assert(for_all (binding_neq (k',v)) slot'') @@ -3136,51 +3136,51 @@ let rec hash_map_remove_from_list_s_lem #t key slot len i = end #pop-options -val hash_map_remove_s_lem - (#t : Type0) (self : hash_map_s_nes t) (key : usize) : +val hashMap_remove_s_lem + (#t : Type0) (self : hashMap_s_nes t) (key : usize) : Lemma - (requires (hash_map_s_inv self)) + (requires (hashMap_s_inv self)) (ensures ( - let hm' = hash_map_remove_s self key in + let hm' = hashMap_remove_s self key in // The invariant is preserved - hash_map_s_inv hm' /\ + hashMap_s_inv hm' /\ // We updated the binding - hash_map_s_updated_binding self key None hm')) + hashMap_s_updated_binding self key None hm')) -let hash_map_remove_s_lem #t self key = +let hashMap_remove_s_lem #t self key = let len = length self in let hash = hash_mod_key key len in let slot = index self hash in - hash_map_remove_from_list_s_lem key slot len hash; - let slot' = hash_map_remove_from_list_s key slot in + hashMap_remove_from_list_s_lem key slot len hash; + let slot' = hashMap_remove_from_list_s key slot in let hm' = list_update self hash slot' in - assert(hash_map_s_inv self) + assert(hashMap_s_inv self) /// Final lemma about [remove'back] -val hash_map_remove_back_lem_aux - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_back_lem_aux + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_remove_back t self key with + match hashMap_remove_back t self key with | Fail _ -> False | Return hm' -> - hash_map_t_inv self /\ - hash_map_t_same_params hm' self /\ + hashMap_t_inv self /\ + hashMap_t_same_params hm' self /\ // We updated the binding - hash_map_s_updated_binding (hash_map_t_v self) key None (hash_map_t_v hm') /\ - hash_map_t_v hm' == hash_map_remove_s (hash_map_t_v self) key /\ + hashMap_s_updated_binding (hashMap_t_v self) key None (hashMap_t_v hm') /\ + hashMap_t_v hm' == hashMap_remove_s (hashMap_t_v self) key /\ // The length is decremented iff the key was in the map - (let len = hash_map_t_len_s self in - let len' = hash_map_t_len_s hm' in - match hash_map_t_find_s self key with + (let len = hashMap_t_len_s self in + let len' = hashMap_t_len_s hm' in + match hashMap_t_find_s self key with | None -> len = len' | Some _ -> len = len' + 1))) -let hash_map_remove_back_lem_aux #t self key = - hash_map_remove_back_lem_refin self key; - hash_map_remove_s_lem (hash_map_t_v self) key +let hashMap_remove_back_lem_aux #t self key = + hashMap_remove_back_lem_refin self key; + hashMap_remove_s_lem (hashMap_t_v self) key /// .fsti -let hash_map_remove_back_lem #t self key = - hash_map_remove_back_lem_aux #t self key +let hashMap_remove_back_lem #t self key = + hashMap_remove_back_lem_aux #t self key diff --git a/tests/fstar/hashmap/Hashmap.Properties.fsti b/tests/fstar/hashmap/Hashmap.Properties.fsti index 0a4f0134..26c0ec06 100644 --- a/tests/fstar/hashmap/Hashmap.Properties.fsti +++ b/tests/fstar/hashmap/Hashmap.Properties.fsti @@ -18,11 +18,11 @@ type key : eqtype = usize type hash : eqtype = usize -val hash_map_t_inv (#t : Type0) (hm : hash_map_t t) : Type0 +val hashMap_t_inv (#t : Type0) (hm : hashMap_t t) : Type0 -val len_s (#t : Type0) (hm : hash_map_t t) : nat +val len_s (#t : Type0) (hm : hashMap_t t) : nat -val find_s (#t : Type0) (hm : hash_map_t t) (k : key) : option t +val find_s (#t : Type0) (hm : hashMap_t t) (k : key) : option t (*** Overloading *) @@ -32,16 +32,16 @@ val find_s (#t : Type0) (hm : hash_map_t t) (k : key) : option t /// limiting the hash collisions. /// This is expressed by the following property, which is maintained in the hash /// map invariant. -val hash_map_not_overloaded_lem (#t : Type0) (hm : hash_map_t t) : +val hashMap_not_overloaded_lem (#t : Type0) (hm : hashMap_t t) : Lemma - (requires (hash_map_t_inv hm)) + (requires (hashMap_t_inv hm)) (ensures ( // The capacity is the number of slots - let capacity = length hm.hash_map_slots in + let capacity = length hm.slots in // The max load factor defines a threshold on the number of entries: // if there are more entries than a given fraction of the number of slots, // we resize the slots vector to limit the hash collisions - let (dividend, divisor) = hm.hash_map_max_load_factor in + let (dividend, divisor) = hm.max_load_factor in // technicality: this postcondition won't typecheck if we don't reveal // that divisor > 0 (because of the division) divisor > 0 /\ @@ -63,14 +63,14 @@ val hash_map_not_overloaded_lem (#t : Type0) (hm : hash_map_t t) : (**** [new'fwd] *) /// [new] doesn't fail and returns an empty hash map -val hash_map_new_fwd_lem (t : Type0) : +val hashMap_new_lem (t : Type0) : Lemma (ensures ( - match hash_map_new_fwd t with + match hashMap_new t with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The hash map has a length of 0 len_s hm = 0 /\ // It contains no bindings @@ -79,16 +79,16 @@ val hash_map_new_fwd_lem (t : Type0) : (**** [clear] *) /// [clear] doesn't fail and turns the hash map into an empty map -val hash_map_clear_fwd_back_lem - (#t : Type0) (self : hash_map_t t) : +val hashMap_clear_lem + (#t : Type0) (self : hashMap_t t) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_clear_fwd_back t self with + match hashMap_clear t self with | Fail _ -> False | Return hm -> // The hash map invariant is satisfied - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // The hash map has a length of 0 len_s hm = 0 /\ // It contains no bindings @@ -97,11 +97,11 @@ val hash_map_clear_fwd_back_lem (**** [len] *) /// [len] can't fail and returns the length (the number of elements) of the hash map -val hash_map_len_fwd_lem (#t : Type0) (self : hash_map_t t) : +val hashMap_len_lem (#t : Type0) (self : hashMap_t t) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_len_fwd t self with + match hashMap_len t self with | Fail _ -> False | Return l -> l = len_s self)) @@ -114,12 +114,12 @@ val hash_map_len_fwd_lem (#t : Type0) (self : hash_map_t t) : /// entirely encompassed by the effect of the backward function alone). /// /// [insert'fwd_back] simply inserts a binding. -val hash_map_insert_fwd_back_lem - (#t : Type0) (self : hash_map_t t) (key : usize) (value : t) : +val hashMap_insert_lem + (#t : Type0) (self : hashMap_t t) (key : usize) (value : t) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_insert_fwd_back t self key value with + match hashMap_insert t self key value with | Fail _ -> // We can fail only if: // - the key is not in the map and we thus need to add it @@ -128,7 +128,7 @@ val hash_map_insert_fwd_back_lem len_s self = usize_max | Return hm' -> // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // [key] maps to [value] find_s hm' key == Some value /\ // The other bindings are preserved @@ -145,24 +145,24 @@ val hash_map_insert_fwd_back_lem /// [contains_key'fwd] can't fail and returns `true` if and only if there is /// a binding for key [key] -val hash_map_contains_key_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_contains_key_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_contains_key_fwd t self key with + match hashMap_contains_key t self key with | Fail _ -> False | Return b -> b = Some? (find_s self key))) (**** [get'fwd] *) /// [get] returns (a shared borrow to) the binding for key [key] -val hash_map_get_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_get_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_get_fwd t self key, find_s self key with + match hashMap_get t self key, find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) @@ -175,12 +175,12 @@ val hash_map_get_fwd_lem /// in Rust, which gives the possibility of modifying this element in place. Then, /// upon ending the borrow, the effect of the modification is modelled in the /// translation through a call to the backward function. -val hash_map_get_mut_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_get_mut_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_get_mut_fwd t self key, find_s self key with + match hashMap_get_mut t self key, find_s self key with | Fail _, None -> True | Return x, Some x' -> x == x' | _ -> False)) @@ -192,11 +192,11 @@ val hash_map_get_mut_fwd_lem /// A call to [get_mut'back] must follow a call to [get_mut'fwd], which gives /// us that there must be a binding for key [key] in the map (otherwise we /// can't prove the absence of failure). -val hash_map_get_mut_back_lem - (#t : Type0) (hm : hash_map_t t) (key : usize) (ret : t) : +val hashMap_get_mut_back_lem + (#t : Type0) (hm : hashMap_t t) (key : usize) (ret : t) : Lemma (requires ( - hash_map_t_inv hm /\ + hashMap_t_inv hm /\ // A call to the backward function must follow a call to the forward // function, whose success gives us that there is a binding for the key. // In the case of *forward* functions, "success" has to be understood as @@ -207,14 +207,14 @@ val hash_map_get_mut_back_lem // "failure" is to be understood as the semantics getting stuck. // This is of course true unless we filtered the call to the forward function // because its effect is encompassed by the backward function, as with - // [hash_map_clear_fwd_back]). + // [hashMap_clear]). Some? (find_s hm key))) (ensures ( - match hash_map_get_mut_back t hm key ret with + match hashMap_get_mut_back t hm key ret with | Fail _ -> False // Can't fail | Return hm' -> // The invariant is preserved - hash_map_t_inv hm' /\ + hashMap_t_inv hm' /\ // The length is preserved len_s hm' = len_s hm /\ // [key] maps to the update value, [ret] @@ -228,12 +228,12 @@ val hash_map_get_mut_back_lem /// (the rust function *moves* it out of the map). Note that the effect of the update /// on the map is modelles through the call to [remove'back] ([remove] takes a /// mutable borrow to the hash map as parameter). -val hash_map_remove_fwd_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_remove_fwd t self key with + match hashMap_remove t self key with | Fail _ -> False | Return opt_x -> opt_x == find_s self key)) @@ -243,16 +243,16 @@ val hash_map_remove_fwd_lem /// The hash map given as parameter to [remove] is given through a mutable borrow: /// hence the backward function which gives back the updated map, without the /// binding. -val hash_map_remove_back_lem - (#t : Type0) (self : hash_map_t t) (key : usize) : +val hashMap_remove_back_lem + (#t : Type0) (self : hashMap_t t) (key : usize) : Lemma - (requires (hash_map_t_inv self)) + (requires (hashMap_t_inv self)) (ensures ( - match hash_map_remove_back t self key with + match hashMap_remove_back t self key with | Fail _ -> False | Return hm' -> // The invariant is preserved - hash_map_t_inv self /\ + hashMap_t_inv self /\ // The binding for [key] is not there anymore find_s hm' key == None /\ // The other bindings are preserved diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst index 106fe05a..358df29e 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Properties.fst @@ -13,36 +13,36 @@ open HashmapMain.Funs /// [state_v] gives us the hash map currently stored on disk assume -val state_v : state -> hashmap_hash_map_t u64 +val state_v : state -> hashmap_HashMap_t u64 /// [serialize] updates the hash map stored on disk assume -val serialize_lem (hm : hashmap_hash_map_t u64) (st : state) : Lemma ( - match hashmap_utils_serialize_fwd hm st with +val serialize_lem (hm : hashmap_HashMap_t u64) (st : state) : Lemma ( + match hashmap_utils_serialize hm st with | Fail _ -> True | Return (st', ()) -> state_v st' == hm) - [SMTPat (hashmap_utils_serialize_fwd hm st)] + [SMTPat (hashmap_utils_serialize hm st)] /// [deserialize] gives us the hash map stored on disk, without updating it assume val deserialize_lem (st : state) : Lemma ( - match hashmap_utils_deserialize_fwd st with + match hashmap_utils_deserialize st with | Fail _ -> True | Return (st', hm) -> hm == state_v st /\ st' == st) - [SMTPat (hashmap_utils_deserialize_fwd st)] + [SMTPat (hashmap_utils_deserialize st)] (*** Lemmas *) /// The obvious lemma about [insert_on_disk]: the updated hash map stored on disk /// is exactly the hash map produced from inserting the binding ([key], [value]) /// in the hash map previously stored on disk. -val insert_on_disk_fwd_lem (key : usize) (value : u64) (st : state) : Lemma ( - match insert_on_disk_fwd key value st with +val insert_on_disk_lem (key : usize) (value : u64) (st : state) : Lemma ( + match insert_on_disk key value st with | Fail _ -> True | Return (st', ()) -> let hm = state_v st in - match hashmap_hash_map_insert_fwd_back u64 hm key value with + match hashmap_HashMap_insert u64 hm key value with | Fail _ -> False | Return hm' -> hm' == state_v st') -let insert_on_disk_fwd_lem key value st = () +let insert_on_disk_lem key value st = () diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/fstar/misc/Loops.fst b/tests/fstar/misc/Loops.fst deleted file mode 100644 index 823acdd4..00000000 --- a/tests/fstar/misc/Loops.fst +++ /dev/null @@ -1,784 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [loops] *) -module Loops -open Primitives - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [loops::sum]: decreases clause *) -unfold let sum_loop_decreases (max : u32) (i : u32) (s : u32) : nat = admit () - -(** [loops::sum]: loop 0: forward function *) -let rec sum_loop - (max : u32) (i : u32) (s : u32) : - Tot (result u32) (decreases (sum_loop_decreases max i s)) - = - if i < max - then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop max i0 s0 - else u32_mul s 2 - -(** [loops::sum]: forward function *) -let sum (max : u32) : result u32 = - sum_loop max 0 0 - -(** [loops::sum_with_mut_borrows]: decreases clause *) -unfold -let sum_with_mut_borrows_loop_decreases (max : u32) (mi : u32) (ms : u32) : nat - = - admit () - -(** [loops::sum_with_mut_borrows]: loop 0: forward function *) -let rec sum_with_mut_borrows_loop - (max : u32) (mi : u32) (ms : u32) : - Tot (result u32) (decreases (sum_with_mut_borrows_loop_decreases max mi ms)) - = - if mi < max - then - let* ms0 = u32_add ms mi in - let* mi0 = u32_add mi 1 in - sum_with_mut_borrows_loop max mi0 ms0 - else u32_mul ms 2 - -(** [loops::sum_with_mut_borrows]: forward function *) -let sum_with_mut_borrows (max : u32) : result u32 = - sum_with_mut_borrows_loop max 0 0 - -(** [loops::sum_with_shared_borrows]: decreases clause *) -unfold -let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : - nat = - admit () - -(** [loops::sum_with_shared_borrows]: loop 0: forward function *) -let rec sum_with_shared_borrows_loop - (max : u32) (i : u32) (s : u32) : - Tot (result u32) (decreases (sum_with_shared_borrows_loop_decreases max i s)) - = - if i < max - then - let* i0 = u32_add i 1 in - let* s0 = u32_add s i0 in - sum_with_shared_borrows_loop max i0 s0 - else u32_mul s 2 - -(** [loops::sum_with_shared_borrows]: forward function *) -let sum_with_shared_borrows (max : u32) : result u32 = - sum_with_shared_borrows_loop max 0 0 - -(** [loops::clear]: decreases clause *) -unfold -let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () - -(** [loops::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -let rec clear_loop - (v : alloc_vec_Vec u32) (i : usize) : - Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) - = - let i0 = alloc_vec_Vec_len u32 v in - if i < i0 - then - let* i1 = usize_add i 1 in - let* v0 = - alloc_vec_Vec_index_mut_back u32 usize - (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0 in - clear_loop v0 i1 - else Return v - -(** [loops::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) -let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = - clear_loop v 0 - -(** [loops::List] *) -type list_t (t : Type0) = -| List_Cons : t -> list_t t -> list_t t -| List_Nil : list_t t - -(** [loops::list_mem]: decreases clause *) -unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () - -(** [loops::list_mem]: loop 0: forward function *) -let rec list_mem_loop - (x : u32) (ls : list_t u32) : - Tot (result bool) (decreases (list_mem_loop_decreases x ls)) - = - begin match ls with - | List_Cons y tl -> if y = x then Return true else list_mem_loop x tl - | List_Nil -> Return false - end - -(** [loops::list_mem]: forward function *) -let list_mem (x : u32) (ls : list_t u32) : result bool = - list_mem_loop x ls - -(** [loops::list_nth_mut_loop]: decreases clause *) -unfold -let list_nth_mut_loop_loop_decreases (t : Type0) (ls : list_t t) (i : u32) : - nat = - admit () - -(** [loops::list_nth_mut_loop]: loop 0: forward function *) -let rec list_nth_mut_loop_loop - (t : Type0) (ls : list_t t) (i : u32) : - Tot (result t) (decreases (list_nth_mut_loop_loop_decreases t ls i)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_loop_loop t tl i0 - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop]: forward function *) -let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result t = - list_nth_mut_loop_loop t ls i - -(** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) -let rec list_nth_mut_loop_loop_back - (t : Type0) (ls : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) (decreases (list_nth_mut_loop_loop_decreases t ls i)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Return (List_Cons ret tl) - else - let* i0 = u32_sub i 1 in - let* tl0 = list_nth_mut_loop_loop_back t tl i0 ret in - Return (List_Cons x tl0) - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop]: backward function 0 *) -let list_nth_mut_loop_back - (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = - list_nth_mut_loop_loop_back t ls i ret - -(** [loops::list_nth_shared_loop]: decreases clause *) -unfold -let list_nth_shared_loop_loop_decreases (t : Type0) (ls : list_t t) (i : u32) : - nat = - admit () - -(** [loops::list_nth_shared_loop]: loop 0: forward function *) -let rec list_nth_shared_loop_loop - (t : Type0) (ls : list_t t) (i : u32) : - Tot (result t) (decreases (list_nth_shared_loop_loop_decreases t ls i)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_loop_loop t tl i0 - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_loop]: forward function *) -let list_nth_shared_loop (t : Type0) (ls : list_t t) (i : u32) : result t = - list_nth_shared_loop_loop t ls i - -(** [loops::get_elem_mut]: decreases clause *) -unfold -let get_elem_mut_loop_decreases (x : usize) (ls : list_t usize) : nat = - admit () - -(** [loops::get_elem_mut]: loop 0: forward function *) -let rec get_elem_mut_loop - (x : usize) (ls : list_t usize) : - Tot (result usize) (decreases (get_elem_mut_loop_decreases x ls)) - = - begin match ls with - | List_Cons y tl -> if y = x then Return y else get_elem_mut_loop x tl - | List_Nil -> Fail Failure - end - -(** [loops::get_elem_mut]: forward function *) -let get_elem_mut - (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = - let* l = - alloc_vec_Vec_index_mut (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) - slots 0 in - get_elem_mut_loop x l - -(** [loops::get_elem_mut]: loop 0: backward function 0 *) -let rec get_elem_mut_loop_back - (x : usize) (ls : list_t usize) (ret : usize) : - Tot (result (list_t usize)) (decreases (get_elem_mut_loop_decreases x ls)) - = - begin match ls with - | List_Cons y tl -> - if y = x - then Return (List_Cons ret tl) - else let* tl0 = get_elem_mut_loop_back x tl ret in Return (List_Cons y tl0) - | List_Nil -> Fail Failure - end - -(** [loops::get_elem_mut]: backward function 0 *) -let get_elem_mut_back - (slots : alloc_vec_Vec (list_t usize)) (x : usize) (ret : usize) : - result (alloc_vec_Vec (list_t usize)) - = - let* l = - alloc_vec_Vec_index_mut (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) - slots 0 in - let* l0 = get_elem_mut_loop_back x l ret in - alloc_vec_Vec_index_mut_back (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) slots - 0 l0 - -(** [loops::get_elem_shared]: decreases clause *) -unfold -let get_elem_shared_loop_decreases (x : usize) (ls : list_t usize) : nat = - admit () - -(** [loops::get_elem_shared]: loop 0: forward function *) -let rec get_elem_shared_loop - (x : usize) (ls : list_t usize) : - Tot (result usize) (decreases (get_elem_shared_loop_decreases x ls)) - = - begin match ls with - | List_Cons y tl -> if y = x then Return y else get_elem_shared_loop x tl - | List_Nil -> Fail Failure - end - -(** [loops::get_elem_shared]: forward function *) -let get_elem_shared - (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = - let* l = - alloc_vec_Vec_index (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) - slots 0 in - get_elem_shared_loop x l - -(** [loops::id_mut]: forward function *) -let id_mut (t : Type0) (ls : list_t t) : result (list_t t) = - Return ls - -(** [loops::id_mut]: backward function 0 *) -let id_mut_back - (t : Type0) (ls : list_t t) (ret : list_t t) : result (list_t t) = - Return ret - -(** [loops::id_shared]: forward function *) -let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = - Return ls - -(** [loops::list_nth_mut_loop_with_id]: decreases clause *) -unfold -let list_nth_mut_loop_with_id_loop_decreases (t : Type0) (i : u32) - (ls : list_t t) : nat = - admit () - -(** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) -let rec list_nth_mut_loop_with_id_loop - (t : Type0) (i : u32) (ls : list_t t) : - Tot (result t) (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_mut_loop_with_id_loop t i0 tl - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_with_id]: forward function *) -let list_nth_mut_loop_with_id - (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls0 = id_mut t ls in list_nth_mut_loop_with_id_loop t i ls0 - -(** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) -let rec list_nth_mut_loop_with_id_loop_back - (t : Type0) (i : u32) (ls : list_t t) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Return (List_Cons ret tl) - else - let* i0 = u32_sub i 1 in - let* tl0 = list_nth_mut_loop_with_id_loop_back t i0 tl ret in - Return (List_Cons x tl0) - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_with_id]: backward function 0 *) -let list_nth_mut_loop_with_id_back - (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = - let* ls0 = id_mut t ls in - let* l = list_nth_mut_loop_with_id_loop_back t i ls0 ret in - id_mut_back t ls l - -(** [loops::list_nth_shared_loop_with_id]: decreases clause *) -unfold -let list_nth_shared_loop_with_id_loop_decreases (t : Type0) (i : u32) - (ls : list_t t) : nat = - admit () - -(** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) -let rec list_nth_shared_loop_with_id_loop - (t : Type0) (i : u32) (ls : list_t t) : - Tot (result t) - (decreases (list_nth_shared_loop_with_id_loop_decreases t i ls)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Return x - else let* i0 = u32_sub i 1 in list_nth_shared_loop_with_id_loop t i0 tl - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_loop_with_id]: forward function *) -let list_nth_shared_loop_with_id - (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls0 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls0 - -(** [loops::list_nth_mut_loop_pair]: decreases clause *) -unfold -let list_nth_mut_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) - (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) -let rec list_nth_mut_loop_pair_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_pair]: forward function *) -let list_nth_mut_loop_pair - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) -let rec list_nth_mut_loop_pair_loop_back'a - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (List_Cons ret tl0) - else - let* i0 = u32_sub i 1 in - let* tl00 = list_nth_mut_loop_pair_loop_back'a t tl0 tl1 i0 ret in - Return (List_Cons x0 tl00) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_pair]: backward function 0 *) -let list_nth_mut_loop_pair_back'a - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - result (list_t t) - = - list_nth_mut_loop_pair_loop_back'a t ls0 ls1 i ret - -(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 *) -let rec list_nth_mut_loop_pair_loop_back'b - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_mut_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (List_Cons ret tl1) - else - let* i0 = u32_sub i 1 in - let* tl10 = list_nth_mut_loop_pair_loop_back'b t tl0 tl1 i0 ret in - Return (List_Cons x1 tl10) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_pair]: backward function 1 *) -let list_nth_mut_loop_pair_back'b - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - result (list_t t) - = - list_nth_mut_loop_pair_loop_back'b t ls0 ls1 i ret - -(** [loops::list_nth_shared_loop_pair]: decreases clause *) -unfold -let list_nth_shared_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) - (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) -let rec list_nth_shared_loop_pair_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_shared_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else let* i0 = u32_sub i 1 in list_nth_shared_loop_pair_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_loop_pair]: forward function *) -let list_nth_shared_loop_pair - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_mut_loop_pair_merge]: decreases clause *) -unfold -let list_nth_mut_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) - (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_mut_loop_pair_merge_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else - let* i0 = u32_sub i 1 in list_nth_mut_loop_pair_merge_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_pair_merge]: forward function *) -let list_nth_mut_loop_pair_merge - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_loop_pair_merge_loop t ls0 ls1 i - -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) -let rec list_nth_mut_loop_pair_merge_loop_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : (t & t)) : - Tot (result ((list_t t) & (list_t t))) - (decreases (list_nth_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then let (x, x2) = ret in Return (List_Cons x tl0, List_Cons x2 tl1) - else - let* i0 = u32_sub i 1 in - let* (tl00, tl10) = - list_nth_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (List_Cons x0 tl00, List_Cons x1 tl10) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_loop_pair_merge]: backward function 0 *) -let list_nth_mut_loop_pair_merge_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : (t & t)) : - result ((list_t t) & (list_t t)) - = - list_nth_mut_loop_pair_merge_loop_back t ls0 ls1 i ret - -(** [loops::list_nth_shared_loop_pair_merge]: decreases clause *) -unfold -let list_nth_shared_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) - (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_shared_loop_pair_merge_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_shared_loop_pair_merge_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_loop_pair_merge]: forward function *) -let list_nth_shared_loop_pair_merge - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_loop_pair_merge_loop t ls0 ls1 i - -(** [loops::list_nth_mut_shared_loop_pair]: decreases clause *) -unfold -let list_nth_mut_shared_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) - (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) -let rec list_nth_mut_shared_loop_pair_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_mut_shared_loop_pair_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_shared_loop_pair]: forward function *) -let list_nth_mut_shared_loop_pair - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_shared_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) -let rec list_nth_mut_shared_loop_pair_loop_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_mut_shared_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (List_Cons ret tl0) - else - let* i0 = u32_sub i 1 in - let* tl00 = list_nth_mut_shared_loop_pair_loop_back t tl0 tl1 i0 ret in - Return (List_Cons x0 tl00) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_shared_loop_pair]: backward function 0 *) -let list_nth_mut_shared_loop_pair_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - result (list_t t) - = - list_nth_mut_shared_loop_pair_loop_back t ls0 ls1 i ret - -(** [loops::list_nth_mut_shared_loop_pair_merge]: decreases clause *) -unfold -let list_nth_mut_shared_loop_pair_merge_loop_decreases (t : Type0) - (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_mut_shared_loop_pair_merge_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_mut_shared_loop_pair_merge_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) -let list_nth_mut_shared_loop_pair_merge - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i - -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) -let rec list_nth_mut_shared_loop_pair_merge_loop_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_mut_shared_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (List_Cons ret tl0) - else - let* i0 = u32_sub i 1 in - let* tl00 = - list_nth_mut_shared_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (List_Cons x0 tl00) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 *) -let list_nth_mut_shared_loop_pair_merge_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - result (list_t t) - = - list_nth_mut_shared_loop_pair_merge_loop_back t ls0 ls1 i ret - -(** [loops::list_nth_shared_mut_loop_pair]: decreases clause *) -unfold -let list_nth_shared_mut_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) - (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) -let rec list_nth_shared_mut_loop_pair_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_shared_mut_loop_pair_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_mut_loop_pair]: forward function *) -let list_nth_shared_mut_loop_pair - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_mut_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) -let rec list_nth_shared_mut_loop_pair_loop_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_shared_mut_loop_pair_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (List_Cons ret tl1) - else - let* i0 = u32_sub i 1 in - let* tl10 = list_nth_shared_mut_loop_pair_loop_back t tl0 tl1 i0 ret in - Return (List_Cons x1 tl10) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_mut_loop_pair]: backward function 1 *) -let list_nth_shared_mut_loop_pair_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - result (list_t t) - = - list_nth_shared_mut_loop_pair_loop_back t ls0 ls1 i ret - -(** [loops::list_nth_shared_mut_loop_pair_merge]: decreases clause *) -unfold -let list_nth_shared_mut_loop_pair_merge_loop_decreases (t : Type0) - (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = - admit () - -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) -let rec list_nth_shared_mut_loop_pair_merge_loop - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : - Tot (result (t & t)) - (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (x0, x1) - else - let* i0 = u32_sub i 1 in - list_nth_shared_mut_loop_pair_merge_loop t tl0 tl1 i0 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) -let list_nth_shared_mut_loop_pair_merge - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i - -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) -let rec list_nth_shared_mut_loop_pair_merge_loop_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - Tot (result (list_t t)) - (decreases (list_nth_shared_mut_loop_pair_merge_loop_decreases t ls0 ls1 i)) - = - begin match ls0 with - | List_Cons x0 tl0 -> - begin match ls1 with - | List_Cons x1 tl1 -> - if i = 0 - then Return (List_Cons ret tl1) - else - let* i0 = u32_sub i 1 in - let* tl10 = - list_nth_shared_mut_loop_pair_merge_loop_back t tl0 tl1 i0 ret in - Return (List_Cons x1 tl10) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end - -(** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 *) -let list_nth_shared_mut_loop_pair_merge_back - (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : - result (list_t t) - = - list_nth_shared_mut_loop_pair_merge_loop_back t ls0 ls1 i ret - diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/fstar/traits/Primitives.fst b/tests/fstar/traits/Primitives.fst index 71d75c11..3297803c 100644 --- a/tests/fstar/traits/Primitives.fst +++ b/tests/fstar/traits/Primitives.fst @@ -427,7 +427,7 @@ let alloc_vec_Vec_new (a : Type0) : alloc_vec_Vec a = assert_norm(length #a [] let alloc_vec_Vec_len (a : Type0) (v : alloc_vec_Vec a) : usize = length v // Helper -let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result a = +let alloc_vec_Vec_index_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : result a = if i < length v then Return (index v i) else Fail Failure // Helper let alloc_vec_Vec_update_usize (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : result (alloc_vec_Vec a) = @@ -704,6 +704,22 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) (*** Theorems *) +let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + +let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : + Lemma ( + alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_usize v i) + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + = + admit() + let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == diff --git a/tests/lean/Hashmap/Properties.lean b/tests/lean/Hashmap/Properties.lean index 4db54316..e79c422d 100644 --- a/tests/lean/Hashmap/Properties.lean +++ b/tests/lean/Hashmap/Properties.lean @@ -157,7 +157,7 @@ instance : Inhabited (List α) where def slots_s_inv (s : Core.List (List α)) : Prop := ∀ (i : Int), 0 ≤ i → i < s.len → slot_t_inv s.len i (s.index i) -def slots_t_inv (s : Vec (List α)) : Prop := +def slots_t_inv (s : alloc.vec.Vec (List α)) : Prop := slots_s_inv s.v @[simp] @@ -302,13 +302,14 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value | none => nhm.len_s = hm.len_s + 1 | some _ => nhm.len_s = hm.len_s) := by rw [insert_no_resize] - simp only [hash_key, bind_tc_ret] -- TODO: annoying - have _ : (Vec.len (List α) hm.slots).val ≠ 0 := by + -- Simplify. Note that this also simplifies some function calls, like array index + simp [hash_key, bind_tc_ret] + have _ : (alloc.vec.Vec.len (List α) hm.slots).val ≠ 0 := by intro simp_all [inv] progress as ⟨ hash_mod, hhm ⟩ have _ : 0 ≤ hash_mod.val := by scalar_tac - have _ : hash_mod.val < Vec.length hm.slots := by + have _ : hash_mod.val < alloc.vec.Vec.length hm.slots := by have : 0 < hm.slots.val.len := by simp [inv] at hinv simp [hinv] @@ -374,7 +375,7 @@ theorem insert_no_resize_spec {α : Type} (hm : HashMap α) (key : Usize) (value -- TODO: we want to automate this simp apply Int.emod_nonneg k.val hvnz - have _ : k_hash_mod < Vec.length hm.slots := by + have _ : k_hash_mod < alloc.vec.Vec.length hm.slots := by -- TODO: we want to automate this simp have h := Int.emod_lt_of_pos k.val hvpos -- cgit v1.2.3 From eb216298bcc9190fab85434aaf54a3de3fb4d6a4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 18:38:29 +0100 Subject: Make administrative updates in the tests --- tests/fstar/demo/Primitives.fst | 405 ---------------------------------------- tests/fstar/traits/Makefile | 49 +++++ 2 files changed, 49 insertions(+), 405 deletions(-) delete mode 100644 tests/fstar/demo/Primitives.fst create mode 100644 tests/fstar/traits/Makefile diff --git a/tests/fstar/demo/Primitives.fst b/tests/fstar/demo/Primitives.fst deleted file mode 100644 index e9391834..00000000 --- a/tests/fstar/demo/Primitives.fst +++ /dev/null @@ -1,405 +0,0 @@ -/// This file lists primitive and assumed functions and types -module Primitives -open FStar.Mul -open FStar.List.Tot - -#set-options "--z3rlimit 15 --fuel 0 --ifuel 1" - -(*** Utilities *) -val list_update (#a : Type0) (ls : list a) (i : nat{i < length ls}) (x : a) : - ls':list a{ - length ls' = length ls /\ - index ls' i == x - } -#push-options "--fuel 1" -let rec list_update #a ls i x = - match ls with - | x' :: ls -> if i = 0 then x :: ls else x' :: list_update ls (i-1) x -#pop-options - -(*** Result *) -type error : Type0 = -| Failure -| OutOfFuel - -type result (a : Type0) : Type0 = -| Return : v:a -> result a -| Fail : e:error -> result a - -// Monadic return operator -unfold let return (#a : Type0) (x : a) : result a = Return x - -// Monadic bind operator. -// Allows to use the notation: -// ``` -// let* x = y in -// ... -// ``` -unfold let (let*) (#a #b : Type0) (m: result a) - (f: (x:a) -> Pure (result b) (requires (m == Return x)) (ensures fun _ -> True)) : - result b = - match m with - | Return x -> f x - | Fail e -> Fail e - -// Monadic assert(...) -let massert (b:bool) : result unit = if b then Return () else Fail Failure - -// Normalize and unwrap a successful result (used for globals). -let eval_global (#a : Type0) (x : result a{Return? (normalize_term x)}) : a = Return?.v x - -(*** Misc *) -type char = FStar.Char.char -type string = string - -let is_zero (n: nat) : bool = n = 0 -let decrease (n: nat{n > 0}) : nat = n - 1 - -let mem_replace_fwd (a : Type0) (x : a) (y : a) : a = x -let mem_replace_back (a : Type0) (x : a) (y : a) : a = y - -(*** Scalars *) -/// Rem.: most of the following code was partially generated - -let isize_min : int = -9223372036854775808 // TODO: should be opaque -let isize_max : int = 9223372036854775807 // TODO: should be opaque -let i8_min : int = -128 -let i8_max : int = 127 -let i16_min : int = -32768 -let i16_max : int = 32767 -let i32_min : int = -2147483648 -let i32_max : int = 2147483647 -let i64_min : int = -9223372036854775808 -let i64_max : int = 9223372036854775807 -let i128_min : int = -170141183460469231731687303715884105728 -let i128_max : int = 170141183460469231731687303715884105727 -let usize_min : int = 0 -let usize_max : int = 4294967295 // TODO: should be opaque -let u8_min : int = 0 -let u8_max : int = 255 -let u16_min : int = 0 -let u16_max : int = 65535 -let u32_min : int = 0 -let u32_max : int = 4294967295 -let u64_min : int = 0 -let u64_max : int = 18446744073709551615 -let u128_min : int = 0 -let u128_max : int = 340282366920938463463374607431768211455 - -type scalar_ty = -| Isize -| I8 -| I16 -| I32 -| I64 -| I128 -| Usize -| U8 -| U16 -| U32 -| U64 -| U128 - -let scalar_min (ty : scalar_ty) : int = - match ty with - | Isize -> isize_min - | I8 -> i8_min - | I16 -> i16_min - | I32 -> i32_min - | I64 -> i64_min - | I128 -> i128_min - | Usize -> usize_min - | U8 -> u8_min - | U16 -> u16_min - | U32 -> u32_min - | U64 -> u64_min - | U128 -> u128_min - -let scalar_max (ty : scalar_ty) : int = - match ty with - | Isize -> isize_max - | I8 -> i8_max - | I16 -> i16_max - | I32 -> i32_max - | I64 -> i64_max - | I128 -> i128_max - | Usize -> usize_max - | U8 -> u8_max - | U16 -> u16_max - | U32 -> u32_max - | U64 -> u64_max - | U128 -> u128_max - -type scalar (ty : scalar_ty) : eqtype = x:int{scalar_min ty <= x && x <= scalar_max ty} - -let mk_scalar (ty : scalar_ty) (x : int) : result (scalar ty) = - if scalar_min ty <= x && scalar_max ty >= x then Return x else Fail Failure - -let scalar_neg (#ty : scalar_ty) (x : scalar ty) : result (scalar ty) = mk_scalar ty (-x) - -let scalar_div (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - if y <> 0 then mk_scalar ty (x / y) else Fail Failure - -/// The remainder operation -let int_rem (x : int) (y : int{y <> 0}) : int = - if x >= 0 then (x % y) else -(x % y) - -(* Checking consistency with Rust *) -let _ = assert_norm(int_rem 1 2 = 1) -let _ = assert_norm(int_rem (-1) 2 = -1) -let _ = assert_norm(int_rem 1 (-2) = 1) -let _ = assert_norm(int_rem (-1) (-2) = -1) - -let scalar_rem (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - if y <> 0 then mk_scalar ty (int_rem x y) else Fail Failure - -let scalar_add (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - mk_scalar ty (x + y) - -let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - mk_scalar ty (x - y) - -let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = - mk_scalar ty (x * y) - -(** Cast an integer from a [src_ty] to a [tgt_ty] *) -// TODO: check the semantics of casts in Rust -let scalar_cast (src_ty : scalar_ty) (tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) = - mk_scalar tgt_ty x - -/// The scalar types -type isize : eqtype = scalar Isize -type i8 : eqtype = scalar I8 -type i16 : eqtype = scalar I16 -type i32 : eqtype = scalar I32 -type i64 : eqtype = scalar I64 -type i128 : eqtype = scalar I128 -type usize : eqtype = scalar Usize -type u8 : eqtype = scalar U8 -type u16 : eqtype = scalar U16 -type u32 : eqtype = scalar U32 -type u64 : eqtype = scalar U64 -type u128 : eqtype = scalar U128 - - -let core_isize_min : isize = isize_min -let core_isize_max : isize = isize_max -let core_i8_min : i8 = i8_min -let core_i8_max : i8 = i8_max -let core_i16_min : i16 = i16_min -let core_i16_max : i16 = i16_max -let core_i32_min : i32 = i32_min -let core_i32_max : i32 = i32_max -let core_i64_min : i64 = i64_min -let core_i64_max : i64 = i64_max -let core_i128_min : i128 = i128_min -let core_i128_max : i128 = i128_max - -let core_usize_min : usize = usize_min -let core_usize_max : usize = usize_max -let core_u8_min : u8 = u8_min -let core_u8_max : u8 = u8_max -let core_u16_min : u16 = u16_min -let core_u16_max : u16 = u16_max -let core_u32_min : u32 = u32_min -let core_u32_max : u32 = u32_max -let core_u64_min : u64 = u64_min -let core_u64_max : u64 = u64_max -let core_u128_min : u128 = u128_min -let core_u128_max : u128 = u128_max - -/// Negation -let isize_neg = scalar_neg #Isize -let i8_neg = scalar_neg #I8 -let i16_neg = scalar_neg #I16 -let i32_neg = scalar_neg #I32 -let i64_neg = scalar_neg #I64 -let i128_neg = scalar_neg #I128 - -/// Division -let isize_div = scalar_div #Isize -let i8_div = scalar_div #I8 -let i16_div = scalar_div #I16 -let i32_div = scalar_div #I32 -let i64_div = scalar_div #I64 -let i128_div = scalar_div #I128 -let usize_div = scalar_div #Usize -let u8_div = scalar_div #U8 -let u16_div = scalar_div #U16 -let u32_div = scalar_div #U32 -let u64_div = scalar_div #U64 -let u128_div = scalar_div #U128 - -/// Remainder -let isize_rem = scalar_rem #Isize -let i8_rem = scalar_rem #I8 -let i16_rem = scalar_rem #I16 -let i32_rem = scalar_rem #I32 -let i64_rem = scalar_rem #I64 -let i128_rem = scalar_rem #I128 -let usize_rem = scalar_rem #Usize -let u8_rem = scalar_rem #U8 -let u16_rem = scalar_rem #U16 -let u32_rem = scalar_rem #U32 -let u64_rem = scalar_rem #U64 -let u128_rem = scalar_rem #U128 - -/// Addition -let isize_add = scalar_add #Isize -let i8_add = scalar_add #I8 -let i16_add = scalar_add #I16 -let i32_add = scalar_add #I32 -let i64_add = scalar_add #I64 -let i128_add = scalar_add #I128 -let usize_add = scalar_add #Usize -let u8_add = scalar_add #U8 -let u16_add = scalar_add #U16 -let u32_add = scalar_add #U32 -let u64_add = scalar_add #U64 -let u128_add = scalar_add #U128 - -/// Substraction -let isize_sub = scalar_sub #Isize -let i8_sub = scalar_sub #I8 -let i16_sub = scalar_sub #I16 -let i32_sub = scalar_sub #I32 -let i64_sub = scalar_sub #I64 -let i128_sub = scalar_sub #I128 -let usize_sub = scalar_sub #Usize -let u8_sub = scalar_sub #U8 -let u16_sub = scalar_sub #U16 -let u32_sub = scalar_sub #U32 -let u64_sub = scalar_sub #U64 -let u128_sub = scalar_sub #U128 - -/// Multiplication -let isize_mul = scalar_mul #Isize -let i8_mul = scalar_mul #I8 -let i16_mul = scalar_mul #I16 -let i32_mul = scalar_mul #I32 -let i64_mul = scalar_mul #I64 -let i128_mul = scalar_mul #I128 -let usize_mul = scalar_mul #Usize -let u8_mul = scalar_mul #U8 -let u16_mul = scalar_mul #U16 -let u32_mul = scalar_mul #U32 -let u64_mul = scalar_mul #U64 -let u128_mul = scalar_mul #U128 - -(*** Range *) -type range (a : Type0) = { - start : a; - end_ : a; -} - -(*** Array *) -type array (a : Type0) (n : usize) = s:list a{length s = n} - -// We tried putting the normalize_term condition as a refinement on the list -// but it didn't work. It works with the requires clause. -let mk_array (a : Type0) (n : usize) - (l : list a) : - Pure (array a n) - (requires (normalize_term(FStar.List.Tot.length l) = n)) - (ensures (fun _ -> True)) = - normalize_term_spec (FStar.List.Tot.length l); - l - -let array_index_shared (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_fwd (a : Type0) (n : usize) (x : array a n) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let array_index_mut_back (a : Type0) (n : usize) (x : array a n) (i : usize) (nx : a) : result (array a n) = - if i < length x then Return (list_update x i nx) - else Fail Failure - -(*** Slice *) -type slice (a : Type0) = s:list a{length s <= usize_max} - -let slice_len (a : Type0) (s : slice a) : usize = length s - -let slice_index_shared (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_fwd (a : Type0) (x : slice a) (i : usize) : result a = - if i < length x then Return (index x i) - else Fail Failure - -let slice_index_mut_back (a : Type0) (x : slice a) (i : usize) (nx : a) : result (slice a) = - if i < length x then Return (list_update x i nx) - else Fail Failure - -(*** Subslices *) - -let array_to_slice_shared (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_fwd (a : Type0) (n : usize) (x : array a n) : result (slice a) = Return x -let array_to_slice_mut_back (a : Type0) (n : usize) (x : array a n) (s : slice a) : result (array a n) = - if length s = n then Return s - else Fail Failure - -// TODO: finish the definitions below (there lacks [List.drop] and [List.take] in the standard library *) -let array_subslice_shared (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_fwd (a : Type0) (n : usize) (x : array a n) (r : range usize) : result (slice a) = - admit() - -let array_subslice_mut_back (a : Type0) (n : usize) (x : array a n) (r : range usize) (ns : slice a) : result (array a n) = - admit() - -let array_repeat (a : Type0) (n : usize) (x : a) : array a n = - admit() - -let slice_subslice_shared (a : Type0) (x : slice a) (r : range usize) : result (slice a) = - admit() - -let slice_subslice_mut_fwd (a : Type0) (x : slice a) (r : range usize) : result (slice a) = - admit() - -let slice_subslice_mut_back (a : Type0) (x : slice a) (r : range usize) (ns : slice a) : result (slice a) = - admit() - -(*** Vector *) -type vec (a : Type0) = v:list a{length v <= usize_max} - -let vec_new (a : Type0) : vec a = assert_norm(length #a [] == 0); [] -let vec_len (a : Type0) (v : vec a) : usize = length v - -// The **forward** function shouldn't be used -let vec_push_fwd (a : Type0) (v : vec a) (x : a) : unit = () -let vec_push_back (a : Type0) (v : vec a) (x : a) : - Pure (result (vec a)) - (requires True) - (ensures (fun res -> - match res with - | Fail e -> e == Failure - | Return v' -> length v' = length v + 1)) = - if length v < usize_max then begin - (**) assert_norm(length [x] == 1); - (**) append_length v [x]; - (**) assert(length (append v [x]) = length v + 1); - Return (append v [x]) - end - else Fail Failure - -// The **forward** function shouldn't be used -let vec_insert_fwd (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure -let vec_insert_back (a : Type0) (v : vec a) (i : usize) (x : a) : result (vec a) = - if i < length v then Return (list_update v i x) else Fail Failure - -// The **backward** function shouldn't be used -let vec_index_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_back (a : Type0) (v : vec a) (i : usize) (x : a) : result unit = - if i < length v then Return () else Fail Failure - -let vec_index_mut_fwd (a : Type0) (v : vec a) (i : usize) : result a = - if i < length v then Return (index v i) else Fail Failure -let vec_index_mut_back (a : Type0) (v : vec a) (i : usize) (nx : a) : result (vec a) = - if i < length v then Return (list_update v i nx) else Fail Failure diff --git a/tests/fstar/traits/Makefile b/tests/fstar/traits/Makefile new file mode 100644 index 00000000..fa7d1f36 --- /dev/null +++ b/tests/fstar/traits/Makefile @@ -0,0 +1,49 @@ +# This file was automatically generated - modify ../Makefile.template instead +INCLUDE_DIRS = . + +FSTAR_INCLUDES = $(addprefix --include ,$(INCLUDE_DIRS)) + +FSTAR_HINTS ?= --use_hints --use_hint_hashes --record_hints + +FSTAR_OPTIONS = $(FSTAR_HINTS) \ + --cache_checked_modules $(FSTAR_INCLUDES) --cmi \ + --warn_error '+241@247+285-274' \ + +FSTAR_EXE ?= fstar.exe +FSTAR_NO_FLAGS = $(FSTAR_EXE) --already_cached 'Prims FStar LowStar Steel' --odir obj --cache_dir obj + +FSTAR = $(FSTAR_NO_FLAGS) $(FSTAR_OPTIONS) + +# The F* roots are used to compute the dependency graph, and generate the .depend file +FSTAR_ROOTS ?= $(wildcard *.fst *.fsti) + +# Build all the files +all: $(addprefix obj/,$(addsuffix .checked,$(FSTAR_ROOTS))) + +# This is the right way to ensure the .depend file always gets re-built. +ifeq (,$(filter %-in,$(MAKECMDGOALS))) +ifndef NODEPEND +ifndef MAKE_RESTARTS +.depend: .FORCE + $(FSTAR_NO_FLAGS) --dep full $(notdir $(FSTAR_ROOTS)) > $@ + +.PHONY: .FORCE +.FORCE: +endif +endif + +include .depend +endif + +# For the interactive mode +%.fst-in %.fsti-in: + @echo $(FSTAR_OPTIONS) + +# Generete the .checked files in batch mode +%.checked: + $(FSTAR) $(FSTAR_OPTIONS) $< && \ + touch -c $@ + +.PHONY: clean +clean: + rm -f obj/* -- cgit v1.2.3 From cc61ce2217339f24a8cc8951ee15abc5fd90b47b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 9 Nov 2023 18:51:43 +0100 Subject: Update the rule build-bin-dir in the Makefile --- Makefile | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 427a5751..4660ac83 100644 --- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ CHARON_TESTS_POLONIUS_DIR ?= $(CHARON_HOME)/tests-polonius # The path to the Aeneas executable to run the tests - we need the ability to # change this path for the Nix package. -AENEAS_EXE ?= bin/aeneas.exe +AENEAS_EXE ?= bin/aeneas # The user can specify additional translation options for Aeneas. # By default we do: @@ -71,9 +71,12 @@ build-lib: .PHONY: build-bin-dir build-bin-dir: build-driver build-lib mkdir -p bin - cp -f compiler/_build/default/driver.exe bin/aeneas.exe + cp -f compiler/_build/default/driver.exe bin/aeneas cp -f compiler/_build/default/driver.exe bin/aeneas.cmxs - cp -rf backends bin + mkdir -p bin/backends/fstar + mkdir -p bin/backends/coq + cp -rf backends/fstar/*.fst* bin/backends/fstar/ + cp -rf backends/coq/*.v bin/backends/coq/ .PHONY: doc doc: -- cgit v1.2.3 From f6bb1983fbbc60ee8f3fd546348a4860688e5b5e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 13:31:37 +0100 Subject: Update the flake.lock --- flake.lock | 137 ++++++++++++++++++++----------------------------------------- 1 file changed, 44 insertions(+), 93 deletions(-) diff --git a/flake.lock b/flake.lock index 9258bf18..e637bc27 100644 --- a/flake.lock +++ b/flake.lock @@ -5,14 +5,14 @@ "crane": "crane", "flake-utils": "flake-utils", "nixpkgs": "nixpkgs", - "rust-overlay": "rust-overlay_2" + "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1691568898, - "narHash": "sha256-BqKlmpX+tV2VYDZXhIhPbO1v9fbNy1/pzd8AooOXvxE=", + "lastModified": 1699619324, + "narHash": "sha256-QscTkSBWlmKhODEOavw29MIxOhue9oHdoDXkOmCOgnk=", "owner": "aeneasverif", "repo": "charon", - "rev": "5a81a41bafe18101d368e9ab4af440d7fefeee25", + "rev": "7de1d1e7131f20e56b37ce50adbeb7c947f72f44", "type": "github" }, "original": { @@ -23,23 +23,17 @@ }, "crane": { "inputs": { - "flake-compat": "flake-compat", - "flake-utils": [ - "charon", - "flake-utils" - ], "nixpkgs": [ "charon", "nixpkgs" - ], - "rust-overlay": "rust-overlay" + ] }, "locked": { - "lastModified": 1691423162, - "narHash": "sha256-cReUZCo83YEEmFcHX8CcOVTZYUrcWgHQO34zxQzy7WI=", + "lastModified": 1699548976, + "narHash": "sha256-xnpxms0koM8mQpxIup9JnT0F7GrKdvv0QvtxvRuOYR4=", "owner": "ipetkov", "repo": "crane", - "rev": "b5d9d42ea3fa8fea1805d9af1416fe207d0dd1dc", + "rev": "6849911446e18e520970cc6b7a691e64ee90d649", "type": "github" }, "original": { @@ -48,32 +42,16 @@ "type": "github" } }, - "flake-compat": { - "flake": false, - "locked": { - "lastModified": 1673956053, - "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "inputs": { "systems": "systems" }, "locked": { - "lastModified": 1689068808, - "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=", + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", "owner": "numtide", "repo": "flake-utils", - "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { @@ -87,11 +65,11 @@ "systems": "systems_2" }, "locked": { - "lastModified": 1681202837, - "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", + "lastModified": 1692799911, + "narHash": "sha256-3eihraek4qL744EvQXsK1Ha6C3CR7nnT8X2qWap4RNk=", "owner": "numtide", "repo": "flake-utils", - "rev": "cfacdce06f30d2b68473a46042957675eebb3401", + "rev": "f9e7cf818399d17d347f847525c5a5a8032e4e44", "type": "github" }, "original": { @@ -104,11 +82,11 @@ "systems": "systems_3" }, "locked": { - "lastModified": 1689068808, - "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=", + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", "owner": "numtide", "repo": "flake-utils", - "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { @@ -153,11 +131,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1690839655, - "narHash": "sha256-285hRt/qzVSMPf34OS187WH4q4edPtb86UJrdZAPtfY=", + "lastModified": 1699558636, + "narHash": "sha256-N4fyP0An2JBC3PRI0/zSeAapDG4gOYH2D40eHXCOemQ=", "owner": "fstarlang", "repo": "fstar", - "rev": "8f812f3adb7e35810edca22a02016f269c0d1d2a", + "rev": "9b60a5b758581edb32488a13e11039db199f89e1", "type": "github" }, "original": { @@ -186,11 +164,11 @@ ] }, "locked": { - "lastModified": 1688938536, - "narHash": "sha256-P+uk/ZbY9+StXs5SivB5lT5qUiPWnz5gSozJ3isezWs=", + "lastModified": 1699550761, + "narHash": "sha256-BNjPd2DuxNCZBeRwcIJH3SZ9/q7+Ny3j8gZDmOvuENs=", "owner": "hacl-star", "repo": "hacl-star", - "rev": "d2f087304c0b59c0486e25ff2f1daec78d92f69b", + "rev": "e1a785f7e88bb6668c9beabd4dc292a03c68bb2e", "type": "github" }, "original": { @@ -216,11 +194,11 @@ ] }, "locked": { - "lastModified": 1690853873, - "narHash": "sha256-RWmZC/Qp8+l/HsbYk982Jqp+zxqYzzsbP60NEhZktwY=", + "lastModified": 1699578804, + "narHash": "sha256-ss+mguIO6C1DBiKkw/5C5M2N3TiNirBagQ0CUZxlt1I=", "owner": "hacl-star", "repo": "hacl-nix", - "rev": "11df45d92e34f23a86bde4134114b023ce0cd6a9", + "rev": "19d0224fffa227ca6374d173f5dfeb7c2b61cf4a", "type": "github" }, "original": { @@ -245,11 +223,11 @@ ] }, "locked": { - "lastModified": 1690242065, - "narHash": "sha256-YCHBlXiQqO5A27f+2p/NdtKKP0GNqNEUTH2tMwtFDkQ=", + "lastModified": 1698968585, + "narHash": "sha256-x3ZaGrmuKF5+7xaWHu0yDikl4mrawkY5tQnfovgyPh8=", "owner": "fstarlang", "repo": "karamel", - "rev": "ed0c7e432715f95c6b9f4268eb1082eb636356a1", + "rev": "a7be2a7c43eca637ceb57fe8f3ffd16fc6627ebd", "type": "github" }, "original": { @@ -287,11 +265,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1691545327, - "narHash": "sha256-9oAUBNRvZxK8dBuxzH5GGhET5lyolecOHmbwywgyk4s=", + "lastModified": 1699614992, + "narHash": "sha256-eSxx1UA47oBzpZGc4tIp6YP2qti1Hrc36Yo77XFnXH0=", "owner": "leanprover", "repo": "lean4", - "rev": "e7a1512da8d6f9339766f3a269de56e546757fde", + "rev": "5189578a488572b39d102b2e8825bf2a1d2c2b76", "type": "github" }, "original": { @@ -340,11 +318,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1691545327, - "narHash": "sha256-9oAUBNRvZxK8dBuxzH5GGhET5lyolecOHmbwywgyk4s=", + "lastModified": 1699614992, + "narHash": "sha256-eSxx1UA47oBzpZGc4tIp6YP2qti1Hrc36Yo77XFnXH0=", "owner": "leanprover", "repo": "lean4", - "rev": "e7a1512da8d6f9339766f3a269de56e546757fde", + "rev": "5189578a488572b39d102b2e8825bf2a1d2c2b76", "type": "github" }, "original": { @@ -427,11 +405,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1691472822, - "narHash": "sha256-XVfYZ2oB3lNPVq6sHCY9WkdQ8lHoIDzzbpg8bB6oBxA=", + "lastModified": 1699099776, + "narHash": "sha256-X09iKJ27mGsGambGfkKzqvw5esP1L/Rf8H3u3fCqIiU=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "41c7605718399dcfa53dd7083793b6ae3bc969ff", + "rev": "85f1ba3e51676fa8cc604a3d863d729026a6b8eb", "type": "github" }, "original": { @@ -474,11 +452,11 @@ }, "nixpkgs_2": { "locked": { - "lastModified": 1684385584, - "narHash": "sha256-O7y0gK8OLIDqz+LaHJJyeu09IGiXlZIS3+JgEzGmmJA=", + "lastModified": 1693158576, + "narHash": "sha256-aRTTXkYvhXosGx535iAFUaoFboUrZSYb1Ooih/auGp0=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "48a0fb7aab511df92a17cf239c37f2bd2ec9ae3a", + "rev": "a999c1cc0c9eb2095729d5aa03e0d8f7ed256780", "type": "github" }, "original": { @@ -584,33 +562,6 @@ } }, "rust-overlay": { - "inputs": { - "flake-utils": [ - "charon", - "crane", - "flake-utils" - ], - "nixpkgs": [ - "charon", - "crane", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1691029059, - "narHash": "sha256-QwVeE9YTgH3LmL7yw2V/hgswL6yorIvYSp4YGI8lZYM=", - "owner": "oxalica", - "repo": "rust-overlay", - "rev": "99df4908445be37ddb2d332580365fce512a7dcf", - "type": "github" - }, - "original": { - "owner": "oxalica", - "repo": "rust-overlay", - "type": "github" - } - }, - "rust-overlay_2": { "inputs": { "flake-utils": [ "charon", @@ -622,11 +573,11 @@ ] }, "locked": { - "lastModified": 1691547503, - "narHash": "sha256-l0AIKJucygbDFc2vuAkxmFMjNNJImDd7jYahA88/E+o=", + "lastModified": 1699582387, + "narHash": "sha256-sPmUXPDl+cEi+zFtM5lnAs7dWOdRn0ptZ4a/qHwvNDk=", "owner": "oxalica", "repo": "rust-overlay", - "rev": "3380f16b39457b49c8186d5e20e7a68ccf4fc96e", + "rev": "41f7b0618052430d3a050e8f937030d00a2fcced", "type": "github" }, "original": { -- cgit v1.2.3 From 865c49d33feeec34ceded80fbaa22c94625a4e91 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 16:40:10 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 664dc674..dc6b64f6 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -17,3 +17,8 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-verify-coq #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 + # Lean isn't supported by Nix, so we need to add extra steps + # Install Elan (https://leanprover-community.github.io/install/linux.html) + - curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + # Verify + - cd tests/lean && make -- cgit v1.2.3 From 084599ea54925d716251d0bbf120555d38c3ec14 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 16:41:37 +0100 Subject: Make a minor update --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index dc6b64f6..6fba43a5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -19,6 +19,6 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 # Lean isn't supported by Nix, so we need to add extra steps # Install Elan (https://leanprover-community.github.io/install/linux.html) - - curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + - runs: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh # Verify - - cd tests/lean && make + - run: cd tests/lean && make -- cgit v1.2.3 From 8471e87b2b1b8123f15f5613e633daf68ccf94dc Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 16:42:19 +0100 Subject: Make a minor fix --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6fba43a5..a67a2aed 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -19,6 +19,6 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 # Lean isn't supported by Nix, so we need to add extra steps # Install Elan (https://leanprover-community.github.io/install/linux.html) - - runs: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh # Verify - run: cd tests/lean && make -- cgit v1.2.3 From e3dc6001c953cd3a292326672762b4dfdbbb933c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 16:54:34 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a67a2aed..d8a91aa7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -17,8 +17,12 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-verify-coq #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 - # Lean isn't supported by Nix, so we need to add extra steps + lean: # Lean isn't supported by Nix, so we need to add extra steps + runs-on: [self-hosted, linux] + steps: # Install Elan (https://leanprover-community.github.io/install/linux.html) - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + # We need make + - run: sudo apt-get update && sudo apt-get install make # Verify - run: cd tests/lean && make -- cgit v1.2.3 From 335e1fdf1b55fa49c378a32dc5619369f366027c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 16:56:20 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d8a91aa7..1ac5dd94 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -22,7 +22,7 @@ jobs: steps: # Install Elan (https://leanprover-community.github.io/install/linux.html) - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh - # We need make - - run: sudo apt-get update && sudo apt-get install make + #- run: sudo apt-get update && sudo apt-get install make # Verify - - run: cd tests/lean && make + #- run: cd tests/lean && make + - cd tests/lean && lake build -- cgit v1.2.3 From 06ca6b4aeee7235acee4d11d67e91e3fe3d3a236 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 16:57:41 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 1ac5dd94..3fb2270a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -25,4 +25,4 @@ jobs: #- run: sudo apt-get update && sudo apt-get install make # Verify #- run: cd tests/lean && make - - cd tests/lean && lake build + - run: cd tests/lean && lake build -- cgit v1.2.3 From a3a1a5e603905fb2bcdf7f05a14282366998b1c4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:00:18 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3fb2270a..a958910b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -18,11 +18,13 @@ jobs: #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 lean: # Lean isn't supported by Nix, so we need to add extra steps - runs-on: [self-hosted, linux] + runs-on: [ubuntu-latest] steps: + # Install curl + - run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh #- run: sudo apt-get update && sudo apt-get install make # Verify - #- run: cd tests/lean && make - - run: cd tests/lean && lake build + - run: cd tests/lean && make + #- run: cd tests/lean && lake build -- cgit v1.2.3 From 27eb90fc61a45f8a8c5f1279082b0210d285bbc1 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:01:48 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a958910b..48392ccc 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,7 +23,7 @@ jobs: # Install curl - run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) - - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + - run: curl -y https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh #- run: sudo apt-get update && sudo apt-get install make # Verify - run: cd tests/lean && make -- cgit v1.2.3 From f00da97a17e4d8445fc74303b907b57b1fbddb1e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:03:32 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 48392ccc..a00c6a24 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,8 +23,8 @@ jobs: # Install curl - run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) - - run: curl -y https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf -y | sh #- run: sudo apt-get update && sudo apt-get install make # Verify - - run: cd tests/lean && make + - run: cd aeneas/tests/lean && make #- run: cd tests/lean && lake build -- cgit v1.2.3 From 5c42ee7194833679264583cf81b0c32898fbb9f2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:04:16 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a00c6a24..7609ee29 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,8 +15,10 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-tests - run: nix build -L .#checks.x86_64-linux.aeneas-verify-fstar - run: nix build -L .#checks.x86_64-linux.aeneas-verify-coq + # HOL4 can be reactivated + #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 + # Lean doesn't work with Nix #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean - - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 lean: # Lean isn't supported by Nix, so we need to add extra steps runs-on: [ubuntu-latest] steps: -- cgit v1.2.3 From 3be02779a3f0decd3e45e1faed6d83992cfb0f0b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:08:10 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7609ee29..8c590a9d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,18 +15,20 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-tests - run: nix build -L .#checks.x86_64-linux.aeneas-verify-fstar - run: nix build -L .#checks.x86_64-linux.aeneas-verify-coq - # HOL4 can be reactivated + # HOL4 can be reactivated, but it is very slow #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 # Lean doesn't work with Nix #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean lean: # Lean isn't supported by Nix, so we need to add extra steps runs-on: [ubuntu-latest] steps: + - run: wget -q https://raw.githubusercontent.com/leanprover-community/mathlib4/master/scripts/install_debian.sh && bash install_debian.sh ; rm -f install_debian.sh && source ~/.profile # Install curl - - run: sudo apt update && sudo apt install curl + #- run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) - - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf -y | sh + #- run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf -y | sh #- run: sudo apt-get update && sudo apt-get install make # Verify - - run: cd aeneas/tests/lean && make + - run: ls + - run: cd tests/lean && make #- run: cd tests/lean && lake build -- cgit v1.2.3 From 4fa2953684e6cb1763b05fd9d392477d04567aaf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:13:37 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8c590a9d..328aaf22 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -22,13 +22,14 @@ jobs: lean: # Lean isn't supported by Nix, so we need to add extra steps runs-on: [ubuntu-latest] steps: - - run: wget -q https://raw.githubusercontent.com/leanprover-community/mathlib4/master/scripts/install_debian.sh && bash install_debian.sh ; rm -f install_debian.sh && source ~/.profile + - run: ls + #- run: wget -q https://raw.githubusercontent.com/leanprover-community/mathlib4/master/scripts/install_debian.sh && bash install_debian.sh ; rm -f install_debian.sh && source ~/.profile # Install curl - #- run: sudo apt update && sudo apt install curl + - run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) - #- run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf -y | sh + #- run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -y #- run: sudo apt-get update && sudo apt-get install make # Verify - - run: ls - run: cd tests/lean && make #- run: cd tests/lean && lake build -- cgit v1.2.3 From f2fd214f6aace2f4dd92411291c2760dadd88116 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:15:49 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 328aaf22..db63f8e3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -28,7 +28,7 @@ jobs: - run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) #- run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh - - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -y + - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -- -y #- run: sudo apt-get update && sudo apt-get install make # Verify - run: cd tests/lean && make -- cgit v1.2.3 From f64cb8cd52871cf5463b68986e6d39e2c133313d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:19:39 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index db63f8e3..7904509b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -22,14 +22,17 @@ jobs: lean: # Lean isn't supported by Nix, so we need to add extra steps runs-on: [ubuntu-latest] steps: - - run: ls #- run: wget -q https://raw.githubusercontent.com/leanprover-community/mathlib4/master/scripts/install_debian.sh && bash install_debian.sh ; rm -f install_debian.sh && source ~/.profile # Install curl - run: sudo apt update && sudo apt install curl # Install Elan (https://leanprover-community.github.io/install/linux.html) + # We updated the script to make it run in non-interactive mode #- run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -- -y #- run: sudo apt-get update && sudo apt-get install make + # Checkout the repo and download it to the runner + - name: Checkout + uses: actions/checkout@v4 # Verify - run: cd tests/lean && make #- run: cd tests/lean && lake build -- cgit v1.2.3 From e74bbd8c4b14686b2886754607036fe4f84d1d49 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:21:22 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7904509b..2ea5dc4f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -22,17 +22,13 @@ jobs: lean: # Lean isn't supported by Nix, so we need to add extra steps runs-on: [ubuntu-latest] steps: - #- run: wget -q https://raw.githubusercontent.com/leanprover-community/mathlib4/master/scripts/install_debian.sh && bash install_debian.sh ; rm -f install_debian.sh && source ~/.profile # Install curl - run: sudo apt update && sudo apt install curl - # Install Elan (https://leanprover-community.github.io/install/linux.html) - # We updated the script to make it run in non-interactive mode - #- run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh + # Install Elan (https://leanprover-community.github.io/install/linux.html) and Lean in + # non-interactive mode: - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -- -y - #- run: sudo apt-get update && sudo apt-get install make # Checkout the repo and download it to the runner - name: Checkout uses: actions/checkout@v4 # Verify - run: cd tests/lean && make - #- run: cd tests/lean && lake build -- cgit v1.2.3 From 2331b4c0d45fd47bae95e4d3380044973e4477e0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:22:25 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2ea5dc4f..32f2dab0 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -27,6 +27,7 @@ jobs: # Install Elan (https://leanprover-community.github.io/install/linux.html) and Lean in # non-interactive mode: - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -- -y + - run: source ~/.profile # Checkout the repo and download it to the runner - name: Checkout uses: actions/checkout@v4 -- cgit v1.2.3 From 57ffe2c9b46e196310f0abd6c001751fe2f2a6b9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:25:47 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 32f2dab0..82b7e724 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -27,9 +27,8 @@ jobs: # Install Elan (https://leanprover-community.github.io/install/linux.html) and Lean in # non-interactive mode: - run: curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | bash -s -- -y - - run: source ~/.profile # Checkout the repo and download it to the runner - name: Checkout uses: actions/checkout@v4 # Verify - - run: cd tests/lean && make + - run: source ~/.profile && cd tests/lean && make -- cgit v1.2.3 From d527795cb5c24892617bd5f7df75450e50069194 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 17:30:23 +0100 Subject: Update the ci.yml --- .github/workflows/ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 82b7e724..6b5aacf0 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,11 +15,10 @@ jobs: - run: nix build -L .#checks.x86_64-linux.aeneas-tests - run: nix build -L .#checks.x86_64-linux.aeneas-verify-fstar - run: nix build -L .#checks.x86_64-linux.aeneas-verify-coq - # HOL4 can be reactivated, but it is very slow - #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 + - run: nix build -L .#checks.x86_64-linux.aeneas-verify-hol4 # Lean doesn't work with Nix #- run: nix build -L .#checks.x86_64-linux.aeneas-verify-lean - lean: # Lean isn't supported by Nix, so we need to add extra steps + lean: # Lean isn't supported by Nix, so we put it in a different job runs-on: [ubuntu-latest] steps: # Install curl @@ -30,5 +29,6 @@ jobs: # Checkout the repo and download it to the runner - name: Checkout uses: actions/checkout@v4 - # Verify + # Verify - note that we need to update the environment with `source` so + # that the lake binary is in the path. - run: source ~/.profile && cd tests/lean && make -- cgit v1.2.3 From d300be95c28ff3147bb6f6a65992df5b9b571bdf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 10 Nov 2023 18:04:29 +0100 Subject: Check in nix that the regenerated files don't differ from the checked out files --- flake.nix | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/flake.nix b/flake.nix index ebe1e90d..e2b7a796 100644 --- a/flake.nix +++ b/flake.nix @@ -92,11 +92,28 @@ cp ${aeneas}/bin/aeneas_driver aeneas.exe export AENEAS_EXE=./aeneas.exe - # Run the tests + # Copy the tests + mkdir tests-copy + cp -r tests tests-copy + + # TODO: remove the test files to make sure we regenerate exactly + # the files which are checked out (we have to be careful about + # files like lakefile.lean, and the user hand-written files) + + # Run the tests - remark: we could remove the file make tests -j $NIX_BUILD_CORES + + # Check that there are no differences between the generated tests + # and the original tests + if [[ $(diff -rq tests tests-copy) ]]; then + echo "Ok: the regenerated test files are the same as the checked out files" + else + echo "Error: the regenerated test files differ from the checked out files" + exit 1 + fi ''; # Tests don't generate anything new as the generated files are - # versionned, but the installation phase still needs to prodocue + # versionned, but the installation phase still needs to produce # something, otherwise Nix will consider the build has failed. installPhase = "touch $out"; }; -- cgit v1.2.3 From b9f33bdd871a1bd7a1bd29f148dd05bd7990548b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 12 Nov 2023 19:28:56 +0100 Subject: Remove the 'r type variable from the ty type definition --- compiler/AssociatedTypes.ml | 482 ++++++++++++--------------------- compiler/Assumed.ml | 29 +- compiler/Contexts.ml | 239 +++++----------- compiler/Extract.ml | 26 +- compiler/ExtractBase.ml | 54 ++-- compiler/ExtractTypes.ml | 42 +-- compiler/FunsAnalysis.ml | 4 +- compiler/Interpreter.ml | 11 +- compiler/InterpreterBorrows.ml | 52 ++-- compiler/InterpreterBorrows.mli | 1 - compiler/InterpreterBorrowsCore.ml | 40 ++- compiler/InterpreterExpansion.ml | 38 +-- compiler/InterpreterExpressions.ml | 90 +++--- compiler/InterpreterLoopsCore.ml | 12 +- compiler/InterpreterLoopsFixedPoint.ml | 16 +- compiler/InterpreterLoopsJoinCtxs.ml | 51 ++-- compiler/InterpreterLoopsMatchCtxs.ml | 87 +++--- compiler/InterpreterPaths.ml | 33 +-- compiler/InterpreterPaths.mli | 7 +- compiler/InterpreterProjectors.ml | 35 +-- compiler/InterpreterProjectors.mli | 6 +- compiler/InterpreterStatements.ml | 118 ++++---- compiler/InterpreterUtils.ml | 83 +++--- compiler/Invariants.ml | 67 +++-- compiler/LlbcAst.ml | 9 +- compiler/LlbcAstUtils.ml | 8 +- compiler/Print.ml | 202 ++++---------- compiler/PrintPure.ml | 24 +- compiler/Pure.ml | 12 +- compiler/PureMicroPasses.ml | 10 +- compiler/PureTypeCheck.ml | 12 +- compiler/PureUtils.ml | 56 ++-- compiler/ReorderDecls.ml | 4 +- compiler/Substitute.ml | 426 +++++++++++------------------ compiler/SymbolicAst.ml | 40 +-- compiler/SymbolicToPure.ml | 219 +++++++-------- compiler/SynthesizeSymbolic.ml | 20 +- compiler/Translate.ml | 12 +- compiler/TypesAnalysis.ml | 24 +- compiler/TypesUtils.ml | 87 +++++- compiler/Values.ml | 298 ++++++-------------- compiler/ValuesUtils.ml | 30 +- 42 files changed, 1305 insertions(+), 1811 deletions(-) diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 581e218c..c76af138 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -20,141 +20,80 @@ module PA = Print.EvalCtxLlbcAst (** The local logger *) let log = L.associated_types_log -let trait_type_ref_substitute (subst : ('r, 'r1) Subst.subst) - (r : 'r C.trait_type_ref) : 'r1 C.trait_type_ref = +let trait_type_ref_substitute (subst : Subst.subst) (r : C.trait_type_ref) : + C.trait_type_ref = let { C.trait_ref; type_name } = r in let trait_ref = Subst.trait_ref_substitute subst trait_ref in { C.trait_ref; type_name } -(* TODO: how not to duplicate below? *) -module RTyOrd = struct - type t = T.rty +module TyOrd = struct + type t = T.ty - let compare = T.compare_rty - let to_string = T.show_rty - let pp_t = T.pp_rty - let show_t = T.show_rty + let compare = T.compare_ty + let to_string = T.show_ty + let pp_t = T.pp_ty + let show_t = T.show_ty end -module STyOrd = struct - type t = T.sty +module TyMap = Collections.MakeMap (TyOrd) - let compare = T.compare_sty - let to_string = T.show_sty - let pp_t = T.pp_sty - let show_t = T.show_sty -end - -module RTyMap = Collections.MakeMap (RTyOrd) -module STyMap = Collections.MakeMap (STyOrd) - -(* TODO: is it possible not to have this? *) -module type TypeWrapper = sig - type t -end - -(* TODO: don't manage to get the syntax right so using a functor *) -module MakeNormalizer - (R : TypeWrapper) - (RTyMap : Collections.Map with type key = R.t T.region T.ty) - (M : Collections.Map with type key = R.t T.region C.trait_type_ref) = -struct - let compute_norm_trait_types_from_preds - (trait_type_constraints : R.t T.region T.trait_type_constraint list) : - R.t T.region T.ty M.t = - (* Compute a union-find structure by recursively exploring the predicates and clauses *) - let norm : R.t T.region T.ty UF.elem RTyMap.t ref = ref RTyMap.empty in - let get_ref (ty : R.t T.region T.ty) : R.t T.region T.ty UF.elem = - match RTyMap.find_opt ty !norm with - | Some r -> r - | None -> - let r = UF.make ty in - norm := RTyMap.add ty r !norm; - r - in - let add_trait_type_constraint (c : R.t T.region T.trait_type_constraint) = - let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in - let trait_ty_ref = get_ref trait_ty in - let ty_ref = get_ref c.ty in - let new_repr = UF.get ty_ref in - let merged = UF.union trait_ty_ref ty_ref in - (* Not sure the set operation is necessary, but I want to control which - representative is chosen *) - UF.set merged new_repr - in - (* Explore the local predicates *) - List.iter add_trait_type_constraint trait_type_constraints; - (* TODO: explore the local clauses *) - (* Compute the norm maps *) - let rbindings = - List.map (fun (k, v) -> (k, UF.get v)) (RTyMap.bindings !norm) - in - (* Filter the keys to keep only the trait type aliases *) - let rbindings = - List.filter_map - (fun (k, v) -> - match k with - | T.TraitType (trait_ref, generics, type_name) -> - assert (generics = TypesUtils.mk_empty_generic_args); - Some ({ C.trait_ref; type_name }, v) - | _ -> None) - rbindings - in - M.of_list rbindings -end - -(** Compute the representative classes of trait associated types, for normalization *) -let compute_norm_trait_stypes_from_preds - (trait_type_constraints : T.strait_type_constraint list) : - T.sty C.STraitTypeRefMap.t = - (* Compute the normalization map for the types with regions *) - let module R = struct - type t = T.region_var_id - end in - let module M = C.STraitTypeRefMap in - let module Norm = MakeNormalizer (R) (STyMap) (M) in - Norm.compute_norm_trait_types_from_preds trait_type_constraints - -(** Compute the representative classes of trait associated types, for normalization *) let compute_norm_trait_types_from_preds - (trait_type_constraints : T.rtrait_type_constraint list) : - T.ety C.ETraitTypeRefMap.t * T.rty C.RTraitTypeRefMap.t = - (* Compute the normalization map for the types with regions *) - let module R = struct - type t = T.region_id - end in - let module M = C.RTraitTypeRefMap in - let module Norm = MakeNormalizer (R) (RTyMap) (M) in + (trait_type_constraints : T.trait_type_constraint list) : + T.ty C.TraitTypeRefMap.t = + (* Compute a union-find structure by recursively exploring the predicates and clauses *) + let norm : T.ty UF.elem TyMap.t ref = ref TyMap.empty in + let get_ref (ty : T.ty) : T.ty UF.elem = + match TyMap.find_opt ty !norm with + | Some r -> r + | None -> + let r = UF.make ty in + norm := TyMap.add ty r !norm; + r + in + let add_trait_type_constraint (c : T.trait_type_constraint) = + (* Sanity check: the type constraint can't make use of regions - Remark + that it would be enough to only visit the field [ty] of the trait type + constraint, but for safety we visit all the fields *) + assert (TU.trait_type_constraint_no_regions c); + let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in + let trait_ty_ref = get_ref trait_ty in + let ty_ref = get_ref c.ty in + let new_repr = UF.get ty_ref in + let merged = UF.union trait_ty_ref ty_ref in + (* Not sure the set operation is necessary, but I want to control which + representative is chosen *) + UF.set merged new_repr + in + (* Explore the local predicates *) + List.iter add_trait_type_constraint trait_type_constraints; + (* TODO: explore the local clauses *) + (* Compute the norm maps *) let rbindings = - Norm.compute_norm_trait_types_from_preds trait_type_constraints + List.map (fun (k, v) -> (k, UF.get v)) (TyMap.bindings !norm) in - (* Compute the normalization map for the types with erased regions *) - let ebindings = - List.map + (* Filter the keys to keep only the trait type aliases *) + let rbindings = + List.filter_map (fun (k, v) -> - ( trait_type_ref_substitute Subst.erase_regions_subst k, - Subst.erase_regions v )) - (M.bindings rbindings) - in - (C.ETraitTypeRefMap.of_list ebindings, rbindings) - -let ctx_add_norm_trait_stypes_from_preds (ctx : C.eval_ctx) - (trait_type_constraints : T.strait_type_constraint list) : C.eval_ctx = - let norm_trait_stypes = - compute_norm_trait_stypes_from_preds trait_type_constraints + match k with + | T.TraitType (trait_ref, generics, type_name) -> + assert (generics = TypesUtils.mk_empty_generic_args); + Some ({ C.trait_ref; type_name }, v) + | _ -> None) + rbindings in - { ctx with C.norm_trait_stypes } + C.TraitTypeRefMap.of_list rbindings let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) - (trait_type_constraints : T.rtrait_type_constraint list) : C.eval_ctx = - let norm_trait_etypes, norm_trait_rtypes = + (trait_type_constraints : T.trait_type_constraint list) : C.eval_ctx = + let norm_trait_types = compute_norm_trait_types_from_preds trait_type_constraints in - { ctx with C.norm_trait_etypes; norm_trait_rtypes } + { ctx with C.norm_trait_types } (** A trait instance id refers to a local clause if it only uses the variants: [Self], [Clause], [ParentClause], [ItemClause] *) -let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = +let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = match id with | T.Self | Clause _ -> true | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> @@ -165,75 +104,52 @@ let rec trait_instance_id_is_local_clause (id : 'r T.trait_instance_id) : bool = (** About the conversion functions: for now we need them (TODO: merge ety, rty, etc.), but they should be applied to types without regions. *) -type 'r norm_ctx = { - ctx : C.eval_ctx; - get_ty_repr : 'r C.trait_type_ref -> 'r T.ty option; - convert_ety : T.ety -> 'r T.ty; (* TODO: remove? *) - convert_etrait_ref : T.etrait_ref -> 'r T.trait_ref; (* TODO: remove? *) - ty_to_string : 'r T.ty -> string; - generic_params_to_string : T.generic_params -> string; - generic_args_to_string : 'r T.generic_args -> string; - trait_ref_to_string : 'r T.trait_ref -> string; - trait_instance_id_to_string : 'r T.trait_instance_id -> string; - pp_r : Format.formatter -> 'r -> unit; -} - -(** Small utility to lookup trait impls, together with a substitution. - - Remark: one reason we have those small helpers is that all functions are - parameterized by a type variable 'r. The OCaml type inferencer and type - checker are however not very good at generating precise error messages in - this context: if in the body of the function we have an overly constrained - usage of 'r (for instance, the type inferencer deduces 'r should be - [T.erased_region]), it will not be able to pinpoint the location which - introduced the constraints and we just get a type-checking error for the - whole function. The fact that we have mutually recursive functions makes it - worse (the type-checker sometimes indicates a well-typed function as not - well-typed, because it calls a not well-typed function...). - By isolating the places where such errors typically happen in small helpers - (i.e., the places where we convert between different types of regions by - performing substitutions), we make maintenance a lot easier. - *) -let ctx_lookup_trait_impl : - 'r. - 'r norm_ctx -> - T.TraitImplId.id -> - 'r T.generic_args -> - A.trait_impl * (T.region_var_id T.region, 'r) Subst.subst = - fun ctx impl_id generics -> +type norm_ctx = { ctx : C.eval_ctx } + +let ctx_get_ty_repr (ctx : norm_ctx) (x : C.trait_type_ref) : T.ty option = + C.TraitTypeRefMap.find_opt x ctx.ctx.norm_trait_types + +let ty_to_string (ctx : norm_ctx) (ty : T.ty) : string = + PA.ty_to_string ctx.ctx ty + +let trait_ref_to_string (ctx : norm_ctx) (x : T.trait_ref) : string = + PA.trait_ref_to_string ctx.ctx x + +let trait_instance_id_to_string (ctx : norm_ctx) (x : T.trait_instance_id) : + string = + PA.trait_instance_id_to_string ctx.ctx x + +let generic_args_to_string (ctx : norm_ctx) (x : T.generic_args) : string = + PA.generic_args_to_string ctx.ctx x + +let generic_params_to_string (ctx : norm_ctx) (x : T.generic_params) : string = + "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx.ctx x)) ^ ">" + +(** Small utility to lookup trait impls, together with a substitution. *) +let ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) + (generics : T.generic_args) : A.trait_impl * Subst.subst = (* Lookup the implementation *) let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in (* The substitution *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = - Subst.make_subst_from_generics_no_regions trait_impl.generics generics - tr_self + Subst.make_subst_from_generics trait_impl.generics generics tr_self in (* Return *) (trait_impl, subst) -let ctx_lookup_trait_impl_ty : - 'r. - 'r norm_ctx -> T.TraitImplId.id -> 'r T.generic_args -> string -> 'r T.ty - = - fun ctx impl_id generics type_name -> +let ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) + (generics : T.generic_args) (type_name : string) : T.ty = (* Lookup the implementation *) let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the type *) let ty = snd (List.assoc type_name trait_impl.types) in - (* Annoying: convert etype to an stype - TODO: how to avoid that? *) - let ty : T.sty = TypesUtils.ety_no_regions_to_gr_ty ty in (* Substitute *) Subst.ty_substitute subst ty -let ctx_lookup_trait_impl_parent_clause : - 'r. - 'r norm_ctx -> - T.TraitImplId.id -> - 'r T.generic_args -> - T.TraitClauseId.id -> - 'r T.trait_ref = - fun ctx impl_id generics clause_id -> +let ctx_lookup_trait_impl_parent_clause (ctx : norm_ctx) + (impl_id : T.TraitImplId.id) (generics : T.generic_args) + (clause_id : T.TraitClauseId.id) : T.trait_ref = (* Lookup the implementation *) let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the clause *) @@ -243,15 +159,9 @@ let ctx_lookup_trait_impl_parent_clause : (* Substitute *) Subst.trait_ref_substitute subst clause -let ctx_lookup_trait_impl_item_clause : - 'r. - 'r norm_ctx -> - T.TraitImplId.id -> - 'r T.generic_args -> - string -> - T.TraitClauseId.id -> - 'r T.trait_ref = - fun ctx impl_id generics item_name clause_id -> +let ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) + (impl_id : T.TraitImplId.id) (generics : T.generic_args) + (item_name : string) (clause_id : T.TraitClauseId.id) : T.trait_ref = (* Lookup the implementation *) let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the item then its clause *) @@ -259,10 +169,6 @@ let ctx_lookup_trait_impl_item_clause : let clause = T.TraitClauseId.nth (fst item) clause_id in (* Sanity check: the clause necessarily refers to an impl *) let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in - (* Annoying: convert etype to an stype - TODO: how to avoid that? *) - let clause : T.strait_ref = - TypesUtils.etrait_ref_no_regions_to_gr_trait_ref clause - in (* Substitute *) Subst.trait_ref_substitute subst clause @@ -272,12 +178,11 @@ let ctx_lookup_trait_impl_item_clause : See the comments for {!ctx_normalize_trait_instance_id}. *) -let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = - fun ctx ty -> - log#ldebug (lazy ("ctx_normalize_ty: " ^ ctx.ty_to_string ty)); +let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = + log#ldebug (lazy ("ctx_normalize_ty: " ^ ty_to_string ctx ty)); match ty with - | T.Adt (id, generics) -> Adt (id, ctx_normalize_generic_args ctx generics) - | TypeVar _ | Literal _ | Never -> ty + | T.TAdt (id, generics) -> TAdt (id, ctx_normalize_generic_args ctx generics) + | TypeVar _ | TLiteral _ | Never -> ty | Ref (r, ty, rkind) -> let ty = ctx_normalize_ty ctx ty in T.Ref (r, ty, rkind) @@ -291,19 +196,18 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = | TraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy - ("ctx_normalize_ty:\n- trait type: " ^ ctx.ty_to_string ty + ("ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r trait_ref + ^ trait_ref_to_string ctx trait_ref + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref ^ "\n- generics:\n" - ^ ctx.generic_args_to_string generics)); + ^ generic_args_to_string ctx generics)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = ctx_normalize_trait_ref ctx trait_ref in let generics = ctx_normalize_generic_args ctx generics in (* For now, we don't support higher order types *) assert (generics = TypesUtils.mk_empty_generic_args); - let ty : 'r T.ty = + let ty : T.ty = match trait_ref.trait_id with | T.TraitRef { T.trait_id = T.TraitImpl impl_id; generics = ref_generics; _ } -> @@ -311,7 +215,7 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = log#ldebug (lazy ("ctx_normalize_ty: trait type: trait ref: " - ^ ctx.ty_to_string ty)); + ^ ty_to_string ctx ty)); (* Lookup the type *) let ty = ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name @@ -322,10 +226,9 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = log#ldebug (lazy ("ctx_normalize_ty (trait impl):\n- trait type: " - ^ ctx.ty_to_string ty ^ "\n- trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r trait_ref)); + ^ ty_to_string ctx ty ^ "\n- trait_ref: " + ^ trait_ref_to_string ctx trait_ref + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); (* This happens. This doesn't come from the substitutions performed by Aeneas (the [TraitImpl] would be wrapped in a [TraitRef] but from non-normalized traits translated from @@ -342,17 +245,16 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = log#ldebug (lazy ("ctx_normalize_ty: trait type: not a trait ref: " - ^ ctx.ty_to_string ty ^ "\n- trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r trait_ref)); + ^ ty_to_string ctx ty ^ "\n- trait_ref: " + ^ trait_ref_to_string ctx trait_ref + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); T.TraitType (trait_ref, generics, type_name) in - let tr : 'r C.trait_type_ref = { C.trait_ref; type_name } in + let tr : C.trait_type_ref = { C.trait_ref; type_name } in (* Lookup the representative, if there is *) - match ctx.get_ty_repr tr with None -> ty | Some ty -> ty) + match ctx_get_ty_repr ctx tr with None -> ty | Some ty -> ty) (** This returns the normalized trait instance id together with an optional reference to a trait **implementation** (the `trait_ref` we return has @@ -398,12 +300,8 @@ let rec ctx_normalize_ty : 'r. 'r norm_ctx -> 'r T.ty -> 'r T.ty = In this case we can lookup the trait implementation and recursively project over it. *) -and ctx_normalize_trait_instance_id : - 'r. - 'r norm_ctx -> - 'r T.trait_instance_id -> - 'r T.trait_instance_id * 'r T.trait_ref option = - fun ctx id -> +and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) + : T.trait_instance_id * T.trait_ref option = match id with | Self -> (id, None) | TraitImpl _ -> @@ -481,7 +379,7 @@ and ctx_normalize_trait_instance_id : (* Normalize the generics *) let generics = ctx_normalize_generic_args ctx generics in let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in - let trait_ref : 'r T.trait_ref = + let trait_ref : T.trait_ref = { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } in (TraitRef trait_ref, Some trait_ref) @@ -500,21 +398,20 @@ and ctx_normalize_trait_instance_id : (* This is actually an error case *) (id, None) -and ctx_normalize_generic_args (ctx : 'r norm_ctx) - (generics : 'r T.generic_args) : 'r T.generic_args = +and ctx_normalize_generic_args (ctx : norm_ctx) (generics : T.generic_args) : + T.generic_args = let { T.regions; types; const_generics; trait_refs } = generics in let types = List.map (ctx_normalize_ty ctx) types in let trait_refs = List.map (ctx_normalize_trait_ref ctx) trait_refs in { T.regions; types; const_generics; trait_refs } -and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : - 'r T.trait_ref = +and ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : + T.trait_ref = log#ldebug (lazy ("ctx_normalize_trait_ref: " - ^ ctx.trait_ref_to_string trait_ref - ^ "\n- raw trait ref:\n" - ^ T.show_trait_ref ctx.pp_r trait_ref)); + ^ trait_ref_to_string ctx trait_ref + ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); let { T.trait_id; generics; trait_decl_ref } = trait_ref in (* Check if the id is an impl, otherwise normalize it *) let trait_id, norm_trait_ref = ctx_normalize_trait_instance_id ctx trait_id in @@ -523,7 +420,7 @@ and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : log#ldebug (lazy ("ctx_normalize_trait_ref: no norm: " - ^ ctx.trait_instance_id_to_string trait_id)); + ^ trait_instance_id_to_string ctx trait_id)); let generics = ctx_normalize_generic_args ctx generics in let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in { T.trait_id; generics; trait_decl_ref } @@ -531,151 +428,108 @@ and ctx_normalize_trait_ref (ctx : 'r norm_ctx) (trait_ref : 'r T.trait_ref) : log#ldebug (lazy ("ctx_normalize_trait_ref: normalized to: " - ^ ctx.trait_ref_to_string trait_ref)); + ^ trait_ref_to_string ctx trait_ref)); assert (generics = TypesUtils.mk_empty_generic_args); trait_ref (* Not sure this one is really necessary *) -and ctx_normalize_trait_decl_ref (ctx : 'r norm_ctx) - (trait_decl_ref : 'r T.trait_decl_ref) : 'r T.trait_decl_ref = +and ctx_normalize_trait_decl_ref (ctx : norm_ctx) + (trait_decl_ref : T.trait_decl_ref) : T.trait_decl_ref = let { T.trait_decl_id; decl_generics } = trait_decl_ref in let decl_generics = ctx_normalize_generic_args ctx decl_generics in { T.trait_decl_id; decl_generics } -let ctx_normalize_trait_type_constraint (ctx : 'r norm_ctx) - (ttc : 'r T.trait_type_constraint) : 'r T.trait_type_constraint = +let ctx_normalize_trait_type_constraint (ctx : norm_ctx) + (ttc : T.trait_type_constraint) : T.trait_type_constraint = let { T.trait_ref; generics; type_name; ty } = ttc in let trait_ref = ctx_normalize_trait_ref ctx trait_ref in let generics = ctx_normalize_generic_args ctx generics in let ty = ctx_normalize_ty ctx ty in { T.trait_ref; generics; type_name; ty } -let generic_params_to_string ctx x = - "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx x)) ^ ">" - -let mk_snorm_ctx (ctx : C.eval_ctx) : T.RegionVarId.id T.region norm_ctx = - let get_ty_repr x = C.STraitTypeRefMap.find_opt x ctx.norm_trait_stypes in - { - ctx; - get_ty_repr; - convert_ety = TypesUtils.ety_no_regions_to_sty; - convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; - ty_to_string = PA.sty_to_string ctx; - generic_params_to_string = generic_params_to_string ctx; - generic_args_to_string = PA.sgeneric_args_to_string ctx; - trait_ref_to_string = PA.strait_ref_to_string ctx; - trait_instance_id_to_string = PA.strait_instance_id_to_string ctx; - pp_r = T.pp_region T.pp_region_var_id; - } - -let mk_rnorm_ctx (ctx : C.eval_ctx) : T.RegionId.id T.region norm_ctx = - let get_ty_repr x = C.RTraitTypeRefMap.find_opt x ctx.norm_trait_rtypes in - { - ctx; - get_ty_repr; - convert_ety = TypesUtils.ety_no_regions_to_rty; - convert_etrait_ref = TypesUtils.etrait_ref_no_regions_to_gr_trait_ref; - ty_to_string = PA.rty_to_string ctx; - generic_params_to_string = generic_params_to_string ctx; - generic_args_to_string = PA.rgeneric_args_to_string ctx; - trait_ref_to_string = PA.rtrait_ref_to_string ctx; - trait_instance_id_to_string = PA.rtrait_instance_id_to_string ctx; - pp_r = T.pp_region T.pp_region_id; - } - -let mk_enorm_ctx (ctx : C.eval_ctx) : T.erased_region norm_ctx = - let get_ty_repr x = C.ETraitTypeRefMap.find_opt x ctx.norm_trait_etypes in - { - ctx; - get_ty_repr; - convert_ety = (fun x -> x); - convert_etrait_ref = (fun x -> x); - ty_to_string = PA.ety_to_string ctx; - generic_params_to_string = generic_params_to_string ctx; - generic_args_to_string = PA.egeneric_args_to_string ctx; - trait_ref_to_string = PA.etrait_ref_to_string ctx; - trait_instance_id_to_string = PA.etrait_instance_id_to_string ctx; - pp_r = T.pp_erased_region; - } - -let ctx_normalize_sty (ctx : C.eval_ctx) (ty : T.sty) : T.sty = - ctx_normalize_ty (mk_snorm_ctx ctx) ty - -let ctx_normalize_rty (ctx : C.eval_ctx) (ty : T.rty) : T.rty = - ctx_normalize_ty (mk_rnorm_ctx ctx) ty - -let ctx_normalize_ety (ctx : C.eval_ctx) (ty : T.ety) : T.ety = - ctx_normalize_ty (mk_enorm_ctx ctx) ty - -let ctx_normalize_rtrait_type_constraint (ctx : C.eval_ctx) - (ttc : T.rtrait_type_constraint) : T.rtrait_type_constraint = - ctx_normalize_trait_type_constraint (mk_rnorm_ctx ctx) ttc - -(** Same as [type_decl_get_instantiated_variants_fields_rtypes] but normalizes the types *) +let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = { ctx } + +let ctx_normalize_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = + ctx_normalize_ty (mk_norm_ctx ctx) ty + +(** Normalize a type and erase the regions at the same time *) +let ctx_normalize_erase_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = + let ty = ctx_normalize_ty ctx ty in + Subst.erase_regions ty + +let ctx_normalize_trait_type_constraint (ctx : C.eval_ctx) + (ttc : T.trait_type_constraint) : T.trait_type_constraint = + ctx_normalize_trait_type_constraint (mk_norm_ctx ctx) ttc + +(** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) - (def : T.type_decl) (generics : T.rgeneric_args) : - (T.VariantId.id option * T.rty list) list = + (def : T.type_decl) (generics : T.generic_args) : + (T.VariantId.id option * T.ty list) list = let res = - Subst.type_decl_get_instantiated_variants_fields_rtypes def generics + Subst.type_decl_get_instantiated_variants_fields_types def generics in List.map (fun (variant_id, types) -> - (variant_id, List.map (ctx_normalize_rty ctx) types)) + (variant_id, List.map (ctx_normalize_ty ctx) types)) res -(** Same as [type_decl_get_instantiated_field_rtypes] but normalizes the types *) +(** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) let type_decl_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : - T.rty list = + (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : + T.ty list = let types = - Subst.type_decl_get_instantiated_field_rtypes def opt_variant_id generics + Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - List.map (ctx_normalize_rty ctx) types + List.map (ctx_normalize_ty ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : - T.rty list = + (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list + = let types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id generics + Subst.ctx_adt_value_get_instantiated_field_types ctx adt id generics in - List.map (ctx_normalize_rty ctx) types + List.map (ctx_normalize_ty ctx) types -(** Same as [ctx_adt_value_get_instantiated_field_etypes] but normalizes the types *) +(** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types + and erases the regions. *) let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : - T.ety list = + (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : + T.ty list = let types = - Subst.type_decl_get_instantiated_field_etypes def opt_variant_id generics + Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in - List.map (ctx_normalize_ety ctx) types + let types = List.map (ctx_normalize_ty ctx) types in + List.map Subst.erase_regions types -(** Same as [ctx_adt_get_instantiated_field_etypes] but normalizes the types *) +(** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and + erases the regions. *) let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.egeneric_args) : T.ety list = + (generics : T.generic_args) : T.ty list = let types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics in - List.map (ctx_normalize_ety ctx) types + let types = List.map (ctx_normalize_ty ctx) types in + List.map Subst.erase_regions types (** Same as [substitute_signature] but normalizes the types *) let ctx_subst_norm_signature (ctx : C.eval_ctx) (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionVarId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.rty) + (r_subst : T.RegionId.id -> T.RegionId.id) + (ty_subst : T.TypeVarId.id -> T.ty) (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.rtrait_instance_id) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) + (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = let sg = Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self sg in let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in - let inputs = List.map (ctx_normalize_rty ctx) inputs in - let output = ctx_normalize_rty ctx output in + let inputs = List.map (ctx_normalize_ty ctx) inputs in + let output = ctx_normalize_ty ctx output in let trait_type_constraints = - List.map (ctx_normalize_rtrait_type_constraint ctx) trait_type_constraints + List.map (ctx_normalize_trait_type_constraint ctx) trait_type_constraints in { regions_hierarchy; inputs; output; trait_type_constraints } diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 79f6b0d4..d8f19173 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -37,11 +37,11 @@ module A = LlbcAst module Sig = struct (** A few utilities *) - let rvar_id_0 = T.RegionVarId.of_int 0 - let rvar_0 : T.RegionVarId.id T.region = T.Var rvar_id_0 + let rvar_id_0 = T.RegionId.of_int 0 + let rvar_0 : T.region = T.RVar rvar_id_0 let rg_id_0 = T.RegionGroupId.of_int 0 let tvar_id_0 = T.TypeVarId.of_int 0 - let tvar_0 : T.sty = T.TypeVar tvar_id_0 + let tvar_0 : T.ty = T.TypeVar tvar_id_0 let cgvar_id_0 = T.ConstGenericVarId.of_int 0 let cgvar_0 : T.const_generic = T.ConstGenericVar cgvar_id_0 @@ -49,36 +49,35 @@ module Sig = struct let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } (** Region group: [{ parent={}; regions:{'a of id 0} }] *) - let region_group_0 : T.region_var_group = + let region_group_0 : T.region_group = { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } (** Type parameter [T] of id 0 *) let type_param_0 : T.type_var = { T.index = tvar_id_0; name = "T" } - let usize_ty : T.sty = T.Literal (Integer Usize) + let usize_ty : T.ty = T.TLiteral (TInteger Usize) (** Const generic parameter [const N : usize] of id 0 *) let cg_param_0 : T.const_generic_var = - { T.index = cgvar_id_0; name = "N"; ty = Integer Usize } + { T.index = cgvar_id_0; name = "N"; ty = TInteger Usize } let empty_const_generic_params : T.const_generic_var list = [] - let mk_generic_args regions types const_generics : T.sgeneric_args = + let mk_generic_args regions types const_generics : T.generic_args = { regions; types; const_generics; trait_refs = [] } let mk_generic_params regions types const_generics : T.generic_params = { regions; types; const_generics; trait_clauses = [] } - let mk_ref_ty (r : T.RegionVarId.id T.region) (ty : T.sty) (is_mut : bool) : - T.sty = + let mk_ref_ty (r : T.region) (ty : T.ty) (is_mut : bool) : T.ty = let ref_kind = if is_mut then T.Mut else T.Shared in mk_ref_ty r ty ref_kind - let mk_array_ty (ty : T.sty) (cg : T.const_generic) : T.sty = - Adt (Assumed Array, mk_generic_args [] [ ty ] [ cg ]) + let mk_array_ty (ty : T.ty) (cg : T.const_generic) : T.ty = + TAdt (TAssumed TArray, mk_generic_args [] [ ty ] [ cg ]) - let mk_slice_ty (ty : T.sty) : T.sty = - Adt (Assumed Slice, mk_generic_args [] [ ty ] []) + let mk_slice_ty (ty : T.ty) : T.ty = + TAdt (TAssumed TSlice, mk_generic_args [] [ ty ] []) let mk_sig generics regions_hierarchy inputs output : A.fun_sig = let preds : T.predicates = @@ -125,8 +124,8 @@ module Sig = struct borrow. *) let mk_array_slice_borrow_sig (cgs : T.const_generic_var list) - (input_ty : T.TypeVarId.id -> T.sty) (index_ty : T.sty option) - (output_ty : T.TypeVarId.id -> T.sty) (is_mut : bool) : A.fun_sig = + (input_ty : T.TypeVarId.id -> T.ty) (index_ty : T.ty option) + (output_ty : T.TypeVarId.id -> T.ty) (is_mut : bool) : A.fun_sig = let generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) in diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index dac64a9a..9a20a6cc 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -112,16 +112,16 @@ let reset_global_counters () = fun_call_id_counter := FunCallId.generator_zero; dummy_var_id_counter := DummyVarId.generator_zero -(** Ancestor for {!var_binder} iter visitor *) -class ['self] iter_var_binder_base = +(** Ancestor for {!env} iter visitor *) +class ['self] iter_env_base = object (_self : 'self) inherit [_] iter_abs method visit_var_id : 'env -> var_id -> unit = fun _ _ -> () method visit_dummy_var_id : 'env -> dummy_var_id -> unit = fun _ _ -> () end -(** Ancestor for {!var_binder} map visitor *) -class ['self] map_var_binder_base = +(** Ancestor for {!env} map visitor *) +class ['self] map_env_base = object (_self : 'self) inherit [_] map_abs method visit_var_id : 'env -> var_id -> var_id = fun _ x -> x @@ -135,97 +135,29 @@ type var_binder = { index : var_id; (** Unique variable identifier *) name : string option; (** Possible name *) } -[@@deriving - show, - visitors - { - name = "iter_var_binder"; - variety = "iter"; - ancestors = [ "iter_var_binder_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_var_binder"; - variety = "map"; - ancestors = [ "map_var_binder_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] (** A binder, for a "real" variable or a dummy variable *) -type binder = VarBinder of var_binder | DummyBinder of dummy_var_id -[@@deriving - show, - visitors - { - name = "iter_binder"; - variety = "iter"; - ancestors = [ "iter_var_binder" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_binder"; - variety = "map"; - ancestors = [ "map_var_binder" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** Ancestor for {!env_elem} iter visitor *) -class ['self] iter_env_elem_base = - object (_self : 'self) - inherit [_] iter_binder - end - -(** Ancestor for {!env_elem} map visitor *) -class ['self] map_env_elem_base = - object (_self : 'self) - inherit [_] map_binder - end +and binder = BVar of var_binder | BDummy of dummy_var_id (** Environment value: mapping from variable to value, abstraction (only used in symbolic mode) or stack frame delimiter. - - TODO: rename Var (-> Binding?) *) -type env_elem = - | Var of binder * typed_value +and env_elem = + | EBinding of binder * typed_value (** Variable binding - the binder is None if the variable is a dummy variable (we use dummy variables to store temporaries while doing bookkeeping such as ending borrows for instance). *) - | Abs of abs - | Frame -[@@deriving - show, - visitors - { - name = "iter_env_elem"; - variety = "iter"; - ancestors = [ "iter_env_elem_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_env_elem"; - variety = "map"; - ancestors = [ "map_env_elem_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] + | EAbs of abs + | EFrame -type env = env_elem list +and env = env_elem list [@@deriving show, visitors { name = "iter_env"; variety = "iter"; - ancestors = [ "iter_env_elem" ]; + ancestors = [ "iter_env_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); concrete = true; }, @@ -233,7 +165,7 @@ type env = env_elem list { name = "map_env"; variety = "map"; - ancestors = [ "map_env_elem" ]; + ancestors = [ "map_env_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); concrete = true; }] @@ -280,48 +212,20 @@ type decls_ctx = { [@@deriving show] (** A reference to a trait associated type *) -type 'r trait_type_ref = { trait_ref : 'r trait_ref; type_name : string } -[@@deriving show, ord] - -type etrait_type_ref = erased_region trait_type_ref [@@deriving show, ord] - -type rtrait_type_ref = Types.RegionId.id Types.region trait_type_ref -[@@deriving show, ord] - -type strait_type_ref = Types.RegionVarId.id Types.region trait_type_ref +type trait_type_ref = { trait_ref : trait_ref; type_name : string } [@@deriving show, ord] (* TODO: correctly use the functors so as not to have a duplication below *) -module ETraitTypeRefOrd = struct - type t = etrait_type_ref +module TraitTypeRefOrd = struct + type t = trait_type_ref - let compare = compare_etrait_type_ref - let to_string = show_etrait_type_ref - let pp_t = pp_etrait_type_ref - let show_t = show_etrait_type_ref + let compare = compare_trait_type_ref + let to_string = show_trait_type_ref + let pp_t = pp_trait_type_ref + let show_t = show_trait_type_ref end -module RTraitTypeRefOrd = struct - type t = rtrait_type_ref - - let compare = compare_rtrait_type_ref - let to_string = show_rtrait_type_ref - let pp_t = pp_rtrait_type_ref - let show_t = show_rtrait_type_ref -end - -module STraitTypeRefOrd = struct - type t = strait_type_ref - - let compare = compare_strait_type_ref - let to_string = show_strait_type_ref - let pp_t = pp_strait_type_ref - let show_t = show_strait_type_ref -end - -module ETraitTypeRefMap = Collections.MakeMap (ETraitTypeRefOrd) -module RTraitTypeRefMap = Collections.MakeMap (RTraitTypeRefOrd) -module STraitTypeRefMap = Collections.MakeMap (STraitTypeRefOrd) +module TraitTypeRefMap = Collections.MakeMap (TraitTypeRefOrd) (** Evaluation context *) type eval_ctx = { @@ -337,25 +241,10 @@ type eval_ctx = { (** The map from const generic vars to their values. Those values can be symbolic values or concrete values (in the latter case: if we run in interpreter mode) *) - norm_trait_etypes : ety ETraitTypeRefMap.t; + norm_trait_types : ty TraitTypeRefMap.t; (** The normalized trait types (a map from trait types to their representatives). - Note that this doesn't support account higher-order types. *) - norm_trait_rtypes : rty RTraitTypeRefMap.t; - (** We need this because we manipulate two kinds of types. - Note that we actually forbid regions from appearing both in the trait - references and in the constraints given to the associated types, - meaning that we don't have to worry about mismatches due to changes - in region ids. - - TODO: how not to duplicate? - *) - norm_trait_stypes : sty STraitTypeRefMap.t; - (** We sometimes need to normalize types in non-instantiated signatures. - - Note that we either need to use the etypes/rtypes maps, or the stypes map. - This means that we either compute the maps for etypes and rtypes, or compute - the one for stypes (we don't always compute and carry all the maps). - *) + Note that this doesn't take into account higher-order type constraints + (of the shape `for<'a> ...`). *) env : env; ended_regions : RegionId.Set.t; } @@ -389,10 +278,10 @@ let env_lookup_var (env : env) (vid : VarId.id) : var_binder * typed_value = match env with | [] -> raise (Invalid_argument ("Variable not found: " ^ VarId.to_string vid)) - | Var (VarBinder var, v) :: env' -> + | EBinding (BVar var, v) :: env' -> if var.index = vid then (var, v) else lookup env' - | (Var (DummyBinder _, _) | Abs _) :: env' -> lookup env' - | Frame :: _ -> raise (Failure "End of frame") + | (EBinding (BDummy _, _) | EAbs _) :: env' -> lookup env' + | EFrame :: _ -> raise (Failure "End of frame") in lookup env @@ -440,11 +329,11 @@ let env_update_var_value (env : env) (vid : VarId.id) (nv : typed_value) : env = let rec update env = match env with | [] -> raise (Failure "Unexpected") - | Var ((VarBinder b as var), v) :: env' -> - if b.index = vid then Var (var, nv) :: env' - else Var (var, v) :: update env' - | ((Var (DummyBinder _, _) | Abs _) as ee) :: env' -> ee :: update env' - | Frame :: _ -> raise (Failure "End of frame") + | EBinding ((BVar b as var), v) :: env' -> + if b.index = vid then EBinding (var, nv) :: env' + else EBinding (var, v) :: update env' + | ((EBinding (BDummy _, _) | EAbs _) as ee) :: env' -> ee :: update env' + | EFrame :: _ -> raise (Failure "End of frame") in update env @@ -466,9 +355,9 @@ let ctx_update_var_value (ctx : eval_ctx) (vid : VarId.id) (nv : typed_value) : is important). *) let ctx_push_var (ctx : eval_ctx) (var : var) (v : typed_value) : eval_ctx = - assert (var.var_ty = v.ty); + assert (TypesUtils.ty_is_ety var.var_ty && var.var_ty = v.ty); let bv = var_to_binder var in - { ctx with env = Var (VarBinder bv, v) :: ctx.env } + { ctx with env = EBinding (BVar bv, v) :: ctx.env } (** Push a list of variables. @@ -488,11 +377,12 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx vars))); assert ( List.for_all - (fun (var, (value : typed_value)) -> var.var_ty = value.ty) + (fun (var, (value : typed_value)) -> + TypesUtils.ty_is_ety var.var_ty && var.var_ty = value.ty) vars); let vars = List.map - (fun (var, value) -> Var (VarBinder (var_to_binder var), value)) + (fun (var, value) -> EBinding (BVar (var_to_binder var), value)) vars in let vars = List.rev vars in @@ -501,7 +391,7 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx (** Push a dummy variable in the context's environment. *) let ctx_push_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) (v : typed_value) : eval_ctx = - { ctx with env = Var (DummyBinder vid, v) :: ctx.env } + { ctx with env = EBinding (BDummy vid, v) :: ctx.env } (** Remove a dummy variable from a context's environment. *) let ctx_remove_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : @@ -509,7 +399,7 @@ let ctx_remove_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : let rec remove_var (env : env) : env * typed_value = match env with | [] -> raise (Failure "Could not lookup a dummy variable") - | Var (DummyBinder vid', v) :: env when vid' = vid -> (env, v) + | EBinding (BDummy vid', v) :: env when vid' = vid -> (env, v) | ee :: env -> let env, v = remove_var env in (ee :: env, v) @@ -522,27 +412,36 @@ let ctx_lookup_dummy_var (ctx : eval_ctx) (vid : DummyVarId.id) : typed_value = let rec lookup_var (env : env) : typed_value = match env with | [] -> raise (Failure "Could not lookup a dummy variable") - | Var (DummyBinder vid', v) :: _env when vid' = vid -> v + | EBinding (BDummy vid', v) :: _env when vid' = vid -> v | _ :: env -> lookup_var env in lookup_var ctx.env +let erase_regions (ty : ty) : ty = + let v = + object + inherit [_] map_ty + method! visit_region _ _ = RErased + end + in + v#visit_ty () ty + (** Push an uninitialized variable (which thus maps to {!constructor:Values.value.Bottom}) *) let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = - ctx_push_var ctx var (mk_bottom var.var_ty) + ctx_push_var ctx var (mk_bottom (erase_regions var.var_ty)) (** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.Bottom}) *) let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = - let vars = List.map (fun v -> (v, mk_bottom v.var_ty)) vars in + let vars = List.map (fun v -> (v, mk_bottom (erase_regions v.var_ty))) vars in ctx_push_vars ctx vars let env_find_abs (env : env) (pred : V.abs -> bool) : V.abs option = let rec lookup env = match env with | [] -> None - | Var (_, _) :: env' -> lookup env' - | Abs abs :: env' -> if pred abs then Some abs else lookup env' - | Frame :: env' -> lookup env' + | EBinding (_, _) :: env' -> lookup env' + | EAbs abs :: env' -> if pred abs then Some abs else lookup env' + | EFrame :: env' -> lookup env' in lookup env @@ -558,17 +457,17 @@ let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : let rec remove (env : env) : env * V.abs option = match env with | [] -> raise (Failure "Unreachable") - | Frame :: _ -> (env, None) - | Var (bv, v) :: env -> + | EFrame :: _ -> (env, None) + | EBinding (bv, v) :: env -> let env, abs_opt = remove env in - (Var (bv, v) :: env, abs_opt) - | Abs abs :: env -> + (EBinding (bv, v) :: env, abs_opt) + | EAbs abs :: env -> if abs.abs_id = abs_id then (env, Some abs) else let env, abs_opt = remove env in (* Update the parents set *) let parents = V.AbstractionId.Set.remove abs_id abs.parents in - (Abs { abs with V.parents } :: env, abs_opt) + (EAbs { abs with V.parents } :: env, abs_opt) in remove env @@ -584,12 +483,12 @@ let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : let rec update (env : env) : env * V.abs option = match env with | [] -> raise (Failure "Unreachable") - | Frame :: _ -> (* We're done *) (env, None) - | Var (bv, v) :: env -> + | EFrame :: _ -> (* We're done *) (env, None) + | EBinding (bv, v) :: env -> let env, opt_abs = update env in - (Var (bv, v) :: env, opt_abs) - | Abs abs :: env -> - if abs.abs_id = abs_id then (Abs nabs :: env, Some abs) + (EBinding (bv, v) :: env, opt_abs) + | EAbs abs :: env -> + if abs.abs_id = abs_id then (EAbs nabs :: env, Some abs) else let env, opt_abs = update env in (* Update the parents set *) @@ -600,7 +499,7 @@ let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : V.AbstractionId.Set.add nabs.abs_id parents else parents in - (Abs { abs with V.parents } :: env, opt_abs) + (EAbs { abs with V.parents } :: env, opt_abs) in update env @@ -641,7 +540,7 @@ class ['self] iter_frame = fun acc env -> match env with | [] -> () - | Frame :: _ -> (* We stop here *) () + | EFrame :: _ -> (* We stop here *) () | em :: env -> self#visit_env_elem acc em; self#visit_env acc env @@ -656,7 +555,7 @@ class ['self] map_frame_concrete = fun acc env -> match env with | [] -> [] - | Frame :: env -> (* We stop here *) Frame :: env + | EFrame :: env -> (* We stop here *) EFrame :: env | em :: env -> let em = self#visit_env_elem acc em in let env = self#visit_env acc env in @@ -686,17 +585,17 @@ class ['self] map_eval_ctx = let env_iter_abs (f : V.abs -> unit) (env : env) : unit = List.iter (fun (ee : env_elem) -> - match ee with Var _ | Frame -> () | Abs abs -> f abs) + match ee with EBinding _ | EFrame -> () | EAbs abs -> f abs) env let env_map_abs (f : V.abs -> V.abs) (env : env) : env = List.map (fun (ee : env_elem) -> - match ee with Var _ | Frame -> ee | Abs abs -> Abs (f abs)) + match ee with EBinding _ | EFrame -> ee | EAbs abs -> EAbs (f abs)) env let env_filter_abs (f : V.abs -> bool) (env : env) : env = List.filter (fun (ee : env_elem) -> - match ee with Var _ | Frame -> true | Abs abs -> f abs) + match ee with EBinding _ | EFrame -> true | EAbs abs -> f abs) env diff --git a/compiler/Extract.ml b/compiler/Extract.ml index d04f5c1d..24999c7d 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -51,7 +51,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (fun ctx (f : fun_decl) -> let open ExtractBuiltin in let fun_id = - (Pure.FunId (Regular f.def_id), f.loop_id, f.back_id) + (Pure.FunId (FRegular f.def_id), f.loop_id, f.back_id) in let fun_info = List.find_opt @@ -124,7 +124,7 @@ let extract_adt_g_value (inside : bool) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : extraction_ctx = match ty with - | Adt (Tuple, generics) -> + | TAdt (Tuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) assert (List.length generics.types = List.length field_values); @@ -146,7 +146,7 @@ let extract_adt_g_value in F.pp_print_string fmt ")"; ctx) - | Adt (adt_id, _) -> + | TAdt (adt_id, _) -> (* "Regular" ADT *) (* If we are generating a pattern for a let-binding and we target Lean, @@ -178,7 +178,7 @@ let extract_adt_g_value | Some vid -> ( (* In the case of Lean, we might have to add the type name as a prefix *) match (!backend, adt_id) with - | Lean, Assumed _ -> + | Lean, TAssumed _ -> ctx_get_type adt_id ctx ^ "." ^ ctx_get_variant adt_id vid ctx | _ -> ctx_get_variant adt_id vid ctx) | None -> ctx_get_struct adt_id ctx @@ -441,7 +441,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) (* Provided method: we see it as a regular function call, and use the function name *) let fun_id = - FromLlbc (FunId (Regular method_id.id), lp_id, rg_id) + FromLlbc (FunId (FRegular method_id.id), lp_id, rg_id) in let fun_name = ctx_get_function fun_id ctx in F.pp_print_string fmt fun_name; @@ -467,7 +467,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) *) let types = match fun_id with - | FromLlbc (FunId (Regular id), _, _) -> + | FromLlbc (FunId (FRegular id), _, _) -> fun_builtin_filter_types id generics.types ctx | _ -> Result.Ok generics.types in @@ -506,7 +506,7 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) and extract_adt_cons (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (adt_cons : adt_cons_id) (generics : generic_args) (args : texpression list) : unit = - let e_ty = Adt (adt_cons.adt_id, generics) in + let e_ty = TAdt (adt_cons.adt_id, generics) in let is_single_pat = false in let _ = extract_adt_g_value @@ -966,7 +966,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) if need_paren then F.pp_print_string fmt ")"; print_bracket false orb; F.pp_close_box fmt () - | Assumed Array -> + | TAssumed Array -> (* Open the boxes *) F.pp_open_hvbox fmt ctx.indent_incr; let need_paren = inside in @@ -974,7 +974,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) - let cs = ctx_get_struct (Assumed Array) ctx in + let cs = ctx_get_struct (TAssumed Array) ctx in F.pp_print_string fmt cs; (* Print the parameters *) let _, generics = ty_as_adt e_ty in @@ -1286,7 +1286,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) (def : fun_decl) : unit = let { keep_fwd; num_backs } = PureUtils.RegularFunIdMap.find - (Pure.FunId (Regular def.def_id), def.loop_id, def.back_id) + (Pure.FunId (FRegular def.def_id), def.loop_id, def.back_id) ctx.fun_name_info in let comment_pre = "[" ^ Print.fun_name_to_string def.basename ^ "]: " in @@ -1772,7 +1772,7 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) let decl_name = ctx_get_global global.def_id ctx in let body_name = ctx_get_function - (FromLlbc (Pure.FunId (Regular global.body_id), None, None)) + (FromLlbc (Pure.FunId (FRegular global.body_id), None, None)) ctx in @@ -2662,7 +2662,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "="; F.pp_print_space fmt (); - let success = ctx_get_variant (Assumed Result) result_return_id ctx in + let success = ctx_get_variant (TAssumed Result) result_return_id ctx in F.pp_print_string fmt (success ^ " ())") | Coq -> F.pp_print_string fmt "Check"; @@ -2691,7 +2691,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "=="; F.pp_print_space fmt (); - let success = ctx_get_variant (Assumed Result) result_return_id ctx in + let success = ctx_get_variant (TAssumed Result) result_return_id ctx in F.pp_print_string fmt ("." ^ success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 31b1a447..272e6396 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -3,7 +3,7 @@ open Pure open TranslateCore module C = Contexts -module RegionVarId = T.RegionVarId +module RegionId = T.RegionId module F = Format open ExtractBuiltin @@ -675,7 +675,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | AdtId id -> let def = TypeDeclId.Map.find id type_decls in Print.name_to_string def.name - | Assumed aty -> show_assumed_ty aty + | TAssumed aty -> show_assumed_ty aty | Tuple -> raise (Failure "Unreachable") in match id with @@ -687,10 +687,10 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | FromLlbc (fid, lp_id, rg_id) -> let fun_name = match fid with - | FunId (Regular fid) -> + | FunId (FRegular fid) -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | FunId (Assumed aid) -> A.show_assumed_fun_id aid + | FunId (FAssumed aid) -> A.show_assumed_fun_id aid | TraitMethod (trait_ref, method_name, _) -> (* Shouldn't happen *) if !Config.fail_hard then raise (Failure "Unexpected") @@ -716,9 +716,9 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | DecreasesProofId (fid, lid) -> let fun_name = match fid with - | Regular fid -> + | FRegular fid -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | Assumed aid -> A.show_assumed_fun_id aid + | FAssumed aid -> A.show_assumed_fun_id aid in let loop = match lid with @@ -729,9 +729,9 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TerminationMeasureId (fid, lid) -> let fun_name = match fid with - | Regular fid -> + | FRegular fid -> Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | Assumed aid -> A.show_assumed_fun_id aid + | FAssumed aid -> A.show_assumed_fun_id aid in let loop = match lid with @@ -745,19 +745,19 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let variant_name = match id with | Tuple -> raise (Failure "Unreachable") - | Assumed Result -> + | TAssumed Result -> if variant_id = result_return_id then "@result::Return" else if variant_id = result_fail_id then "@result::Fail" else raise (Failure "Unreachable") - | Assumed Error -> + | TAssumed Error -> if variant_id = error_failure_id then "@error::Failure" else if variant_id = error_out_of_fuel_id then "@error::OutOfFuel" else raise (Failure "Unreachable") - | Assumed Fuel -> + | TAssumed Fuel -> if variant_id = fuel_zero_id then "@fuel::0" else if variant_id = fuel_succ_id then "@fuel::Succ" else raise (Failure "Unreachable") - | Assumed (State | Array | Slice | Str | RawPtr _) -> + | TAssumed (State | Array | Slice | Str | RawPtr _) -> raise (Failure ("Unreachable: variant id (" @@ -776,7 +776,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let field_name = match id with | Tuple -> raise (Failure "Unreachable") - | Assumed + | TAssumed (State | Result | Error | Fuel | Array | Slice | Str | RawPtr _) -> (* We can't directly have access to the fields of those types *) raise (Failure "Unreachable") @@ -835,7 +835,7 @@ let allow_collisions (id : id) : bool = | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ | TraitMethodId _ -> !Config.record_fields_short_names - | FunId (Pure _ | FromLlbc (FunId (Assumed _), _, _)) -> + | FunId (Pure _ | FromLlbc (FunId (FAssumed _), _, _)) -> (* We map several assumed functions to the same id *) true | _ -> false @@ -928,16 +928,16 @@ let ctx_get (id : id) (ctx : extraction_ctx) : string = let names_maps_add_assumed_type (id_to_string : id -> string) (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = - names_maps_add id_to_string (TypeId (Assumed id)) name nm + names_maps_add id_to_string (TypeId (TAssumed id)) name nm let names_maps_add_assumed_struct (id_to_string : id -> string) (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = - names_maps_add id_to_string (StructId (Assumed id)) name nm + names_maps_add id_to_string (StructId (TAssumed id)) name nm let names_maps_add_assumed_variant (id_to_string : id -> string) (id : assumed_ty) (variant_id : VariantId.id) (name : string) (nm : names_maps) : names_maps = - names_maps_add id_to_string (VariantId (Assumed id, variant_id)) name nm + names_maps_add id_to_string (VariantId (TAssumed id, variant_id)) name nm let names_maps_add_function (id_to_string : id -> string) (fid : fun_id) (name : string) (nm : names_maps) : names_maps = @@ -951,7 +951,7 @@ let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = - ctx_get_function (FromLlbc (FunId (Regular id), lp, rg)) ctx + ctx_get_function (FromLlbc (FunId (FRegular id), lp, rg)) ctx let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = assert (id <> Tuple); @@ -961,7 +961,7 @@ let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = ctx_get_type (AdtId id) ctx let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = - ctx_get_type (Assumed id) ctx + ctx_get_type (TAssumed id) ctx let ctx_get_trait_constructor (id : trait_decl_id) (ctx : extraction_ctx) : string = @@ -1027,11 +1027,11 @@ let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) let ctx_get_decreases_proof (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get (DecreasesProofId (Regular def_id, loop_id)) ctx + ctx_get (DecreasesProofId (FRegular def_id, loop_id)) ctx let ctx_get_termination_measure (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = - ctx_get (TerminationMeasureId (Regular def_id, loop_id)) ctx + ctx_get (TerminationMeasureId (FRegular def_id, loop_id)) ctx (** Generate a unique type variable name and add it to the context *) let ctx_add_type_var (basename : string) (id : TypeVarId.id) @@ -1150,7 +1150,7 @@ let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : ctx.fmt.decreases_proof_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add (DecreasesProofId (Regular def.def_id, def.loop_id)) name ctx + ctx_add (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1158,7 +1158,7 @@ let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : ctx.fmt.termination_measure_name def.def_id def.basename def.num_loops def.loop_id in - ctx_add (TerminationMeasureId (Regular def.def_id, def.loop_id)) name ctx + ctx_add (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = @@ -1176,7 +1176,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : | None -> (* Not the case: "standard" registration *) let name = ctx.fmt.global_name def.name in - let body = FunId (FromLlbc (FunId (Regular def.body_id), None, None)) in + let body = FunId (FromLlbc (FunId (FRegular def.body_id), None, None)) in let ctx = ctx_add decl (name ^ "_c") ctx in let ctx = ctx_add body (name ^ "_body") ctx in ctx @@ -1197,7 +1197,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in let region_names = List.map - (fun rid -> (T.RegionVarId.nth sg.generics.regions rid).name) + (fun rid -> (T.RegionId.nth sg.generics.regions rid).name) rg.regions in Some { id = rg_id; region_names } @@ -1218,7 +1218,7 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) let num_backs = List.length backs in (* Add the function name *) let def_name = ctx_compute_fun_name trans_group def ctx in - let fun_id = (Pure.FunId (Regular def_id), def.loop_id, def.back_id) in + let fun_id = (Pure.FunId (FRegular def_id), def.loop_id, def.back_id) in let ctx = ctx_add (FunId (FromLlbc fun_id)) def_name ctx in (* Add the name info *) { @@ -1300,7 +1300,7 @@ let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps let assumed_functions = List.map (fun (fid, rg, name) -> - (FromLlbc (Pure.FunId (Assumed fid), None, rg), name)) + (FromLlbc (Pure.FunId (FAssumed fid), None, rg), name)) init.assumed_llbc_functions @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions in diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 77f76bb4..48273023 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -799,19 +799,19 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | None -> ( (* No basename: we use the first letter of the type *) match ty with - | Adt (type_id, generics) -> ( + | TAdt (type_id, generics) -> ( match type_id with | Tuple -> (* The "pair" case is frequent enough to have its special treatment *) if List.length generics.types = 2 then "p" else "t" - | Assumed Result -> "r" - | Assumed Error -> ConstStrings.error_basename - | Assumed Fuel -> ConstStrings.fuel_basename - | Assumed Array -> "a" - | Assumed Slice -> "s" - | Assumed Str -> "s" - | Assumed State -> ConstStrings.state_basename - | Assumed (RawPtr _) -> "p" + | TAssumed Result -> "r" + | TAssumed Error -> ConstStrings.error_basename + | TAssumed Fuel -> ConstStrings.fuel_basename + | TAssumed Array -> "a" + | TAssumed Slice -> "s" + | TAssumed Str -> "s" + | TAssumed State -> ConstStrings.state_basename + | TAssumed (RawPtr _) -> "p" | AdtId adt_id -> let def = TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls in (* Derive the var name from the last ident of the type name @@ -826,8 +826,8 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) match !backend with | FStar -> "x" (* lacking inspiration here... *) | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) - | Literal lty -> ( - match lty with Bool -> "b" | Char -> "c" | Integer _ -> "i") + | TLiteral lty -> ( + match lty with TBool -> "b" | TChar -> "c" | TInteger _ -> "i") | Arrow _ -> "f" | TraitType (_, _, name) -> name_from_type_ident name) in @@ -864,7 +864,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) let extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = match cv with - | Scalar sv -> ( + | VScalar sv -> ( match !backend with | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) | Coq | HOL4 | Lean -> @@ -895,14 +895,14 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | HOL4 -> () | _ -> raise (Failure "Unreachable")); if print_brackets then F.pp_print_string fmt ")") - | Bool b -> + | VBool b -> let b = match !backend with | HOL4 -> if b then "T" else "F" | Coq | FStar | Lean -> if b then "true" else "false" in F.pp_print_string fmt b - | Char c -> ( + | VChar c -> ( match !backend with | HOL4 -> (* [#"a"] is a notation for [CHR 97] (97 is the ASCII code for 'a') *) @@ -1130,9 +1130,9 @@ let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) let extract_literal_type (ctx : extraction_ctx) (fmt : F.formatter) (ty : literal_type) : unit = match ty with - | Bool -> F.pp_print_string fmt ctx.fmt.bool_name - | Char -> F.pp_print_string fmt ctx.fmt.char_name - | Integer int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + | TBool -> F.pp_print_string fmt ctx.fmt.bool_name + | TChar -> F.pp_print_string fmt ctx.fmt.char_name + | TInteger int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) (** [inside] constrols whether we should add parentheses or not around type applications (if [true] we add parentheses). @@ -1158,7 +1158,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (no_params_tys : TypeDeclId.Set.t) (inside : bool) (ty : ty) : unit = let extract_rec = extract_ty ctx fmt no_params_tys in match ty with - | Adt (type_id, generics) -> ( + | TAdt (type_id, generics) -> ( let has_params = generics <> empty_generic_args in match type_id with | Tuple -> @@ -1181,7 +1181,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt ()) (extract_rec true) generics.types; F.pp_print_string fmt ")") - | AdtId _ | Assumed _ -> ( + | AdtId _ | TAssumed _ -> ( (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: `tree a b` @@ -1224,7 +1224,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) let print_tys = match type_id with | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) - | Assumed _ -> true + | TAssumed _ -> true | _ -> raise (Failure "Unreachable") in if types <> [] && print_tys then ( @@ -1244,7 +1244,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) (extract_trait_ref ctx fmt no_params_tys true) trait_refs))) | TypeVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) - | Literal lty -> extract_literal_type ctx fmt lty + | TLiteral lty -> extract_literal_type ctx fmt lty | Arrow (arg_ty, ret_ty) -> if inside then F.pp_print_string fmt "("; extract_rec false arg_ty; diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index e17ea16f..1f17c1aa 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -91,7 +91,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_Call env call = (match call.func.func with - | FunId (Regular id) -> + | FunId (FRegular id) -> if FunDeclId.Set.mem id fun_ids then ( can_diverge := true; is_rec := true) @@ -100,7 +100,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) self#may_fail info.can_fail; stateful := !stateful || info.stateful; can_diverge := !can_diverge || info.can_diverge - | FunId (Assumed id) -> + | FunId (FAssumed id) -> (* None of the assumed functions can diverge nor are considered stateful *) can_fail := !can_fail || Assumed.assumed_fun_can_fail id | TraitMethod _ -> diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 24ff4808..bc28bcd6 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -46,7 +46,7 @@ let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : let { A.regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in - let norm = AssociatedTypes.ctx_normalize_rty ctx in + let norm = AssociatedTypes.ctx_normalize_ty ctx in let inputs = List.map norm inputs in let output = norm output in { sg with A.inputs; output } @@ -70,7 +70,7 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) in let generics = let { T.regions; types; const_generics; trait_clauses } = sg.generics in - let regions = List.map (fun _ -> T.Erased) regions in + let regions = List.map (fun _ -> T.RErased) regions in let types = List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) types in let const_generics = List.map @@ -110,9 +110,8 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) ]} *) (* We will need to update the trait refs map while we perform the instantiations *) - let mk_tr_subst - (tr_map : T.erased_region T.trait_instance_id T.TraitClauseId.Map.t) - clause_id : T.erased_region T.trait_instance_id = + let mk_tr_subst (tr_map : T.trait_instance_id T.TraitClauseId.Map.t) + clause_id : T.trait_instance_id = match T.TraitClauseId.Map.find_opt clause_id tr_map with | Some tr -> tr | None -> raise (Failure "Local trait clause not found") @@ -185,7 +184,7 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) let sg = fdef.signature in (* Create the context *) let region_groups = - List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy + List.map (fun (g : T.region_group) -> g.id) sg.regions_hierarchy in let ctx = initialize_eval_context ctx region_groups sg.generics.types diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index e97795a1..d4dbf80a 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -301,8 +301,8 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) if nv.V.ty <> expected_ty then ( log#serror ("give_back_value: improper type:\n- expected: " - ^ ety_to_string ctx ty ^ "\n- received: " - ^ ety_to_string ctx nv.V.ty); + ^ PA.ty_to_string ctx ty ^ "\n- received: " + ^ PA.ty_to_string ctx nv.V.ty); raise (Failure "Value given back doesn't have the proper type")); (* Replace *) set_replaced (); @@ -426,12 +426,12 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* Nothing special to do *) super#visit_ALoan opt_abs lc - method! visit_Abs opt_abs abs = + method! visit_EAbs opt_abs abs = (* We remember in which abstraction we are before diving - * this is necessary for projecting values: we need to know * over which regions to project *) assert (Option.is_none opt_abs); - super#visit_Abs (Some abs) abs + super#visit_EAbs (Some abs) abs end in @@ -447,7 +447,7 @@ let give_back_symbolic_value (_config : C.config) (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = (* Sanity checks *) - assert (sv.sv_id <> nsv.sv_id); + assert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty); (match nsv.sv_kind with | V.SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> @@ -554,8 +554,8 @@ let give_back_avalue_to_same_abstraction (_config : C.config) if nv.V.ty <> expected_ty then ( log#serror ("give_back_avalue_to_same_abstraction: improper type:\n\ - - expected: " ^ rty_to_string ctx ty ^ "\n- received: " - ^ rty_to_string ctx nv.V.ty); + - expected: " ^ PA.ty_to_string ctx ty ^ "\n- received: " + ^ PA.ty_to_string ctx nv.V.ty); raise (Failure "Value given back doesn't have the proper type")); (* This is the loan we are looking for: apply the projection to * the value we give back and replaced this mutable loan with @@ -1734,14 +1734,14 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) and list_values (v : V.typed_value) : V.typed_avalue list * V.typed_value = let ty = v.V.ty in match v.V.value with - | Literal _ -> ([], v) - | Adt adt -> + | VLiteral _ -> ([], v) + | VAdt adt -> let avll, field_values = List.split (List.map list_values adt.field_values) in let avl = List.concat avll in let adt = { adt with V.field_values } in - (avl, { v with V.value = Adt adt }) + (avl, { v with V.value = VAdt adt }) | Bottom -> raise (Failure "Unreachable") | Borrow _ -> (* We don't support nested borrows for now *) @@ -1750,9 +1750,9 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) match lc with | SharedLoan (bids, sv) -> let avl, sv = list_values sv in - if destructure_shared_values then + if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) - let rty = ety_no_regions_to_rty ty in + assert (ty_no_regions ty); let av : V.typed_avalue = assert (not (value_has_loans_or_borrows ctx sv.V.value)); (* We introduce fresh ids for the symbolic values *) @@ -1771,12 +1771,12 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) let value = - V.ALoan (V.ASharedLoan (bids, sv, mk_aignored rty)) + V.ALoan (V.ASharedLoan (bids, sv, mk_aignored ty)) in - { V.value; ty = rty } + { V.value; ty } in let avl = List.append [ av ] avl in - (avl, sv) + (avl, sv)) else (avl, { v with V.value = V.Loan (V.SharedLoan (bids, sv)) }) | MutLoan _ -> raise (Failure "Unreachable")) | Symbolic _ -> @@ -1842,12 +1842,12 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) let ty = v.V.ty in match v.V.value with - | V.Literal _ -> ([], v) + | V.VLiteral _ -> ([], v) | V.Bottom -> (* Can happen: we *do* convert dummy values to abstractions, and dummy values can contain bottoms *) ([], v) - | V.Adt adt -> + | V.VAdt adt -> (* Two cases, depending on whether we have to group all the borrows/loans inside one abstraction or not *) let avl, field_values = @@ -1879,16 +1879,17 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) ([], field_values) in let adt = { adt with field_values } in - (avl, { v with V.value = V.Adt adt }) + (avl, { v with V.value = V.VAdt adt }) | V.Borrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in + assert (ty_no_regions ref_ty); (* Sanity check *) assert allow_borrows; (* Convert the borrow content *) match bc with | SharedBorrow bid -> - let ref_ty = ety_no_regions_to_rty ref_ty in - let ty = T.Ref (T.Var r_id, ref_ty, kind) in + assert (ty_no_regions ref_ty); + let ty = T.Ref (T.RVar r_id, ref_ty, kind) in let value = V.ABorrow (V.ASharedBorrow bid) in ([ { V.value; ty } ], v) | MutBorrow (bid, bv) -> @@ -1896,8 +1897,7 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx bv.V.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ref_ty = ety_no_regions_to_rty ref_ty in - let ty = T.Ref (T.Var r_id, ref_ty, kind) in + let ty = T.Ref (T.RVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in let av = V.ABorrow (V.AMutBorrow (bid, ignored)) in let av = { V.value = av; ty } in @@ -1917,8 +1917,8 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) assert (not (value_has_borrows ctx sv.V.value)); (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - let ty = ety_no_regions_to_rty ty in - let ty = mk_ref_ty (T.Var r_id) ty T.Shared in + assert (ty_no_regions ty); + let ty = mk_ref_ty (T.RVar r_id) ty T.Shared in let ignored = mk_aignored ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in @@ -1935,8 +1935,8 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) | V.MutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) - let ty = ety_no_regions_to_rty ty in - let ty = mk_ref_ty (T.Var r_id) ty T.Mut in + assert (ty_no_regions ty); + let ty = mk_ref_ty (T.RVar r_id) ty T.Mut in let ignored = mk_aignored ty in let av = V.ALoan (V.AMutLoan (bid, ignored)) in let av = { V.value = av; ty } in diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 31b67bd7..6302dcc3 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -137,7 +137,6 @@ val convert_value_to_abstractions : Rem.: it may be more idiomatic to have a functor, but this seems a bit heavyweight, though. *) - type merge_duplicates_funcs = { merge_amut_borrows : V.borrow_id -> diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index e7da045c..cf8e5994 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -88,24 +88,29 @@ let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) (** Helper function. This function allows to define in a generic way a comparison of **region types**. - See [projections_interesect] for instance. - + See [projections_intersect] for instance. + + Important: the regions in the types mustn't be erased. + [default]: default boolean to return, when comparing types with no regions [combine]: how to combine booleans [compare_regions]: how to compare regions TODO: is there a way of deriving such a comparison? + TODO: rename *) let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) - (compare_regions : T.RegionId.id T.region -> T.RegionId.id T.region -> bool) - (ty1 : T.rty) (ty2 : T.rty) : bool = + (compare_regions : T.region -> T.region -> bool) (ty1 : T.rty) (ty2 : T.rty) + : bool = let compare = compare_rtys default combine compare_regions in + (* Sanity check - TODO: don't do this at every recursive call *) + assert (ty_is_rty ty1 && ty_is_rty ty2); (* Normalize the associated types *) match (ty1, ty2) with - | T.Literal lit1, T.Literal lit2 -> + | T.TLiteral lit1, T.TLiteral lit2 -> assert (lit1 = lit2); default - | T.Adt (id1, generics1), T.Adt (id2, generics2) -> + | T.TAdt (id1, generics1), T.TAdt (id2, generics2) -> assert (id1 = id2); (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) @@ -161,8 +166,8 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) | _ -> log#lerror (lazy - ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_rty ty1 - ^ "\n- ty2: " ^ T.show_rty ty2)); + ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_ty ty1 + ^ "\n- ty2: " ^ T.show_ty ty2)); raise (Failure "Unreachable") (** Check if two different projections intersect. This is necessary when @@ -183,6 +188,9 @@ let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) (** Check if the first projection contains the second projection. We use this function when checking invariants. + + The regions in the types shouldn't be erased (this function will raise an exception + otherwise). *) let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) (rset2 : T.RegionId.Set.t) : bool = @@ -264,21 +272,21 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) | V.AIgnoredSharedLoan _ -> super#visit_aloan_content env lc - method! visit_Var env bv v = + method! visit_EBinding env bv v = assert (Option.is_none !abs_or_var); abs_or_var := Some (match bv with - | VarBinder b -> VarId b.C.index - | DummyBinder id -> DummyVarId id); - super#visit_Var env bv v; + | BVar b -> VarId b.C.index + | BDummy id -> DummyVarId id); + super#visit_EBinding env bv v; abs_or_var := None - method! visit_Abs env abs = + method! visit_EAbs env abs = assert (Option.is_none !abs_or_var); if ek.enter_abs then ( abs_or_var := Some (AbsId abs.V.abs_id); - super#visit_Abs env abs; + super#visit_EAbs env abs; abs_or_var := None) else () end @@ -921,6 +929,8 @@ let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) Note that for sanity, this function checks that we update *at least* one projector of loans. + + [proj_ty]: shouldn't contain erased regions. [subst]: takes as parameters the abstraction in which we perform the substitution and the list of given back values at the projector of @@ -932,6 +942,8 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) (subst : V.abs -> (V.msymbolic_value * V.aproj) list -> V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = + (* *) + assert (ty_is_rty proj_ty); (* Small helpers for sanity checks *) let updated = ref false in let update abs local_given_back : V.aproj = diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index b267bb51..48688893 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -211,11 +211,12 @@ let apply_symbolic_expansion_non_borrow (config : C.config) The function might return a list of values if the symbolic value to expand is an enumeration. + [generics]: mustn't contain erased regions. [expand_enumerations] controls the expansion of enumerations: if false, it doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.rgeneric_args) + (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.generic_args) (ctx : C.eval_ctx) : V.symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) @@ -263,11 +264,12 @@ let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : The function might return a list of values if the symbolic value to expand is an enumeration. + [generics]: the regions shouldn't have been erased. [expand_enumerations] controls the expansion of enumerations: if [false], it doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.rgeneric_args) + (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.generic_args) (ctx : C.eval_ctx) : V.symbolic_expansion list = match (adt_id, generics.regions, generics.types) with | T.AdtId def_id, _, _ -> @@ -275,7 +277,7 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) def_id generics ctx | T.Tuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind generics.types ] - | T.Assumed T.Box, [], [ boxed_ty ] -> + | T.TAssumed T.TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] | _ -> raise @@ -330,10 +332,10 @@ let expand_symbolic_value_shared_borrow (config : C.config) V.Borrow (V.SharedBorrow bid) else super#visit_Symbolic env sv - method! visit_Abs proj_regions abs = + method! visit_EAbs proj_regions abs = assert (Option.is_none proj_regions); let proj_regions = Some abs.V.regions in - super#visit_Abs proj_regions abs + super#visit_EAbs proj_regions abs method! visit_AProjSharedBorrow proj_regions asb = let expand_asb (asb : V.abstract_shared_borrow) : @@ -398,9 +400,9 @@ let expand_symbolic_value_shared_borrow (config : C.config) (** TODO: simplify and merge with the other expansion function *) let expand_symbolic_value_borrow (config : C.config) (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : - cm_fun = + (region : T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : cm_fun = fun cf ctx -> + assert (region <> T.RErased); (* Check that we are allowed to expand the reference *) assert (not (region_in_set region ctx.ended_regions)); (* Match on the reference kind *) @@ -500,10 +502,10 @@ let expand_symbolic_bool (config : C.config) (sv : V.symbolic_value) let original_sv = sv in let original_sv_place = sv_place in let rty = original_sv.V.sv_ty in - assert (rty = T.Literal PV.Bool); + assert (rty = T.TLiteral PV.TBool); (* Expand the symbolic value to true or false and continue execution *) - let see_true = V.SeLiteral (PV.Bool true) in - let see_false = V.SeLiteral (PV.Bool false) in + let see_true = V.SeLiteral (PV.VBool true) in + let see_false = V.SeLiteral (PV.VBool false) in let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) apply_branching_symbolic_expansions_non_borrow config original_sv @@ -527,7 +529,7 @@ let expand_symbolic_value_no_branching (config : C.config) fun cf ctx -> match rty with (* ADTs *) - | T.Adt (adt_id, generics) -> + | T.TAdt (adt_id, generics) -> (* Compute the expanded value *) let allow_branching = false in let seel = @@ -584,7 +586,7 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) (* Execute *) match rty with (* ADTs *) - | T.Adt (adt_id, generics) -> + | T.TAdt (adt_id, generics) -> let allow_branching = true in (* Compute the expanded value *) let seel = @@ -604,7 +606,7 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) (tgts : (V.scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - assert (sv.V.sv_ty = T.Literal (PV.Integer int_type)); + assert (sv.V.sv_ty = T.TLiteral (PV.TInteger int_type)); (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is @@ -615,7 +617,7 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) * (optional expansion, statement to execute) *) let seel = - List.map (fun (v, cf) -> (Some (V.SeLiteral (PV.Scalar v)), cf)) tgts + List.map (fun (v, cf) -> (Some (V.SeLiteral (PV.VScalar v)), cf)) tgts in let seel = List.append seel [ (None, otherwise) ] in (* Then expand and evaluate - this generates the proper symbolic AST *) @@ -663,7 +665,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ^ symbolic_value_to_string ctx sv)); let cc : cm_fun = match sv.V.sv_ty with - | T.Adt (AdtId def_id, _) -> + | T.TAdt (AdtId def_id, _) -> (* {!expand_symbolic_value_no_branching} checks if there are branchings, * but we prefer to also check it here - this leads to cleaner messages * and debugging *) @@ -688,15 +690,15 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = [config]): " ^ Print.name_to_string def.name)) else expand_symbolic_value_no_branching config sv None - | T.Adt ((Tuple | Assumed Box), _) | T.Ref (_, _, _) -> + | T.TAdt ((Tuple | TAssumed TBox), _) | T.Ref (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None - | T.Adt (Assumed (Array | Slice | Str), _) -> + | T.TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TypeVar _ | T.Literal _ | Never | T.TraitType _ | T.Arrow _ + | T.TypeVar _ | T.TLiteral _ | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> raise (Failure "Unreachable") in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 245f3b77..f4430c77 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -105,13 +105,13 @@ let literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : ^ Print.PrimitiveValues.literal_to_string cv)); match (ty, cv) with (* Scalar, boolean... *) - | PV.Bool, Bool v -> { V.value = V.Literal (Bool v); ty = T.Literal ty } - | Char, Char v -> { V.value = V.Literal (Char v); ty = T.Literal ty } - | Integer int_ty, PV.Scalar v -> + | PV.TBool, VBool v -> { V.value = V.VLiteral (VBool v); ty = T.TLiteral ty } + | TChar, VChar v -> { V.value = V.VLiteral (VChar v); ty = T.TLiteral ty } + | TInteger int_ty, PV.VScalar v -> (* Check the type and the ranges *) assert (int_ty = v.int_ty); assert (check_scalar_value_in_range v); - { V.value = V.Literal (PV.Scalar v); ty = T.Literal ty } + { V.value = V.VLiteral (PV.VScalar v); ty = T.TLiteral ty } (* Remaining cases (invalid) *) | _, _ -> raise (Failure "Improperly typed constant value") @@ -138,17 +138,17 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) * the fact that we have exhaustive matches below makes very obvious the cases * in which we need to fail *) match v.V.value with - | V.Literal _ -> (ctx, v) - | V.Adt av -> + | V.VLiteral _ -> (ctx, v) + | V.VAdt av -> (* Sanity check *) (match v.V.ty with - | T.Adt (T.Assumed T.Box, _) -> + | T.TAdt (T.TAssumed T.TBox, _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.Adt (T.AdtId _, _) as ty -> + | T.TAdt (T.AdtId _, _) as ty -> assert (allow_adt_copy || ty_is_primitively_copyable ty) - | T.Adt (T.Tuple, _) -> () (* Ok *) - | T.Adt - ( T.Assumed (Slice | T.Array), + | T.TAdt (T.Tuple, _) -> () (* Ok *) + | T.TAdt + ( T.TAssumed (TSlice | T.TArray), { regions = []; types = [ ty ]; @@ -162,7 +162,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) (copy_value allow_adt_copy config) ctx av.field_values in - (ctx, { v with V.value = V.Adt { av with field_values = fields } }) + (ctx, { v with V.value = V.VAdt { av with field_values = fields } }) | V.Bottom -> raise (Failure "Can't copy ⊥") | V.Borrow bc -> ( (* We can only copy shared borrows *) @@ -292,7 +292,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) List.find (fun (name, _) -> name = const_name) trait_decl.consts in (* Introduce a fresh symbolic value *) - let v = mk_fresh_symbolic_typed_value_from_ety V.TraitConst ty in + let v = mk_fresh_symbolic_typed_value V.TraitConst ty in (* Continue the evaluation *) let e = cf v ctx in (* We have to wrap the generated expression *) @@ -304,7 +304,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ( ctx0, None, value_as_symbolic v.value, - SymbolicAst.TraitConstValue + SymbolicAst.VaTraitConstValue (trait_ref, generics, const_name), e )))) | E.CVar vid -> ( @@ -329,7 +329,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ( ctx0, None, value_as_symbolic v.value, - SymbolicAst.ConstGenericValue vid, + SymbolicAst.VaConstGenericValue vid, e ))) | E.CFnPtr _ -> raise (Failure "TODO")) | E.Copy p -> @@ -421,21 +421,21 @@ let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) (* Apply the unop *) let apply cf (v : V.typed_value) : m_fun = match (unop, v.V.value) with - | E.Not, V.Literal (Bool b) -> - cf (Ok { v with V.value = V.Literal (Bool (not b)) }) - | E.Neg, V.Literal (PV.Scalar sv) -> ( + | E.Not, V.VLiteral (VBool b) -> + cf (Ok { v with V.value = V.VLiteral (VBool (not b)) }) + | E.Neg, V.VLiteral (PV.VScalar sv) -> ( let i = Z.neg sv.PV.value in match mk_scalar sv.int_ty i with | Error _ -> cf (Error EPanic) - | Ok sv -> cf (Ok { v with V.value = V.Literal (PV.Scalar sv) })) - | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.Literal (PV.Scalar sv) -> ( + | Ok sv -> cf (Ok { v with V.value = V.VLiteral (PV.VScalar sv) })) + | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.VLiteral (PV.VScalar sv) -> ( assert (src_ty = sv.int_ty); let i = sv.PV.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) | Ok sv -> - let ty = T.Literal (Integer tgt_ty) in - let value = V.Literal (PV.Scalar sv) in + let ty = T.TLiteral (TInteger tgt_ty) in + let value = V.VLiteral (PV.VScalar sv) in cf (Ok { V.ty; value })) | _ -> raise (Failure "Invalid input for unop") in @@ -452,9 +452,9 @@ let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) let res_sv_id = C.fresh_symbolic_value_id () in let res_sv_ty = match (unop, v.V.ty) with - | E.Not, (T.Literal Bool as lty) -> lty - | E.Neg, (T.Literal (Integer _) as lty) -> lty - | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.Literal (Integer tgt_ty) + | E.Not, (T.TLiteral TBool as lty) -> lty + | E.Neg, (T.TLiteral (TInteger _) as lty) -> lty + | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.TLiteral (TInteger tgt_ty) | _ -> raise (Failure "Invalid input for unop") in let res_sv = @@ -489,11 +489,11 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) (* Equality/inequality check is primitive only for a subset of types *) assert (ty_is_primitively_copyable v1.ty); let b = v1 = v2 in - Ok { V.value = V.Literal (Bool b); ty = T.Literal Bool }) + Ok { V.value = V.VLiteral (VBool b); ty = T.TLiteral TBool }) else (* For the non-equality operations, the input values are necessarily scalars *) match (v1.V.value, v2.V.value) with - | V.Literal (PV.Scalar sv1), V.Literal (PV.Scalar sv2) -> ( + | V.VLiteral (PV.VScalar sv1), V.VLiteral (PV.VScalar sv2) -> ( (* There are binops which require the two operands to have the same type, and binops for which it is not the case. There are also binops which return booleans, and binops which @@ -514,7 +514,7 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) raise (Failure "Unreachable") in Ok - ({ V.value = V.Literal (Bool b); ty = T.Literal Bool } + ({ V.value = V.VLiteral (VBool b); ty = T.TLiteral TBool } : V.typed_value) | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr -> ( @@ -543,8 +543,8 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) | Ok sv -> Ok { - V.value = V.Literal (PV.Scalar sv); - ty = T.Literal (Integer sv1.int_ty); + V.value = V.VLiteral (PV.VScalar sv); + ty = T.TLiteral (TInteger sv1.int_ty); }) | E.Shl | E.Shr -> raise Unimplemented | E.Ne | E.Eq -> raise (Failure "Unreachable")) @@ -580,19 +580,19 @@ let eval_binary_op_symbolic (config : C.config) (binop : E.binop) assert (v1.ty = v2.ty); (* Equality/inequality check is primitive only for a subset of types *) assert (ty_is_primitively_copyable v1.ty); - T.Literal Bool) + T.TLiteral TBool) else (* Other operations: input types are integers *) match (v1.V.ty, v2.V.ty) with - | T.Literal (Integer int_ty1), T.Literal (Integer int_ty2) -> ( + | T.TLiteral (TInteger int_ty1), T.TLiteral (TInteger int_ty2) -> ( match binop with | E.Lt | E.Le | E.Ge | E.Gt -> assert (int_ty1 = int_ty2); - T.Literal Bool + T.TLiteral TBool | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr -> assert (int_ty1 = int_ty2); - T.Literal (Integer int_ty1) + T.TLiteral (TInteger int_ty1) | E.Shl | E.Shr -> raise Unimplemented | E.Ne | E.Eq -> raise (Failure "Unreachable")) | _ -> raise (Failure "Invalid inputs for binop") @@ -670,7 +670,7 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) | E.TwoPhaseMut -> T.Mut | _ -> raise (Failure "Unreachable") in - let rv_ty = T.Ref (T.Erased, v.ty, ref_kind) in + let rv_ty = T.Ref (T.RErased, v.ty, ref_kind) in let bc = match bkind with | E.Shared | E.Shallow -> @@ -698,7 +698,7 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) fun ctx -> (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) let bid = C.fresh_borrow_id () in - let rv_ty = T.Ref (T.Erased, v.ty, Mut) in + let rv_ty = T.Ref (T.RErased, v.ty, Mut) in let rv : V.typed_value = { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } in @@ -727,9 +727,9 @@ let eval_rvalue_aggregate (config : C.config) match type_id with | Tuple -> let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in + let v = V.VAdt { variant_id = None; field_values = values } in let generics = TypesUtils.mk_generic_args [] tys [] [] in - let ty = T.Adt (T.Tuple, generics) in + let ty = T.TAdt (T.Tuple, generics) in let aggregated : V.typed_value = { V.value = v; ty } in (* Call the continuation *) cf aggregated ctx @@ -750,11 +750,11 @@ let eval_rvalue_aggregate (config : C.config) let av : V.adt_value = { V.variant_id = opt_variant_id; V.field_values = values } in - let aty = T.Adt (T.AdtId def_id, generics) in - let aggregated : V.typed_value = { V.value = Adt av; ty = aty } in + let aty = T.TAdt (T.AdtId def_id, generics) in + let aggregated : V.typed_value = { V.value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx - | Assumed _ -> raise (Failure "Unreachable")) + | TAssumed _ -> raise (Failure "Unreachable")) | E.AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) assert (List.for_all (fun (v : V.typed_value) -> v.V.ty = ety) values); @@ -762,22 +762,20 @@ let eval_rvalue_aggregate (config : C.config) let len = (literal_as_scalar (const_generic_as_literal cg)).value in assert (len = Z.of_int (List.length values)); let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in - let ty = T.Adt (T.Assumed T.Array, generics) in + let ty = T.TAdt (T.TAssumed T.TArray, generics) in (* In order to generate a better AST, we introduce a symbolic value equal to the array. The reason is that otherwise, the array we introduce here might be duplicated in the generated code: by introducing a symbolic value we introduce a let-binding in the generated code. *) - let saggregated = - mk_fresh_symbolic_typed_value_from_ety V.Aggregate ty - in + let saggregated = mk_fresh_symbolic_typed_value V.Aggregate ty in (* Call the continuation *) match cf saggregated ctx with | None -> None | Some e -> (* Introduce the symbolic value in the AST *) let sv = ValuesUtils.value_as_symbolic saggregated.value in - Some (SymbolicAst.IntroSymbolic (ctx, None, sv, Array values, e))) + Some (SymbolicAst.IntroSymbolic (ctx, None, sv, VaArray values, e))) in (* Compose and apply *) comp eval_ops compute cf diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 6e33c75b..50bc7767 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -343,24 +343,24 @@ let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : C.eval_ctx) : though) in the target context *) let is_fresh (ee : C.env_elem) : bool = match ee with - | C.Var (VarBinder _, _) | C.Frame -> false - | C.Var (DummyBinder bv, _) -> is_fresh_did bv - | C.Abs abs -> is_fresh_abs_id abs.abs_id + | C.EBinding (BVar _, _) | C.EFrame -> false + | C.EBinding (BDummy bv, _) -> is_fresh_did bv + | C.EAbs abs -> is_fresh_abs_id abs.abs_id in let new_eel, filt_env = List.partition is_fresh ctx.env in - let is_abs ee = match ee with C.Abs _ -> true | _ -> false in + let is_abs ee = match ee with C.EAbs _ -> true | _ -> false in let new_absl, new_dummyl = List.partition is_abs new_eel in let new_absl = List.map (fun ee -> - match ee with C.Abs abs -> abs | _ -> raise (Failure "Unreachable")) + match ee with C.EAbs abs -> abs | _ -> raise (Failure "Unreachable")) new_absl in let new_dummyl = List.map (fun ee -> match ee with - | C.Var (DummyBinder _, v) -> v + | C.EBinding (BDummy _, v) -> v | _ -> raise (Failure "Unreachable")) new_dummyl in diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 4310f017..3447131c 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -85,7 +85,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = *) let absl = List.filter_map - (function C.Var _ | C.Frame -> None | C.Abs abs -> Some abs) + (function C.EBinding _ | C.EFrame -> None | C.EAbs abs -> Some abs) ctx.env in let absl_ids, absl_id_maps = compute_absl_ids absl in @@ -109,7 +109,6 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = (fun r -> if T.RegionId.Set.mem r rids then nrid else r) (fun x -> x) (fun x -> x) - (fun x -> x) (fun id -> let nid = C.fresh_symbolic_value_id () in let sv = V.SymbolicValueId.Map.find id absl_id_maps.sids_to_values in @@ -163,14 +162,15 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = assert (T.RegionId.Set.is_empty abs.ancestors_regions); (* Introduce the new abstraction for the shared values *) - let rty = ety_no_regions_to_rty sv.V.ty in + assert (ty_no_regions sv.V.ty); + let rty = sv.V.ty in (* Create the shared loan child *) let child_rty = rty in let child_av = mk_aignored child_rty in (* Create the shared loan *) - let loan_rty = T.Ref (T.Var nrid, rty, T.Shared) in + let loan_rty = T.Ref (T.RVar nrid, rty, T.Shared) in let loan_value = V.ALoan (V.ASharedLoan (V.BorrowId.Set.singleton nlid, nsv, child_av)) in @@ -304,7 +304,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = in (* Add the abstractions *) - let fresh_absl = List.map (fun abs -> C.Abs abs) !fresh_absl in + let fresh_absl = List.map (fun abs -> C.EAbs abs) !fresh_absl in let env = List.append fresh_absl env in let ctx = { ctx with env } in @@ -322,7 +322,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = let sv = V.SymbolicValueId.Map.find sid new_ctx_ids_map.sids_to_values in - SymbolicAst.IntroSymbolic (ctx, None, sv, SingleValue v, e)) + SymbolicAst.IntroSymbolic (ctx, None, sv, VaSingleValue v, e)) e !sid_subst) let prepare_ashared_loans_no_synth (loop_id : V.LoopId.id) (ctx : C.eval_ctx) : @@ -865,8 +865,8 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : List.filter (fun (ee : C.env_elem) -> match ee with - | C.Var _ | C.Frame -> false - | Abs abs -> V.AbstractionId.Set.mem abs.abs_id old_ids.aids) + | C.EBinding _ | C.EFrame -> false + | EAbs abs -> V.AbstractionId.Set.mem abs.abs_id old_ids.aids) ctx.env in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 6d3ecb18..654ee21b 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -163,14 +163,14 @@ let collapse_ctx (loop_id : V.LoopId.id) (List.map (fun ee -> match ee with - | C.Abs _ | C.Frame | C.Var (VarBinder _, _) -> [ ee ] - | C.Var (DummyBinder id, v) -> + | C.EAbs _ | C.EFrame | C.EBinding (BVar _, _) -> [ ee ] + | C.EBinding (BDummy id, v) -> if is_fresh_did id then let absl = convert_value_to_abstractions abs_kind can_end destructure_shared_values ctx0 v in - List.map (fun abs -> C.Abs abs) absl + List.map (fun abs -> C.EAbs abs) absl else [ ee ]) ctx0.env) in @@ -436,14 +436,14 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Sanity check: there are no values/abstractions which should be in the prefix *) let check_valid (ee : C.env_elem) : unit = match ee with - | C.Var (C.VarBinder _, _) -> + | C.EBinding (C.BVar _, _) -> (* Variables are necessarily in the prefix *) raise (Failure "Unreachable") - | Var (C.DummyBinder did, _) -> + | EBinding (C.BDummy did, _) -> assert (not (C.DummyVarId.Set.mem did fixed_ids.dids)) - | Abs abs -> + | EAbs abs -> assert (not (V.AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) - | Frame -> + | EFrame -> (* This should have been eliminated *) raise (Failure "Unreachable") in @@ -451,7 +451,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) List.iter check_valid env1; (* Concatenate the suffixes and append the abstractions introduced while joining the prefixes *) - let absl = List.map (fun abs -> C.Abs abs) (List.rev !nabs) in + let absl = List.map (fun abs -> C.EAbs abs) (List.rev !nabs) in List.concat [ env0; env1; absl ] in @@ -466,12 +466,12 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Rem.: this function raises exceptions *) let rec join_prefixes (env0 : C.env) (env1 : C.env) : C.env = match (env0, env1) with - | ( (C.Var (C.DummyBinder b0, v0) as var0) :: env0', - (C.Var (C.DummyBinder b1, v1) as var1) :: env1' ) -> + | ( (C.EBinding (C.BDummy b0, v0) as var0) :: env0', + (C.EBinding (C.BDummy b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy - ("join_prefixes: DummyBinders:\n\n- fixed_ids:\n" ^ "\n" + ("join_prefixes: BDummys:\n\n- fixed_ids:\n" ^ "\n" ^ show_ids_sets fixed_ids ^ "\n\n- value0:\n" ^ env_elem_to_string ctx var0 ^ "\n\n- value1:\n" @@ -486,17 +486,17 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) assert (b0 = b1); let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.Var (C.DummyBinder b, v) in + let var = C.EBinding (C.BDummy b, v) in (* Continue *) var :: join_prefixes env0' env1') else (* Not in the prefix anymore *) join_suffixes env0 env1 - | ( (C.Var (C.VarBinder b0, v0) as var0) :: env0', - (C.Var (C.VarBinder b1, v1) as var1) :: env1' ) -> + | ( (C.EBinding (C.BVar b0, v0) as var0) :: env0', + (C.EBinding (C.BVar b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy - ("join_prefixes: VarBinders:\n\n- fixed_ids:\n" ^ "\n" + ("join_prefixes: BVars:\n\n- fixed_ids:\n" ^ "\n" ^ show_ids_sets fixed_ids ^ "\n\n- value0:\n" ^ env_elem_to_string ctx var0 ^ "\n\n- value1:\n" @@ -509,10 +509,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Match the values *) let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.Var (C.VarBinder b, v) in + let var = C.EBinding (C.BVar b, v) in (* Continue *) var :: join_prefixes env0' env1' - | (C.Abs abs0 as abs) :: env0', C.Abs abs1 :: env1' -> + | (C.EAbs abs0 as abs) :: env0', C.EAbs abs1 :: env1' -> (* Debug *) log#ldebug (lazy @@ -537,7 +537,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Remove the frame delimiter (the first element of an environment is a frame delimiter) *) let env0, env1 = match (env0, env1) with - | C.Frame :: env0, C.Frame :: env1 -> (env0, env1) + | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in @@ -546,7 +546,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ("- env0:\n" ^ C.show_env env0 ^ "\n\n- env1:\n" ^ C.show_env env1 ^ "\n\n")); - let env = List.rev (C.Frame :: join_prefixes env0 env1) in + let env = List.rev (C.EFrame :: join_prefixes env0 env1) in (* Construct the joined context - of course, the type, fun, etc. contexts * should be the same in the two contexts *) @@ -560,9 +560,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars; const_generic_vars; const_generic_vars_map; - norm_trait_etypes; - norm_trait_rtypes; - norm_trait_stypes; + norm_trait_types; env = _; ended_regions = ended_regions0; } = @@ -578,9 +576,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars = _; const_generic_vars = _; const_generic_vars_map = _; - norm_trait_etypes = _; - norm_trait_rtypes = _; - norm_trait_stypes = _; + norm_trait_types = _; env = _; ended_regions = ended_regions1; } = @@ -598,9 +594,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) type_vars; const_generic_vars; const_generic_vars_map; - norm_trait_etypes; - norm_trait_rtypes; - norm_trait_stypes; + norm_trait_types; env; ended_regions; } @@ -656,7 +650,6 @@ let refresh_abs (old_abs : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : (fun x -> x) (fun x -> x) (fun x -> x) - (fun x -> x) subst ctx.env in { ctx with C.env } diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 8cab546e..9bc25626 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -144,12 +144,16 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) borrow_loan_to_abs = !borrow_loan_to_abs; } -(** Match two types during a join. *) -let rec match_types (match_distinct_types : 'r T.ty -> 'r T.ty -> 'r T.ty) - (match_regions : 'r -> 'r -> 'r) (ty0 : 'r T.ty) (ty1 : 'r T.ty) : 'r T.ty = +(** Match two types during a join. + + TODO: probably don't need to take [match_regions] as input anymore. + *) +let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) + (match_regions : T.region -> T.region -> T.region) (ty0 : T.ty) (ty1 : T.ty) + : T.ty = let match_rec = match_types match_distinct_types match_regions in match (ty0, ty1) with - | Adt (id0, generics0), Adt (id1, generics1) -> + | TAdt (id0, generics0), TAdt (id1, generics1) -> assert (id0 = id1); assert (generics0.const_generics = generics1.const_generics); assert (generics0.trait_refs = generics1.trait_refs); @@ -167,12 +171,12 @@ let rec match_types (match_distinct_types : 'r T.ty -> 'r T.ty -> 'r T.ty) (List.combine generics0.types generics1.types) in let generics = { T.regions; types; const_generics; trait_refs } in - Adt (id, generics) + TAdt (id, generics) | TypeVar vid0, TypeVar vid1 -> assert (vid0 = vid1); let vid = vid0 in TypeVar vid - | Literal lty0, Literal lty1 -> + | TLiteral lty0, TLiteral lty1 -> assert (lty0 = lty1); ty0 | Never, Never -> ty0 @@ -190,16 +194,16 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let match_rec = match_typed_values ctx in let ty = M.match_etys v0.V.ty v1.V.ty in match (v0.V.value, v1.V.value) with - | V.Literal lv0, V.Literal lv1 -> + | V.VLiteral lv0, V.VLiteral lv1 -> if lv0 = lv1 then v1 else M.match_distinct_literals ty lv0 lv1 - | V.Adt av0, V.Adt av1 -> + | V.VAdt av0, V.VAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in let field_values = List.map (fun (f0, f1) -> match_rec f0 f1) fields in let value : V.value = - V.Adt { variant_id = av0.variant_id; field_values } + V.VAdt { variant_id = av0.variant_id; field_values } in { V.value; ty = v1.V.ty } else ( @@ -393,7 +397,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : V.typed_value = - mk_fresh_symbolic_typed_value_from_ety V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty let match_distinct_adts (ty : T.ety) (adt0 : V.adt_value) (adt1 : V.adt_value) : V.typed_value = @@ -422,7 +426,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct check_loans false adt1.field_values; (* No borrows, no loans: we can introduce a symbolic value *) - mk_fresh_symbolic_typed_value_from_ety V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty let match_shared_borrows _ (ty : T.ety) (bid0 : V.borrow_id) (bid1 : V.borrow_id) : V.borrow_id = @@ -439,12 +443,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate a fresh symbolic value for the shared value *) let _, bv_ty, kind = ty_as_ref ty in - let sv = mk_fresh_symbolic_typed_value_from_ety V.LoopJoin bv_ty in - - let borrow_ty = - mk_ref_ty (T.Var rid) (ety_no_regions_to_rty bv_ty) kind + let sv = + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty in + let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + (* Generate the avalues for the abstraction *) let mk_aborrow (bid : V.borrow_id) : V.typed_avalue = let value = V.ABorrow (V.ASharedBorrow bid) in @@ -453,10 +457,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in let loan = - V.ASharedLoan - ( V.BorrowId.Set.singleton bid2, - sv, - mk_aignored (ety_no_regions_to_rty bv_ty) ) + V.ASharedLoan (V.BorrowId.Set.singleton bid2, sv, mk_aignored bv_ty) in (* Note that an aloan has a borrow type *) let loan = { V.value = V.ALoan loan; ty = borrow_ty } in @@ -542,8 +543,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let nbid = C.fresh_borrow_id () in let kind = T.Mut in - let bv_ty = ety_no_regions_to_rty bv.V.ty in - let borrow_ty = mk_ref_ty (T.Var rid) bv_ty kind in + let bv_ty = bv.V.ty in + assert (ty_no_regions bv_ty); + let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in let borrow_av = let ty = borrow_ty in @@ -588,21 +590,22 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate a fresh symbolic value for the borrowed value *) let _, bv_ty, kind = ty_as_ref ty in - let sv = mk_fresh_symbolic_typed_value_from_ety V.LoopJoin bv_ty in - - let borrow_ty = - mk_ref_ty (T.Var rid) (ety_no_regions_to_rty bv_ty) kind + let sv = + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty in + let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + (* Generate the avalues for the abstraction *) let mk_aborrow (bid : V.borrow_id) (bv : V.typed_value) : V.typed_avalue = - let bv_ty = ety_no_regions_to_rty bv.V.ty in + let bv_ty = bv.V.ty in + assert (ty_no_regions bv_ty); let value = V.ABorrow (V.AMutBorrow (bid, mk_aignored bv_ty)) in { V.value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in - let loan = V.AMutLoan (bid2, mk_aignored (ety_no_regions_to_rty bv_ty)) in + let loan = V.AMutLoan (bid2, mk_aignored bv_ty) in (* Note that an aloan has a borrow type *) let loan = { V.value = V.ALoan loan; ty = borrow_ty } in @@ -832,17 +835,17 @@ struct let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with - | T.Static, T.Static -> r1 - | Var rid0, Var rid1 -> + | T.RStatic, T.RStatic -> r1 + | RVar rid0, RVar rid1 -> let rid = match_rid rid0 rid1 in - Var rid + RVar rid | _ -> raise (Distinct "match_rtys") in match_types match_distinct_types match_regions ty0 ty1 let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : V.typed_value = - mk_fresh_symbolic_typed_value_from_ety V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty let match_distinct_adts (_ty : T.ety) (_adt0 : V.adt_value) (_adt1 : V.adt_value) : V.typed_value = @@ -982,7 +985,7 @@ struct (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " ^ V.BorrowId.to_string id0 ^ "\n- id1: " ^ V.BorrowId.to_string id1 - ^ "\n- ty: " ^ rty_to_string S.ctx ty ^ "\n- av: " + ^ "\n- ty: " ^ PA.ty_to_string S.ctx ty ^ "\n- av: " ^ typed_avalue_to_string S.ctx av)); let id = match_loan_id id0 id1 in @@ -1153,8 +1156,8 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n\n")); match (env0, env1) with - | ( C.Var (C.DummyBinder b0, v0) :: env0', - C.Var (C.DummyBinder b1, v1) :: env1' ) -> + | ( C.EBinding (C.BDummy b0, v0) :: env0', + C.EBinding (C.BDummy b1, v1) :: env1' ) -> (* Sanity check: if the dummy value is an old value, the bindings must be the same and their values equal (and the borrows/loans/symbolic *) if C.DummyVarId.Set.mem b0 fixed_ids.dids then ( @@ -1168,14 +1171,14 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) are the identity actually) *) let _ = M.match_typed_values ctx v0 v1 in match_envs env0' env1' - | C.Var (C.VarBinder b0, v0) :: env0', C.Var (C.VarBinder b1, v1) :: env1' + | C.EBinding (C.BVar b0, v0) :: env0', C.EBinding (C.BVar b1, v1) :: env1' -> assert (b0 = b1); (* Match the values *) let _ = M.match_typed_values ctx v0 v1 in (* Continue *) match_envs env0' env1' - | C.Abs abs0 :: env0', C.Abs abs1 :: env1' -> + | C.EAbs abs0 :: env0', C.EAbs abs1 :: env1' -> log#ldebug (lazy "match_ctxs: match_envs: matching abs"); (* Same as for the dummy values: there are two cases *) if V.AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( @@ -1211,7 +1214,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) let env1 = List.rev ctx1.env in let env0, env1 = match (env0, env1) with - | C.Frame :: env0, C.Frame :: env1 -> (env0, env1) + | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in @@ -1275,7 +1278,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (* Remove the abstractions *) let filter (ee : C.env_elem) : bool = - match ee with Var _ -> true | Abs _ | Frame -> false + match ee with EBinding _ -> true | EAbs _ | EFrame -> false in let filt_src_env = List.filter filter filt_src_env in let filt_tgt_env = List.filter filter filt_tgt_env in @@ -1304,11 +1307,11 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) List.iter (fun (var0, var1) -> match (var0, var1) with - | C.Var (C.DummyBinder b0, v0), C.Var (C.DummyBinder b1, v1) -> + | C.EBinding (C.BDummy b0, v0), C.EBinding (C.BDummy b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () - | C.Var (C.VarBinder b0, v0), C.Var (C.VarBinder b1, v1) -> + | C.EBinding (C.BVar b0, v0), C.EBinding (C.BVar b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () @@ -1392,7 +1395,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) ^ eval_ctx_to_string_no_filter filt_src_ctx ^ "\n\n- new_absl:\n" ^ eval_ctx_to_string - { src_ctx with C.env = List.map (fun abs -> C.Abs abs) new_absl } + { src_ctx with C.env = List.map (fun abs -> C.EAbs abs) new_absl } ^ "\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- fp_bl_maps:\n" ^ show_borrow_loan_corresp fp_bl_maps ^ "\n\n- src_to_tgt_maps: " @@ -1585,7 +1588,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) end in let new_absl = List.map (visit_src#visit_abs ()) new_absl in - let new_absl = List.map (fun abs -> C.Abs abs) new_absl in + let new_absl = List.map (fun abs -> C.EAbs abs) new_absl in (* Add the abstractions from the target context to the source context *) let nenv = List.append new_absl tgt_ctx.env in diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 2a277c91..728e5226 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -97,8 +97,8 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) (* Match on the projection element and the value *) match (pe, v.V.value, v.V.ty) with | ( Field ((ProjAdt (_, _) as proj_kind), field_id), - V.Adt adt, - T.Adt (type_id, _) ) -> ( + V.VAdt adt, + T.TAdt (type_id, _) ) -> ( (* Check consistency *) (match (proj_kind, type_id) with | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> @@ -114,11 +114,11 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let nvalues = T.FieldId.update_nth adt.field_values field_id res.updated in - let nadt = V.Adt { adt with V.field_values = nvalues } in + let nadt = V.VAdt { adt with V.field_values = nvalues } in let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _) -> ( + | Field (ProjTuple arity, field_id), V.VAdt adt, T.TAdt (T.Tuple, _) -> ( assert (arity = List.length adt.field_values); let fv = T.FieldId.nth adt.field_values field_id in (* Project *) @@ -129,7 +129,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let nvalues = T.FieldId.update_nth adt.field_values field_id res.updated in - let ntuple = V.Adt { adt with field_values = nvalues } in + let ntuple = V.VAdt { adt with field_values = nvalues } in let updated = { v with value = ntuple } in Ok (ctx, { res with updated }) (* If we reach Bottom, it may mean we need to expand an uninitialized @@ -142,8 +142,8 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) Error (FailSymbolic (1 + List.length p', sp)) (* Box dereferencement *) | ( DerefBox, - Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _) ) -> ( + VAdt { variant_id = None; field_values = [ bv ] }, + T.TAdt (T.TAssumed T.TBox, _) ) -> ( (* We allow moving outside of boxes. In practice, this kind of * manipulations should happen only inside unsafe code, so * it shouldn't happen due to user code, and we leverage it @@ -156,7 +156,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) { v with value = - V.Adt { variant_id = None; field_values = [ res.updated ] }; + V.VAdt { variant_id = None; field_values = [ res.updated ] }; } in Ok (ctx, { res with updated = nv })) @@ -248,7 +248,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) in Ok (ctx, { res with updated = nv }) else Error (FailSharedLoan bids)) - | (_, (V.Literal _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> + | (_, (V.VLiteral _ | V.VAdt _ | V.Bottom | V.Borrow _), _) as r -> let pe, v, ty = r in let pe = "- pe: " ^ E.show_projection_elem pe in let v = "- v:\n" ^ V.show_value v in @@ -357,7 +357,8 @@ let write_place (access : access_kind) (p : E.place) (nv : V.typed_value) let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.egeneric_args) : V.typed_value = + (generics : T.generic_args) : V.typed_value = + assert (TypesUtils.generic_args_only_erased_regions generics); (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list @@ -370,17 +371,17 @@ let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) in (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in - let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, generics) in + let av = V.VAdt { variant_id = opt_variant_id; field_values = fields } in + let ty = T.TAdt (T.AdtId def_id, generics) in { V.value = av; V.ty } let compute_expanded_bottom_tuple_value (field_types : T.ety list) : V.typed_value = (* Generate the field values *) let fields = List.map mk_bottom field_types in - let v = V.Adt { variant_id = None; field_values = fields } in + let v = V.VAdt { variant_id = None; field_values = fields } in let generics = TypesUtils.mk_generic_args [] field_types [] [] in - let ty = T.Adt (T.Tuple, generics) in + let ty = T.TAdt (T.Tuple, generics) in { V.value = v; V.ty } (** Auxiliary helper to expand {!V.Bottom} values. @@ -432,12 +433,12 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) match (pe, ty) with (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', generics) ) -> + T.TAdt (T.AdtId def_id', generics) ) -> assert (def_id = def_id'); compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics (* Tuples *) | ( Field (ProjTuple arity, _), - T.Adt + T.TAdt ( T.Tuple, { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) -> diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index 0ff8063f..a493ad69 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -55,12 +55,15 @@ val write_place : *) val compute_expanded_bottom_tuple_value : T.ety list -> V.typed_value -(** Compute an expanded ADT ⊥ value *) +(** Compute an expanded ADT ⊥ value. + + The types in the generics should use erased regions. + *) val compute_expanded_bottom_adt_value : C.eval_ctx -> T.TypeDeclId.id -> T.VariantId.id option -> - T.egeneric_args -> + T.generic_args -> V.typed_value (** Drop (end) outer loans at a given place, which should be seen as an l-value diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 9e0c2b75..70a77be5 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -12,20 +12,21 @@ open InterpreterBorrowsCore (** The local logger *) let log = L.projectors_log +(** [ty] shouldn't contain erased regions *) let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) (regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : V.abstract_shared_borrows = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every + (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in - assert (ety = v.V.ty); + assert (ty_is_rty ty && ety = v.V.ty); (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then [] else match (v.V.value, ty) with - | V.Literal _, T.Literal _ -> [] - | V.Adt adt, T.Adt (id, generics) -> + | V.VLiteral _, T.TLiteral _ -> [] + | V.VAdt adt, T.TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics @@ -97,14 +98,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in - assert (ety = v.V.ty); + assert (ty_is_rty ty && ety = v.V.ty); (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } else let value : V.avalue = match (v.V.value, ty) with - | V.Literal _, T.Literal _ -> V.AIgnored - | V.Adt adt, T.Adt (id, generics) -> + | V.VLiteral _, T.TLiteral _ -> V.AIgnored + | V.VAdt adt, T.TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics @@ -208,10 +209,10 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) let rset2 = regions in log#ldebug (lazy - ("projections_intersect:" ^ "\n- ty1: " ^ rty_to_string ctx ty1 - ^ "\n- rset1: " + ("projections_intersect:" ^ "\n- ty1: " + ^ PA.ty_to_string ctx ty1 ^ "\n- rset1: " ^ T.RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ rty_to_string ctx ty2 ^ "\n- rset2: " + ^ "\n- ty2: " ^ PA.ty_to_string ctx ty2 ^ "\n- rset2: " ^ T.RegionId.Set.to_string None rset2 ^ "\n")); assert (not (projections_intersect ty1 rset1 ty2 rset2))); @@ -221,7 +222,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (lazy ("apply_proj_borrows: unexpected inputs:\n- input value: " ^ typed_value_to_string ctx v - ^ "\n- proj rty: " ^ rty_to_string ctx ty)); + ^ "\n- proj rty: " ^ PA.ty_to_string ctx ty)); raise (Failure "Unreachable") in { V.value; V.ty } @@ -231,12 +232,12 @@ let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) let ty = Subst.erase_regions sv.V.sv_ty in let value = match see with - | SeLiteral cv -> V.Literal cv + | SeLiteral cv -> V.VLiteral cv | SeAdt (variant_id, field_values) -> let field_values = List.map mk_typed_value_from_symbolic_value field_values in - V.Adt { V.variant_id; V.field_values } + V.VAdt { V.variant_id; V.field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic reference expansion") in @@ -265,10 +266,10 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) * contain regions which we will project *) assert (ty_has_regions_in_set regions original_sv_ty); (* Match *) - let (value, ty) : V.avalue * T.rty = + let (value, ty) : V.avalue * T.ty = match (see, original_sv_ty) with - | SeLiteral _, T.Literal _ -> (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _generics) -> + | SeLiteral _, T.TLiteral _ -> (V.AIgnored, original_sv_ty) + | SeAdt (variant_id, field_values), T.TAdt (_id, _generics) -> (* Project over the field values *) let field_values = List.map @@ -493,9 +494,11 @@ let prepare_reborrows (config : C.config) (allow_reborrows : bool) : in (fresh_reborrow, apply_registered_reborrows) +(** [ty] shouldn't have erased regions *) let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : C.eval_ctx * V.typed_avalue = + assert (ty_is_rty ty); let check_symbolic_no_ended = true in let allow_reborrows = true in (* Prepare the reborrows *) diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index bcc3dee2..7cee9ee7 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -16,7 +16,7 @@ open InterpreterBorrowsCore [regions] [ancestor_regions] [see] - [original_sv_ty] + [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : T.RegionId.Set.t -> @@ -121,8 +121,8 @@ val apply_proj_borrows : - [regions]: the regions to project - [ancestors_regions] - [v]: the value on which to apply the projection - - [ty]: the type (with regions) to use for the projection - + - [ty]: the type (with regions) to use for the projection (shouldn't have + erased regions) *) val apply_proj_borrows_on_input_value : C.config -> diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index e0c4703b..cdcea2cc 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -149,7 +149,7 @@ let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : let eval_assert cf (v : V.typed_value) : m_fun = fun ctx -> match v.value with - | Literal (Bool b) -> + | VLiteral (VBool b) -> (* Branch *) if b = assertion.expected then cf Unit ctx else cf Panic ctx | _ -> @@ -172,26 +172,26 @@ let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = (* Evaluate the assertion *) let eval_assert cf (v : V.typed_value) : m_fun = fun ctx -> - assert (v.ty = T.Literal PV.Bool); + assert (v.ty = T.TLiteral PV.TBool); (* We make a choice here: we could completely decouple the concrete and * symbolic executions here but choose not to. In the case where we * know the concrete value of the boolean we test, we use this value * even if we are in symbolic mode. Note that this case should be * extremely rare... *) match v.value with - | Literal (Bool _) -> + | VLiteral (VBool _) -> (* Delegate to the concrete evaluation function *) eval_assertion_concrete config assertion cf ctx | Symbolic sv -> assert (config.mode = C.SymbolicMode); - assert (sv.V.sv_ty = T.Literal PV.Bool); + assert (sv.V.sv_ty = T.TLiteral PV.TBool); (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code * (see below). *) let ctx = apply_symbolic_expansion_non_borrow config sv - (V.SeLiteral (PV.Bool true)) ctx + (V.SeLiteral (PV.VBool true)) ctx in (* Continue *) let expr = cf Unit ctx in @@ -232,7 +232,7 @@ let set_discriminant (config : C.config) (p : E.place) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> match (v.V.ty, v.V.value) with - | T.Adt ((T.AdtId _ as type_id), generics), V.Adt av -> ( + | T.TAdt ((T.AdtId _ as type_id), generics), V.VAdt av -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -254,7 +254,7 @@ let set_discriminant (config : C.config) (p : E.place) | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | T.Adt ((T.AdtId _ as type_id), generics), V.Bottom -> + | T.TAdt ((T.AdtId _ as type_id), generics), V.Bottom -> let bottom_v = match type_id with | T.AdtId def_id -> @@ -273,8 +273,8 @@ let set_discriminant (config : C.config) (p : E.place) * setting a discriminant should only be used to initialize a value, * or reset an already initialized value, really. *) raise (Failure "Unexpected value") - | _, (V.Adt _ | V.Bottom) -> raise (Failure "Inconsistent state") - | _, (V.Literal _ | V.Borrow _ | V.Loan _) -> + | _, (V.VAdt _ | V.Bottom) -> raise (Failure "Inconsistent state") + | _, (V.VLiteral _ | V.Borrow _ | V.Loan _) -> raise (Failure "Unexpected value") in (* Compose and apply *) @@ -282,7 +282,7 @@ let set_discriminant (config : C.config) (p : E.place) (** Push a frame delimiter in the context's environment *) let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = - { ctx with env = Frame :: ctx.env } + { ctx with env = EFrame :: ctx.env } (** Push a frame delimiter in the context's environment *) let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) @@ -291,7 +291,7 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) instantiation of an assumed function. *) let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) - (generics : T.egeneric_args) : T.ety = + (generics : T.generic_args) : T.ety = assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) match fid with @@ -305,17 +305,16 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) let sg = Assumed.get_assumed_fun_sig fid in (* Instantiate the return type *) (* There shouldn't be any reference to Self *) - let tr_self : T.erased_region T.trait_instance_id = - T.UnknownTrait __FUNCTION__ - in + let tr_self : T.trait_instance_id = T.UnknownTrait __FUNCTION__ in + let generics = Subst.generic_args_erase_regions generics in let { Subst.r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = - Subst.make_esubst_from_generics sg.generics generics tr_self + Subst.make_subst_from_generics sg.generics generics tr_self in let ty = Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self sg.output in - Assoc.ctx_normalize_ety ctx ty + Assoc.ctx_normalize_erase_ty ctx ty let move_return_value (config : C.config) (pop_return_value : bool) (cf : V.typed_value option -> m_fun) : m_fun = @@ -337,12 +336,12 @@ let pop_frame (config : C.config) (pop_return_value : bool) let rec list_locals env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.Abs _ :: env -> list_locals env - | C.Var (DummyBinder _, _) :: env -> list_locals env - | C.Var (VarBinder var, _) :: env -> + | C.EAbs _ :: env -> list_locals env + | C.EBinding (BDummy _, _) :: env -> list_locals env + | C.EBinding (BVar var, _) :: env -> let locals = list_locals env in if var.index <> ret_vid then var.index :: locals else locals - | C.Frame :: _ -> [] + | C.EFrame :: _ -> [] in let locals : E.VarId.id list = list_locals ctx.env in (* Debug *) @@ -392,11 +391,11 @@ let pop_frame (config : C.config) (pop_return_value : bool) let rec pop env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.Abs abs :: env -> C.Abs abs :: pop env - | C.Var (_, v) :: env -> + | C.EAbs abs :: env -> C.EAbs abs :: pop env + | C.EBinding (_, v) :: env -> let vid = C.fresh_dummy_var_id () in - C.Var (C.DummyBinder vid, v) :: pop env - | C.Frame :: env -> (* Stop here *) env + C.EBinding (C.BDummy vid, v) :: pop env + | C.EFrame :: env -> (* Stop here *) env in let cf_pop cf (ret_value : V.typed_value option) : m_fun = fun ctx -> @@ -416,7 +415,7 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : +let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) @@ -426,9 +425,9 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : | ( [], [ boxed_ty ], [], - Var (VarBinder input_var, input_value) - :: Var (_ret_var, _) - :: C.Frame :: _ ) -> + EBinding (BVar input_var, input_value) + :: EBinding (_ret_var, _) + :: C.EFrame :: _ ) -> (* Required type checking *) assert (input_value.V.ty = boxed_ty); @@ -441,9 +440,9 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : let cf_create cf (moved_input_value : V.typed_value) : m_fun = (* Create the box value *) let generics = TypesUtils.mk_generic_args_from_types [ boxed_ty ] in - let box_ty = T.Adt (T.Assumed T.Box, generics) in + let box_ty = T.TAdt (T.TAssumed T.TBox, generics) in let box_v = - V.Adt { variant_id = None; field_values = [ moved_input_value ] } + V.VAdt { variant_id = None; field_values = [ moved_input_value ] } in let box_v = mk_typed_value box_ty box_v in @@ -478,7 +477,7 @@ let eval_box_new_concrete (config : C.config) (generics : T.egeneric_args) : It thus updates the box value (by calling {!drop_value}) and updates the destination (by setting it to [()]). *) -let eval_box_free (config : C.config) (generics : T.egeneric_args) +let eval_box_free (config : C.config) (generics : T.generic_args) (args : E.operand list) (dest : E.place) : cm_fun = fun cf ctx -> match (generics.regions, generics.types, generics.const_generics, args) with @@ -657,7 +656,7 @@ let create_push_abstractions_from_abs_region_groups (* Add the avalues to the abstraction *) let abs = { abs with avalues } in (* Insert the abstraction in the context *) - let ctx = { ctx with env = Abs abs :: ctx.env } in + let ctx = { ctx with env = EAbs abs :: ctx.env } in (* Return *) ctx in @@ -768,7 +767,7 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) (* Treat the evaluation of the global as a call to the global body (without arguments) *) let func = { - E.func = FunId (Regular global.body_id); + E.func = FunId (FRegular global.body_id); generics = TypesUtils.mk_empty_generic_args; trait_and_method_generic_args = None; } @@ -779,9 +778,8 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) - let sval = - mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) - in + assert (ty_no_regions global.ty); + let sval = mk_fresh_symbolic_value V.Global global.ty in let cc = assign_to_place config (mk_typed_value_from_symbolic_value sval) dest in @@ -810,7 +808,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let cf_if (cf : st_m_fun) (op_v : V.typed_value) : m_fun = fun ctx -> match op_v.value with - | V.Literal (PV.Bool b) -> + | V.VLiteral (PV.VBool b) -> (* Evaluate the if and the branch body *) let cf_branch cf : m_fun = (* Branch *) @@ -838,7 +836,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let cf_switch (cf : st_m_fun) (op_v : V.typed_value) : m_fun = fun ctx -> match op_v.value with - | V.Literal (PV.Scalar sv) -> + | V.VLiteral (PV.VScalar sv) -> (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) @@ -893,7 +891,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let p_v = value_strip_shared_loans p_v in (* Match *) match p_v.value with - | V.Adt adt -> ( + | V.VAdt adt -> ( (* Evaluate the discriminant *) let dv = Option.get adt.variant_id in (* Find the branch, evaluate and continue *) @@ -931,9 +929,9 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun = fun cf ctx -> match call.func.func with - | FunId (Regular fid) -> + | FunId (FRegular fid) -> eval_transparent_function_call_concrete config fid call cf ctx - | FunId (Assumed fid) -> + | FunId (FAssumed fid) -> (* Continue - note that we do as if the function call has been successful, * by giving {!Unit} to the continuation, because we place us in the case * where we haven't panicked. Of course, the translation needs to take the @@ -944,9 +942,9 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun = match call.func.func with - | FunId (Regular _) | TraitMethod _ -> + | FunId (FRegular _) | TraitMethod _ -> eval_transparent_function_call_symbolic config call - | FunId (Assumed fid) -> eval_assumed_function_call_symbolic config fid call + | FunId (FAssumed fid) -> eval_assumed_function_call_symbolic config fid call (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) and eval_transparent_function_call_concrete (config : C.config) @@ -975,7 +973,7 @@ and eval_transparent_function_call_concrete (config : C.config) (* There shouldn't be any reference to Self *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = - Subst.make_esubst_from_generics def.A.signature.generics generics tr_self + Subst.make_subst_from_generics def.A.signature.generics generics tr_self in let locals, body_st = Subst.fun_body_substitute_in_body subst body in @@ -1106,13 +1104,13 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) *) let func, generics, def, inst_sg = match call.func.func with - | FunId (Regular fid) -> + | FunId (FRegular fid) -> let def = C.ctx_lookup_fun_decl ctx fid in log#ldebug (lazy ("fun call:\n- call: " ^ call_to_string ctx call ^ "\n- call.generics:\n" - ^ egeneric_args_to_string ctx call.func.generics + ^ PA.generic_args_to_string ctx call.func.generics ^ "\n- def.signature:\n" ^ fun_sig_to_string ctx def.A.signature)); let tr_self = T.UnknownTrait __FUNCTION__ in @@ -1120,7 +1118,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) instantiate_fun_sig ctx call.func.generics tr_self def.A.signature in (call.func.func, call.func.generics, def, inst_sg) - | FunId (Assumed _) -> + | FunId (FAssumed _) -> (* Unreachable: must be a transparent function *) raise (Failure "Unreachable") | TraitMethod (trait_ref, method_name, _) -> ( @@ -1128,9 +1126,9 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("trait method call:\n- call: " ^ call_to_string ctx call ^ "\n- method name: " ^ method_name ^ "\n- call.generics:\n" - ^ egeneric_args_to_string ctx call.func.generics + ^ PA.generic_args_to_string ctx call.func.generics ^ "\n- trait and method generics:\n" - ^ egeneric_args_to_string ctx + ^ PA.generic_args_to_string ctx (Option.get call.func.trait_and_method_generic_args))); (* When instantiating, we need to group the generics for the trait ref and the method *) @@ -1155,9 +1153,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (* This is a required method *) let method_def = C.ctx_lookup_fun_decl ctx id in (* Instantiate *) - let tr_self = - T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) - in + let tr_self = T.TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature @@ -1168,7 +1164,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) which implements the method. In order to do this properly, we also need to update the generics. *) - let func = E.FunId (Regular id) in + let func = E.FunId (FRegular id) in (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* @@ -1210,13 +1206,11 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("provided method call:" ^ "\n- method name: " ^ method_name ^ "\n- all_generics:\n" - ^ egeneric_args_to_string ctx all_generics + ^ PA.generic_args_to_string ctx all_generics ^ "\n- parent params info: " ^ Print.option_to_string A.show_params_info method_def.signature.parent_params_info)); - let tr_self = - T.TraitRef (etrait_ref_no_regions_to_gr_trait_ref trait_ref) - in + let tr_self = T.TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx all_generics tr_self method_def.A.signature @@ -1243,10 +1237,6 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); (* Instantiate *) let tr_self = T.TraitRef trait_ref in - let tr_self = - TypesUtils.etrait_instance_id_no_regions_to_gr_trait_instance_id - tr_self - in let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature in @@ -1271,7 +1261,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) *) and eval_function_call_symbolic_from_inst_sig (config : C.config) (fid : A.fun_id_or_trait_method_ref) (inst_sg : A.inst_fun_sig) - (generics : T.egeneric_args) (args : E.operand list) (dest : E.place) : + (generics : T.generic_args) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> log#ldebug @@ -1281,7 +1271,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) ^ "\n- inst_sg:\n" ^ inst_fun_sig_to_string ctx inst_sg ^ "\n- call.generics:\n" - ^ egeneric_args_to_string ctx generics + ^ PA.generic_args_to_string ctx generics ^ "\n- args:\n" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "\n- dest:\n" ^ place_to_string ctx dest)); @@ -1454,7 +1444,7 @@ and eval_assumed_function_call_symbolic (config : C.config) in (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config (FunId (Assumed fid)) + eval_function_call_symbolic_from_inst_sig config (FunId (FAssumed fid)) inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 6e08e553..6f62b577 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -31,8 +31,6 @@ let get_cf_ctx_no_synth (f : cm_fun) (ctx : C.eval_ctx) : C.eval_ctx = let eval_ctx_to_string_no_filter = Print.Contexts.eval_ctx_to_string_no_filter let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string -let ety_to_string = PA.ety_to_string -let rty_to_string = PA.rty_to_string let symbolic_value_to_string = PA.symbolic_value_to_string let borrow_content_to_string = PA.borrow_content_to_string let loan_content_to_string = PA.loan_content_to_string @@ -43,8 +41,6 @@ let typed_value_to_string = PA.typed_value_to_string let typed_avalue_to_string = PA.typed_avalue_to_string let place_to_string = PA.place_to_string let operand_to_string = PA.operand_to_string -let egeneric_args_to_string = PA.egeneric_args_to_string -let rtrait_instance_id_to_string = PA.rtrait_instance_id_to_string let fun_sig_to_string = PA.fun_sig_to_string let inst_fun_sig_to_string = PA.inst_fun_sig_to_string @@ -66,8 +62,7 @@ let abs_to_string ctx = PA.abs_to_string ctx "" " " let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = sv0.V.sv_id = sv1.V.sv_id -let mk_var (index : E.VarId.id) (name : string option) (var_ty : T.ety) : A.var - = +let mk_var (index : E.VarId.id) (name : string option) (var_ty : T.ty) : A.var = { A.index; name; var_ty } (** Small helper - TODO: move *) @@ -75,25 +70,32 @@ let mk_place_from_var_id (var_id : E.VarId.id) : E.place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.rty) : - V.symbolic_value = +let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.ty) : V.symbolic_value + = + (* Sanity check *) + assert (ty_is_rty ty); let sv_id = C.fresh_symbolic_value_id () in let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in svalue +let mk_fresh_symbolic_value_from_no_regions_ty (sv_kind : V.sv_kind) (ty : T.ty) + : V.symbolic_value = + assert (ty_no_regions ty); + mk_fresh_symbolic_value sv_kind ty + (** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.rty) : +let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.ty) : V.typed_value = + assert (ty_is_rty rty); let ty = Subst.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value sv_kind rty in let value = V.Symbolic value in { V.value; V.ty } -(** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value_from_ety (sv_kind : V.sv_kind) (ety : T.ety) : - V.typed_value = - let ty = TypesUtils.ety_no_regions_to_rty ety in +let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : V.sv_kind) + (ty : T.ty) : V.typed_value = + assert (ty_no_regions ty); mk_fresh_symbolic_typed_value sv_kind ty (** Create a typed value from a symbolic value. *) @@ -122,7 +124,8 @@ let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) (** Create a borrows projector from a symbolic value *) let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) (proj_ty : T.rty) : V.aproj = + (svalue : V.symbolic_value) (proj_ty : T.ty) : V.aproj = + assert (ty_is_rty proj_ty); if ty_has_regions_in_set proj_regions proj_ty then V.AProjBorrows (svalue, proj_ty) else V.AIgnoredProjBorrows @@ -193,7 +196,7 @@ exception FoundGBorrowContent of g_borrow_content exception FoundGLoanContent of g_loan_content (** Utility exception *) -exception FoundAProjBorrows of V.symbolic_value * T.rty +exception FoundAProjBorrows of V.symbolic_value * T.ty let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : bool = @@ -235,7 +238,7 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : *) let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) (s : V.symbolic_value) : bool = - let regions = rty_regions s.V.sv_ty in + let regions = ty_regions s.V.sv_ty in not (T.RegionId.Set.disjoint regions ended_regions) (** Check if a {!type:V.value} contains [⊥]. @@ -435,7 +438,7 @@ let initialize_eval_context (ctx : C.decls_ctx) T.ConstGenericVarId.Map.of_list (List.map (fun (cg : T.const_generic_var) -> - let ty = TypesUtils.ety_no_regions_to_rty (T.Literal cg.ty) in + let ty = T.TLiteral cg.ty in let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in (cg.index, cv)) const_generic_vars) @@ -450,28 +453,27 @@ let initialize_eval_context (ctx : C.decls_ctx) C.type_vars; C.const_generic_vars; C.const_generic_vars_map; - C.norm_trait_etypes = C.ETraitTypeRefMap.empty (* Empty for now *); - C.norm_trait_rtypes = C.RTraitTypeRefMap.empty (* Empty for now *); - C.norm_trait_stypes = C.STraitTypeRefMap.empty (* Empty for now *); - C.env = [ C.Frame ]; + C.norm_trait_types = C.TraitTypeRefMap.empty (* Empty for now *); + C.env = [ C.EFrame ]; C.ended_regions = T.RegionId.Set.empty; } (** Instantiate a function signature, introducing **fresh** abstraction ids and region ids. This is mostly used in preparation of function calls (when evaluating in symbolic mode). - - Note: there are no region parameters, because they should be erased. *) -let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = +let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) + (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = log#ldebug (lazy ("instantiate_fun_sig:" ^ "\n- generics: " - ^ egeneric_args_to_string ctx generics + ^ PA.generic_args_to_string ctx generics ^ "\n- tr_self: " - ^ rtrait_instance_id_to_string ctx tr_self + ^ PA.trait_instance_id_to_string ctx tr_self ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); + (* Erase the regions in the generics we use for the instantiation *) + let generics = Subst.generic_args_erase_regions generics in + let tr_self = Subst.trait_instance_id_erase_regions tr_self in (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = @@ -492,29 +494,20 @@ let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.egeneric_args) (* Generate fresh regions and their substitutions *) let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * {!rty} types (not {!ety}). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty generics.types in - let tsubst = Subst.make_type_subst_from_vars sg.generics.types rtype_params in + Note that for now we don't support instantiating the type parameters with + types containing regions. *) + assert (List.for_all TypesUtils.ty_no_regions generics.types); + assert (TypesUtils.trait_instance_id_no_regions tr_self); + let tsubst = + Subst.make_type_subst_from_vars sg.generics.types generics.types + in let cgsubst = Subst.make_const_generic_subst_from_vars sg.generics.const_generics generics.const_generics in - (* TODO: something annoying with the trait ref subst: we need to use region - types, but the arguments use erased regions. For now we use the fact - that no regions should appear inside. In the future: we should merge - ety and rty. *) - let trait_refs = - List.map TypesUtils.etrait_ref_no_regions_to_gr_trait_ref - generics.trait_refs - in let tr_subst = - Subst.make_trait_subst_from_clauses sg.generics.trait_clauses trait_refs + Subst.make_trait_subst_from_clauses sg.generics.trait_clauses + generics.trait_refs in (* Substitute the signature *) let inst_sig = diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 5c8ec7af..01de6fd0 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -138,13 +138,13 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = object inherit [_] C.iter_eval_ctx as super - method! visit_Var _ binder v = + method! visit_EBinding _ binder v = let inside_abs = false in - super#visit_Var inside_abs binder v + super#visit_EBinding inside_abs binder v - method! visit_Abs _ abs = + method! visit_EAbs _ abs = let inside_abs = true in - super#visit_Abs inside_abs abs + super#visit_EAbs inside_abs abs method! visit_loan_content inside_abs lc = (* Register the loan *) @@ -380,8 +380,8 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = let check_literal_type (cv : V.literal) (ty : PV.literal_type) : unit = match (cv, ty) with - | PV.Scalar sv, PV.Integer int_ty -> assert (sv.int_ty = int_ty) - | PV.Bool _, PV.Bool | PV.Char _, PV.Char -> () + | PV.VScalar sv, PV.TInteger int_ty -> assert (sv.int_ty = int_ty) + | PV.VBool _, PV.TBool | PV.VChar _, PV.TChar -> () | _ -> raise (Failure "Erroneous typing") let check_typing_invariant (ctx : C.eval_ctx) : unit = @@ -389,10 +389,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = * of the shape [& (mut) T] where they should have type [T]... * This messes a bit the type invariant checks when checking the * children. In order to isolate the problem (for future modifications) - * we introduce function, so that we can easily spot all the involved + * we introduce this function, so that we can easily spot all the involved * places. * *) - let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = + let aloan_get_expected_child_type (ty : T.ty) : T.ty = let _, ty, _ = ty_get_ref ty in ty in @@ -402,12 +402,24 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = inherit [_] C.iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs + method! visit_EBinding info binder v = + (* We also check that the regions are erased *) + assert (ty_is_ety v.ty); + super#visit_EBinding info binder v + + method! visit_symbolic_value inside_abs v = + (* Check that the types have regions *) + assert (ty_is_rty v.sv_ty); + super#visit_symbolic_value inside_abs v + method! visit_typed_value info tv = + (* Check that the types have erased regions *) + assert (ty_is_ety tv.ty); (* Check the current pair (value, type) *) (match (tv.V.value, tv.V.ty) with - | V.Literal cv, T.Literal ty -> check_literal_type cv ty + | V.VLiteral cv, T.TLiteral ty -> check_literal_type cv ty (* ADT case *) - | V.Adt av, T.Adt (T.AdtId def_id, generics) -> + | V.VAdt av, T.TAdt (T.AdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in @@ -430,10 +442,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values field_types in List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.Adt av, T.Adt (T.Tuple, generics) -> + | V.VAdt av, T.TAdt (T.Tuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); assert (av.V.variant_id = None); @@ -443,10 +455,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.Adt av, T.Adt (T.Assumed aty_id, generics) -> ( + | V.VAdt av, T.TAdt (T.TAssumed aty_id, generics) -> ( assert (av.V.variant_id = None); match ( aty_id, @@ -456,9 +468,9 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = generics.const_generics ) with (* Box *) - | T.Box, [ inner_value ], [], [ inner_ty ], [] -> + | T.TBox, [ inner_value ], [], [ inner_ty ], [] -> assert (inner_value.V.ty = inner_ty) - | T.Array, inner_values, _, [ inner_ty ], [ cg ] -> + | T.TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) assert ( List.for_all @@ -471,7 +483,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = .value in assert (Z.of_int (List.length inner_values) = len) - | (T.Slice | T.Str), _, _, _, _ -> raise (Failure "Unexpected") + | (T.TSlice | T.TStr), _, _, _, _ -> raise (Failure "Unexpected") | _ -> raise (Failure "Erroneous type")) | V.Bottom, _ -> (* Nothing to check *) () | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( @@ -516,10 +528,12 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = * so the cost of maintenance should be pretty low. * *) method! visit_typed_avalue info atv = + (* Check that the types have regions *) + assert (ty_is_rty atv.ty); (* Check the current pair (value, type) *) (match (atv.V.value, atv.V.ty) with (* ADT case *) - | V.AAdt av, T.Adt (T.AdtId def_id, generics) -> + | V.AAdt av, T.TAdt (T.AdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in @@ -545,10 +559,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values field_types in List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.AAdt av, T.Adt (T.Tuple, generics) -> + | V.AAdt av, T.TAdt (T.Tuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); assert (av.V.variant_id = None); @@ -558,10 +572,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.V.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Assumed type case *) - | V.AAdt av, T.Adt (T.Assumed aty_id, generics) -> ( + | V.AAdt av, T.TAdt (T.TAssumed aty_id, generics) -> ( assert (av.V.variant_id = None); match ( aty_id, @@ -571,7 +585,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = generics.const_generics ) with (* Box *) - | T.Box, [ boxed_value ], [], [ boxed_ty ], [] -> + | T.TBox, [ boxed_value ], [], [ boxed_ty ], [] -> assert (boxed_value.V.ty = boxed_ty) | _ -> raise (Failure "Erroneous type")) | V.ABottom, _ -> (* Nothing to check *) () @@ -663,7 +677,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = ("Erroneous typing:" ^ "\n- raw value: " ^ V.show_typed_avalue atv ^ "\n- value: " ^ typed_avalue_to_string ctx atv - ^ "\n- type: " ^ rty_to_string ctx atv.V.ty)); + ^ "\n- type: " + ^ PA.ty_to_string ctx atv.V.ty)); raise (Failure "Erroneous typing")); (* Continue exploring to inspect the subterms *) super#visit_typed_avalue info atv @@ -674,7 +689,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = type proj_borrows_info = { abs_id : V.AbstractionId.id; regions : T.RegionId.Set.t; - proj_ty : T.rty; + proj_ty : T.rty; (** The regions shouldn't be erased *) as_shared_value : bool; (** True if the value is below a shared borrow *) } [@@deriving show] @@ -686,7 +701,7 @@ type proj_loans_info = { [@@deriving show] type sv_info = { - ty : T.rty; + ty : T.rty; (** The regions shouldn't be erased *) env_count : int; aproj_borrows : proj_borrows_info list; aproj_loans : proj_loans_info list; diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml index 2db859b2..9772671e 100644 --- a/compiler/LlbcAst.ml +++ b/compiler/LlbcAst.ml @@ -2,16 +2,13 @@ open Types open Values include Charon.LlbcAst -type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group -[@@deriving show] - -type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups -[@@deriving show] +type abs_region_group = AbstractionId.id g_region_group [@@deriving show] +type abs_region_groups = abs_region_group list [@@deriving show] (** A function signature, after instantiation *) type inst_fun_sig = { regions_hierarchy : abs_region_groups; - trait_type_constraints : rtrait_type_constraint list; + trait_type_constraints : trait_type_constraint list; inputs : rty list; output : rty; } diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 0ab4ed94..46b36851 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -4,14 +4,14 @@ include Charon.LlbcAstUtils let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : fun_sig = match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).signature - | Assumed aid -> Assumed.get_assumed_fun_sig aid + | FRegular id -> (FunDeclId.Map.find id fun_decls).signature + | FAssumed aid -> Assumed.get_assumed_fun_sig aid let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : Names.fun_name = match fun_id with - | Regular id -> (FunDeclId.Map.find id fun_decls).name - | Assumed aid -> Assumed.get_assumed_fun_name aid + | FRegular id -> (FunDeclId.Map.find id fun_decls).name + | FAssumed aid -> Assumed.get_assumed_fun_name aid (** Return the opaque declarations found in the crate, which are also *not builtin*. diff --git a/compiler/Print.ml b/compiler/Print.ml index 7f0d95ff..dd24767e 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -15,8 +15,7 @@ let bool_to_string (b : bool) : string = if b then "true" else "false" (** Pretty-printing for values *) module Values = struct type value_formatter = { - rvar_to_string : T.RegionVarId.id -> string; - r_to_string : T.RegionId.id -> string; + region_id_to_string : T.RegionId.id -> string; type_var_id_to_string : T.TypeVarId.id -> string; type_decl_id_to_string : T.TypeDeclId.id -> string; const_generic_var_id_to_string : T.ConstGenericVarId.id -> string; @@ -30,33 +29,9 @@ module Values = struct T.TypeDeclId.id -> T.VariantId.id option -> string list option; } - let value_to_etype_formatter (fmt : value_formatter) : PT.etype_formatter = + let value_to_type_formatter (fmt : value_formatter) : PT.type_formatter = { - PT.r_to_string = PT.erased_region_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - PT.global_decl_id_to_string = fmt.global_decl_id_to_string; - PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; - PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; - PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; - } - - let value_to_rtype_formatter (fmt : value_formatter) : PT.rtype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.r_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - PT.global_decl_id_to_string = fmt.global_decl_id_to_string; - PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; - PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; - PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; - } - - let value_to_stype_formatter (fmt : value_formatter) : PT.stype_formatter = - { - PT.r_to_string = PT.region_to_string fmt.rvar_to_string; + PT.region_id_to_string = fmt.region_id_to_string; PT.type_var_id_to_string = fmt.type_var_id_to_string; PT.type_decl_id_to_string = fmt.type_decl_id_to_string; PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; @@ -72,17 +47,17 @@ module Values = struct let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = "s@" ^ V.SymbolicValueId.to_string id - let symbolic_value_to_string (fmt : PT.rtype_formatter) - (sv : V.symbolic_value) : string = - symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty + let symbolic_value_to_string (fmt : PT.type_formatter) (sv : V.symbolic_value) + : string = + symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.ty_to_string fmt sv.sv_ty let symbolic_value_proj_to_string (fmt : value_formatter) - (sv : V.symbolic_value) (rty : T.rty) : string = + (sv : V.symbolic_value) (rty : T.ty) : string = + let ty_fmt = value_to_type_formatter fmt in symbolic_value_id_to_string sv.sv_id ^ " : " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) sv.sv_ty - ^ " <: " - ^ PT.ty_to_string (value_to_rtype_formatter fmt) rty + ^ PT.ty_to_string ty_fmt sv.sv_ty + ^ " <: " ^ PT.ty_to_string ty_fmt rty (* TODO: it may be a good idea to try to factorize this function with * typed_avalue_to_string. At some point we had done it, because [typed_value] @@ -90,18 +65,18 @@ module Values = struct * but then we removed this general type because it proved to be a bad idea. *) let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : string = - let ty_fmt : PT.etype_formatter = value_to_etype_formatter fmt in + let ty_fmt : PT.type_formatter = value_to_type_formatter fmt in match v.value with - | Literal cv -> PPV.literal_to_string cv - | Adt av -> ( + | VLiteral cv -> PPV.literal_to_string cv + | VAdt av -> ( let field_values = List.map (typed_value_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _) -> + | T.TAdt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _) -> + | T.TAdt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -123,11 +98,11 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _) -> ( + | T.TAdt (T.TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" - | Array, _ -> + | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" + | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" | _ -> @@ -136,7 +111,7 @@ module Values = struct | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty | Borrow bc -> borrow_content_to_string fmt bc | Loan lc -> loan_content_to_string fmt lc - | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s + | Symbolic s -> symbolic_value_to_string ty_fmt s and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : string = @@ -180,7 +155,7 @@ module Values = struct " (" ^ String.concat "," given_back ^ ") " in "⌊" - ^ symbolic_value_to_string (value_to_rtype_formatter fmt) sv + ^ symbolic_value_to_string (value_to_type_formatter fmt) sv ^ given_back ^ "⌋" | AProjBorrows (sv, rty) -> "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" @@ -195,17 +170,17 @@ module Values = struct let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : string = - let ty_fmt : PT.rtype_formatter = value_to_rtype_formatter fmt in + let ty_fmt : PT.type_formatter = value_to_type_formatter fmt in match v.value with | AAdt av -> ( let field_values = List.map (typed_avalue_to_string fmt) av.field_values in match v.ty with - | T.Adt (T.Tuple, _) -> + | T.TAdt (T.Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.Adt (T.AdtId def_id, _) -> + | T.TAdt (T.AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -227,10 +202,10 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.Adt (T.Assumed aty, _) -> ( + | T.TAdt (T.TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with - | Box, [ bv ] -> "@Box(" ^ bv ^ ")" + | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" | _ -> raise (Failure "Inconsistent value")) | _ -> raise (Failure "Inconsistent typed value")) | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty @@ -352,7 +327,7 @@ module Values = struct let inst_fun_sig_to_string (fmt : value_formatter) (sg : LlbcAst.inst_fun_sig) : string = (* TODO: print the trait type constraints? *) - let ty_fmt = value_to_rtype_formatter fmt in + let ty_fmt = value_to_type_formatter fmt in let ty_to_string = PT.ty_to_string ty_fmt in let inputs = @@ -376,23 +351,23 @@ module Contexts = struct let binder_to_string (bv : C.binder) : string = match bv with - | VarBinder b -> var_binder_to_string b - | DummyBinder bid -> dummy_var_id_to_string bid + | BVar b -> var_binder_to_string b + | BDummy bid -> dummy_var_id_to_string bid let env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) (ev : C.env_elem) : string = match ev with - | Var (var, tv) -> + | EBinding (var, tv) -> let bv = binder_to_string var in let ty = if with_var_types then - " : " ^ PT.ty_to_string (PV.value_to_etype_formatter fmt) tv.V.ty + " : " ^ PT.ty_to_string (PV.value_to_type_formatter fmt) tv.V.ty else "" in indent ^ bv ^ ty ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | Abs abs -> PV.abs_to_string fmt verbose indent indent_incr abs - | Frame -> raise (Failure "Can't print a Frame element") + | EAbs abs -> PV.abs_to_string fmt verbose indent indent_incr abs + | EFrame -> raise (Failure "Can't print a Frame element") let opt_env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) @@ -413,10 +388,10 @@ module Contexts = struct *) let filter_elem (ev : C.env_elem) : C.env_elem option = match ev with - | Var (VarBinder _, tv) -> + | EBinding (BVar _, tv) -> (* Not a dummy binding: check if the value is ⊥ *) if VU.is_bottom tv.value then None else Some ev - | Var (DummyBinder _, tv) -> + | EBinding (BDummy _, tv) -> (* Dummy binding: check if the value contains borrows or loans *) if VU.borrows_in_value tv || VU.loans_in_value tv then Some ev else None @@ -456,8 +431,7 @@ module Contexts = struct let ast_to_ctx_formatter (fmt : PA.ast_formatter) : ctx_formatter = { - PV.rvar_to_string = fmt.rvar_to_string; - PV.r_to_string = fmt.r_to_string; + PV.region_id_to_string = fmt.region_id_to_string; PV.type_var_id_to_string = fmt.type_var_id_to_string; PV.type_decl_id_to_string = fmt.type_decl_id_to_string; PV.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; @@ -473,22 +447,11 @@ module Contexts = struct let ast_to_value_formatter (fmt : PA.ast_formatter) : PV.value_formatter = ast_to_ctx_formatter fmt - let ctx_to_etype_formatter (fmt : ctx_formatter) : PT.etype_formatter = - PV.value_to_etype_formatter fmt - - let ctx_to_rtype_formatter (fmt : ctx_formatter) : PT.rtype_formatter = - PV.value_to_rtype_formatter fmt - - let ctx_to_stype_formatter (fmt : ctx_formatter) : PT.stype_formatter = - PV.value_to_stype_formatter fmt + let ctx_to_type_formatter (fmt : ctx_formatter) : PT.type_formatter = + PV.value_to_type_formatter fmt let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - let rvar_to_string r = - (* In theory we shouldn't use rvar_to_string, but it can happen - when printing definitions for instance... *) - T.RegionVarId.to_string r - in - let r_to_string r = PT.region_id_to_string r in + let region_id_to_string r = PT.region_id_to_string r in let type_var_id_to_string vid = (* The context may be invalid *) @@ -529,8 +492,7 @@ module Contexts = struct PT.type_ctx_to_adt_field_names_fun ctx.type_context.type_decls in { - rvar_to_string; - r_to_string; + region_id_to_string; type_var_id_to_string; type_decl_id_to_string; const_generic_var_id_to_string; @@ -566,8 +528,7 @@ module Contexts = struct in let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in { - rvar_to_string = ctx_fmt.PV.rvar_to_string; - r_to_string = ctx_fmt.PV.r_to_string; + region_id_to_string = ctx_fmt.PV.region_id_to_string; type_var_id_to_string = ctx_fmt.PV.type_var_id_to_string; type_decl_id_to_string = ctx_fmt.PV.type_decl_id_to_string; const_generic_var_id_to_string = ctx_fmt.PV.const_generic_var_id_to_string; @@ -593,7 +554,7 @@ module Contexts = struct match env with | [] -> if List.length curr_frame > 0 then curr_frame :: frames else frames - | Frame :: env' -> split_aux (curr_frame :: frames) [] env' + | EFrame :: env' -> split_aux (curr_frame :: frames) [] env' | ev :: env' -> split_aux frames (ev :: curr_frame) env' in let frames = split_aux [] [] env in @@ -613,9 +574,9 @@ module Contexts = struct List.iter (fun ev -> match ev with - | C.Var (DummyBinder _, _) -> num_dummies := !num_abs + 1 - | C.Var (VarBinder _, _) -> num_bindings := !num_bindings + 1 - | C.Abs _ -> num_abs := !num_abs + 1 + | C.EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 + | C.EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 + | C.EAbs _ -> num_abs := !num_abs + 1 | _ -> raise (Failure "Unreachable")) f; "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " @@ -645,77 +606,32 @@ module PC = Contexts (* local module *) (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) module EvalCtxLlbcAst = struct - let ety_to_string (ctx : C.eval_ctx) (t : T.ety) : string = + let ty_to_string (ctx : C.eval_ctx) (t : T.ty) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.ety_to_string fmt t - - let rty_to_string (ctx : C.eval_ctx) (t : T.rty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rty_to_string fmt t - - let sty_to_string (ctx : C.eval_ctx) (t : T.sty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in - PT.sty_to_string fmt t + let fmt = PC.ctx_to_type_formatter fmt in + PT.ty_to_string fmt t let generic_params_to_strings (ctx : C.eval_ctx) (x : T.generic_params) : string list * string list = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in + let fmt = PC.ctx_to_type_formatter fmt in PT.generic_params_to_strings fmt x - let egeneric_args_to_string (ctx : C.eval_ctx) (x : T.egeneric_args) : string - = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.egeneric_args_to_string fmt x - - let rgeneric_args_to_string (ctx : C.eval_ctx) (x : T.rgeneric_args) : string - = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rgeneric_args_to_string fmt x - - let sgeneric_args_to_string (ctx : C.eval_ctx) (x : T.sgeneric_args) : string - = + let generic_args_to_string (ctx : C.eval_ctx) (x : T.generic_args) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in - PT.sgeneric_args_to_string fmt x + let fmt = PC.ctx_to_type_formatter fmt in + PT.generic_args_to_string fmt x - let etrait_ref_to_string (ctx : C.eval_ctx) (x : T.etrait_ref) : string = + let trait_ref_to_string (ctx : C.eval_ctx) (x : T.trait_ref) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.etrait_ref_to_string fmt x + let fmt = PC.ctx_to_type_formatter fmt in + PT.trait_ref_to_string fmt x - let rtrait_ref_to_string (ctx : C.eval_ctx) (x : T.rtrait_ref) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rtrait_ref_to_string fmt x - - let strait_ref_to_string (ctx : C.eval_ctx) (x : T.strait_ref) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in - PT.strait_ref_to_string fmt x - - let etrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.etrait_instance_id) - : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_etype_formatter fmt in - PT.etrait_instance_id_to_string fmt x - - let rtrait_instance_id_to_string (ctx : C.eval_ctx) (x : T.rtrait_instance_id) - : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in - PT.rtrait_instance_id_to_string fmt x - - let strait_instance_id_to_string (ctx : C.eval_ctx) (x : T.strait_instance_id) - : string = + let trait_instance_id_to_string (ctx : C.eval_ctx) (x : T.trait_instance_id) : + string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_stype_formatter fmt in - PT.strait_instance_id_to_string fmt x + let fmt = PC.ctx_to_type_formatter fmt in + PT.trait_instance_id_to_string fmt x let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : string = @@ -743,7 +659,7 @@ module EvalCtxLlbcAst = struct let symbolic_value_to_string (ctx : C.eval_ctx) (sv : V.symbolic_value) : string = let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_rtype_formatter fmt in + let fmt = PC.ctx_to_type_formatter fmt in PV.symbolic_value_to_string fmt sv let typed_value_to_string (ctx : C.eval_ctx) (v : V.typed_value) : string = diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index ec75fcfd..cd156215 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -205,7 +205,7 @@ let type_id_to_string (fmt : type_formatter) (id : type_id) : string = match id with | AdtId id -> fmt.type_decl_id_to_string id | Tuple -> "" - | Assumed aty -> assumed_ty_to_string aty + | TAssumed aty -> assumed_ty_to_string aty (* TODO: duplicates Charon.PrintTypes.const_generic_to_string *) let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : @@ -217,12 +217,12 @@ let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = match ty with - | Adt (id, generics) -> ( + | TAdt (id, generics) -> ( match id with | Tuple -> let generics = generic_args_to_strings fmt false generics in "(" ^ String.concat " * " generics ^ ")" - | AdtId _ | Assumed _ -> + | AdtId _ | TAssumed _ -> let generics = generic_args_to_strings fmt true generics in let generics_s = if generics = [] then "" else " " ^ String.concat " " generics @@ -230,7 +230,7 @@ let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = let ty_s = type_id_to_string fmt id ^ generics_s in if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) | TypeVar tv -> fmt.type_var_id_to_string tv - | Literal lty -> literal_type_to_string lty + | TLiteral lty -> literal_type_to_string lty | Arrow (arg_ty, ret_ty) -> let ty = ty_to_string fmt true arg_ty ^ " -> " ^ ty_to_string fmt false ret_ty @@ -384,7 +384,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) match variant_id with | Some vid -> fmt.adt_variant_to_string def_id vid | None -> fmt.type_decl_id_to_string def_id) - | Assumed aty -> ( + | TAssumed aty -> ( (* Assumed type *) match aty with | State | Array | Slice | Str | RawPtr _ -> @@ -419,7 +419,7 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) match fields with | None -> FieldId.to_string field_id | Some fields -> FieldId.nth fields field_id) - | Assumed aty -> ( + | TAssumed aty -> ( (* Assumed type *) match aty with | State | Fuel | Array | Slice | Str -> @@ -437,10 +437,10 @@ let adt_g_value_to_string (fmt : value_formatter) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with - | Adt (Tuple, _) -> + | TAdt (Tuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | Adt (AdtId def_id, _) -> + | TAdt (AdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match variant_id with @@ -462,7 +462,7 @@ let adt_g_value_to_string (fmt : value_formatter) let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | Adt (Assumed aty, _) -> ( + | TAdt (TAssumed aty, _) -> ( (* Assumed type *) match aty with | State | RawPtr _ -> @@ -585,8 +585,8 @@ let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = | FromLlbc (fid, lp_id, rg_id) -> let f = match fid with - | FunId (Regular fid) -> fmt.fun_decl_id_to_string fid - | FunId (Assumed fid) -> llbc_assumed_fun_id_to_string fid + | FunId (FRegular fid) -> fmt.fun_decl_id_to_string fid + | FunId (FAssumed fid) -> llbc_assumed_fun_id_to_string fid | TraitMethod (trait_ref, method_name, _) -> let fmt = ast_to_type_formatter fmt in trait_ref_to_string fmt true trait_ref ^ "." ^ method_name @@ -664,7 +664,7 @@ let rec texpression_to_string (fmt : ast_formatter) (inside : bool) in let bl = if fields = [] then "" else "\n" ^ indent in "{" ^ s ^ String.concat "" fields ^ bl ^ "}" - | Assumed Array -> + | TAssumed Array -> let fields = List.map (fun (_, fe) -> diff --git a/compiler/Pure.ml b/compiler/Pure.ml index e6a3dab5..ffbd1f09 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -64,6 +64,8 @@ type mutability = Mut | Const [@@deriving show, ord] - [State]: the type of the state, when using state-error monads. Note that this state is opaque to Aeneas (the user can define it, or leave it as assumed) + + TODO: add a prefix "T" *) type assumed_ty = | State @@ -144,7 +146,7 @@ class virtual ['self] mapreduce_type_id_base = fun _ x -> (x, self#zero) end -type type_id = AdtId of type_decl_id | Tuple | Assumed of assumed_ty +type type_id = AdtId of type_decl_id | Tuple | TAssumed of assumed_ty [@@deriving show, ord, @@ -190,7 +192,6 @@ class ['self] iter_ty_base = object (_self : 'self) inherit [_] iter_type_id inherit! [_] T.iter_const_generic - inherit! [_] PV.iter_literal_type method visit_type_var_id : 'env -> type_var_id -> unit = fun _ _ -> () method visit_trait_decl_id : 'env -> trait_decl_id -> unit = fun _ _ -> () method visit_trait_impl_id : 'env -> trait_impl_id -> unit = fun _ _ -> () @@ -207,7 +208,6 @@ class ['self] map_ty_base = object (_self : 'self) inherit [_] map_type_id inherit! [_] T.map_const_generic - inherit! [_] PV.map_literal_type method visit_type_var_id : 'env -> type_var_id -> type_var_id = fun _ x -> x method visit_trait_decl_id : 'env -> trait_decl_id -> trait_decl_id = @@ -228,7 +228,6 @@ class virtual ['self] reduce_ty_base = object (self : 'self) inherit [_] reduce_type_id inherit! [_] T.reduce_const_generic - inherit! [_] PV.reduce_literal_type method visit_type_var_id : 'env -> type_var_id -> 'a = fun _ _ -> self#zero method visit_trait_decl_id : 'env -> trait_decl_id -> 'a = @@ -249,7 +248,6 @@ class virtual ['self] mapreduce_ty_base = object (self : 'self) inherit [_] mapreduce_type_id inherit! [_] T.mapreduce_const_generic - inherit! [_] PV.mapreduce_literal_type method visit_type_var_id : 'env -> type_var_id -> type_var_id * 'a = fun _ x -> (x, self#zero) @@ -270,7 +268,7 @@ class virtual ['self] mapreduce_ty_base = end type ty = - | Adt of type_id * generic_args + | TAdt of type_id * generic_args (** {!Adt} encodes ADTs and tuples and assumed types. TODO: what about the ended regions? (ADTs may be parameterized @@ -279,7 +277,7 @@ type ty = such "partial" ADTs. *) | TypeVar of type_var_id - | Literal of literal_type + | TLiteral of literal_type | Arrow of ty * ty | TraitType of trait_ref * generic_args * string (** The string is for the name of the associated type *) diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index f3e6cbe2..d62a028e 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -791,7 +791,7 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) let id0 = match id0 with | FunId fun_id -> fun_id - | TraitMethod (_, _, fun_decl_id) -> Regular fun_decl_id + | TraitMethod (_, _, fun_decl_id) -> FRegular fun_decl_id in LlbcAstUtils.lookup_fun_sig id0 ctx.fun_ctx.fun_decls in @@ -1527,7 +1527,7 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = * could have: [box_new f x]) * *) match fun_id with - | Fun (FromLlbc (FunId (Assumed aid), _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (FAssumed aid), _lp_id, rg_id)) -> ( match (aid, rg_id) with | BoxNew, _ -> assert (rg_id = None); @@ -1541,7 +1541,7 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ArrayRepeat | SliceLen ), _ ) -> super#visit_texpression env e) - | Fun (FromLlbc (FunId (Regular fid), _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> ( (* Lookup the function name *) let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in match @@ -2050,7 +2050,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : let inputs_set = VarId.Set.of_list (List.map var_get_id inputs_prefix) in assert (Option.is_some decl.loop_id); - let fun_id = (E.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.FRegular decl.def_id, decl.loop_id) in let set_used vid = used := List.map (fun (vid', b) -> (vid', b || vid = vid')) !used @@ -2134,7 +2134,7 @@ let filter_loop_inputs (transl : pure_fun_translation list) : (* We then apply the filtering to all the function definitions at once *) let filter_in_one (decl : fun_decl) : fun_decl = (* Filter the function signature *) - let fun_id = (E.Regular decl.def_id, decl.loop_id) in + let fun_id = (E.FRegular decl.def_id, decl.loop_id) in let decl = match FunLoopIdMap.find_opt fun_id !used_map with | None -> (* Nothing to filter *) decl diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index 2ad942bb..f8b5de6a 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -22,7 +22,7 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) (* "Regular" ADT *) let def = TypeDeclId.Map.find def_id type_decls in type_decl_get_instantiated_fields_types def variant_id generics - | Assumed aty -> ( + | TAssumed aty -> ( (* Assumed type *) match aty with | State -> @@ -63,8 +63,8 @@ type tc_ctx = { let check_literal (v : literal) (ty : literal_type) : unit = match (ty, v) with - | Integer int_ty, PV.Scalar sv -> assert (int_ty = sv.PV.int_ty) - | Bool, Bool _ | Char, Char _ -> () + | TInteger int_ty, PV.VScalar sv -> assert (int_ty = sv.PV.int_ty) + | TBool, VBool _ | TChar, VChar _ -> () | _ -> raise (Failure "Inconsistent type") let rec check_typed_pattern (ctx : tc_ctx) (v : typed_pattern) : tc_ctx = @@ -156,7 +156,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = let field_tys, adt_ty = destruct_arrows e.ty in assert (expected_field_tys = field_tys); match adt_ty with - | Adt (type_id, generics) -> + | TAdt (type_id, generics) -> assert (type_id = id.adt_id); assert (generics = qualif.generics) | _ -> raise (Failure "Unreachable"))) @@ -174,7 +174,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx scrut; match switch_body with | If (e_then, e_else) -> - assert (scrut.ty = Literal Bool); + assert (scrut.ty = TLiteral TBool); assert (e_then.ty = e.ty); assert (e_else.ty = e.ty); check_texpression ctx e_then; @@ -219,7 +219,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = assert (expected_field_ty = fe.ty); check_texpression ctx fe) supd.updates - | Assumed Array -> + | TAssumed Array -> let expected_field_ty = Collections.List.to_cons_nil adt_generics.types in diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 3aeabffe..5e46d551 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -64,14 +64,14 @@ let dest_arrow_ty (ty : ty) : ty * ty = let compute_literal_type (cv : literal) : literal_type = match cv with - | PV.Scalar sv -> Integer sv.PV.int_ty - | Bool _ -> Bool - | Char _ -> Char + | PV.VScalar sv -> TInteger sv.PV.int_ty + | VBool _ -> TBool + | VChar _ -> TChar let var_get_id (v : var) : VarId.id = v.id let mk_typed_pattern_from_literal (cv : literal) : typed_pattern = - let ty = Literal (compute_literal_type cv) in + let ty = TLiteral (compute_literal_type cv) in { value = PatConstant cv; ty } let mk_let (monadic : bool) (lv : typed_pattern) (re : texpression) @@ -232,7 +232,7 @@ let is_const (e : texpression) : bool = let ty_as_adt (ty : ty) : type_id * generic_args = match ty with - | Adt (id, generics) -> (id, generics) + | TAdt (id, generics) -> (id, generics) | _ -> raise (Failure "Unreachable") (** Remove the external occurrences of {!Meta} *) @@ -340,7 +340,7 @@ let opt_destruct_function_call (e : texpression) : let opt_destruct_result (ty : ty) : ty option = match ty with - | Adt (Assumed Result, generics) -> + | TAdt (TAssumed Result, generics) -> assert (generics.const_generics = []); assert (generics.trait_refs = []); Some (Collections.List.to_cons_nil generics.types) @@ -350,7 +350,7 @@ let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) let opt_destruct_tuple (ty : ty) : ty list option = match ty with - | Adt (Tuple, generics) -> + | TAdt (Tuple, generics) -> assert (generics.const_generics = []); assert (generics.trait_refs = []); Some generics.types @@ -408,7 +408,7 @@ let iter_switch_body_branches (f : texpression -> unit) (sb : switch_body) : let mk_switch (scrut : texpression) (sb : switch_body) : texpression = (* Sanity check: the scrutinee has the proper type *) (match sb with - | If (_, _) -> assert (scrut.ty = Literal Bool) + | If (_, _) -> assert (scrut.ty = TLiteral TBool) | Match branches -> List.iter (fun (b : match_branch) -> assert (b.pat.ty = scrut.ty)) @@ -427,10 +427,10 @@ let mk_switch (scrut : texpression) (sb : switch_body) : texpression = let mk_simpl_tuple_ty (tys : ty list) : ty = match tys with | [ ty ] -> ty - | _ -> Adt (Tuple, mk_generic_args_from_types tys) + | _ -> TAdt (Tuple, mk_generic_args_from_types tys) -let mk_bool_ty : ty = Literal Bool -let mk_unit_ty : ty = Adt (Tuple, empty_generic_args) +let mk_bool_ty : ty = TLiteral TBool +let mk_unit_ty : ty = TAdt (Tuple, empty_generic_args) let mk_unit_rvalue : texpression = let id = AdtCons { adt_id = Tuple; variant_id = None } in @@ -474,7 +474,7 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = | [ v ] -> v | _ -> let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = Adt (Tuple, mk_generic_args_from_types tys) in + let ty = TAdt (Tuple, mk_generic_args_from_types tys) in let value = PatAdt { variant_id = None; field_values = vl } in { value; ty } @@ -485,7 +485,7 @@ let mk_simpl_tuple_texpression (vl : texpression list) : texpression = | _ -> (* Compute the types of the fields, and the type of the tuple constructor *) let tys = List.map (fun (v : texpression) -> v.ty) vl in - let ty = Adt (Tuple, mk_generic_args_from_types tys) in + let ty = TAdt (Tuple, mk_generic_args_from_types tys) in let ty = mk_arrows tys ty in (* Construct the tuple constructor qualifier *) let id = AdtCons { adt_id = Tuple; variant_id = None } in @@ -501,40 +501,40 @@ let mk_adt_pattern (adt_ty : ty) (variant_id : VariantId.id option) let ty_as_integer (t : ty) : T.integer_type = match t with - | Literal (Integer int_ty) -> int_ty + | TLiteral (TInteger int_ty) -> int_ty | _ -> raise (Failure "Unreachable") let ty_as_literal (t : ty) : T.literal_type = - match t with Literal ty -> ty | _ -> raise (Failure "Unreachable") + match t with TLiteral ty -> ty | _ -> raise (Failure "Unreachable") -let mk_state_ty : ty = Adt (Assumed State, empty_generic_args) +let mk_state_ty : ty = TAdt (TAssumed State, empty_generic_args) let mk_result_ty (ty : ty) : ty = - Adt (Assumed Result, mk_generic_args_from_types [ ty ]) + TAdt (TAssumed Result, mk_generic_args_from_types [ ty ]) -let mk_error_ty : ty = Adt (Assumed Error, empty_generic_args) -let mk_fuel_ty : ty = Adt (Assumed Fuel, empty_generic_args) +let mk_error_ty : ty = TAdt (TAssumed Error, empty_generic_args) +let mk_fuel_ty : ty = TAdt (TAssumed Fuel, empty_generic_args) let mk_error (error : VariantId.id) : texpression = let ty = mk_error_ty in - let id = AdtCons { adt_id = Assumed Error; variant_id = Some error } in + let id = AdtCons { adt_id = TAssumed Error; variant_id = Some error } in let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in { e; ty } let unwrap_result_ty (ty : ty) : ty = match ty with - | Adt - (Assumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) + | TAdt + (TAssumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) -> ty | _ -> raise (Failure "not a result type") let mk_result_fail_texpression (error : texpression) (ty : ty) : texpression = let type_args = [ ty ] in - let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types type_args) in let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_fail_id } + AdtCons { adt_id = TAssumed Result; variant_id = Some result_fail_id } in let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in @@ -549,9 +549,9 @@ let mk_result_fail_texpression_with_error_id (error : VariantId.id) (ty : ty) : let mk_result_return_texpression (v : texpression) : texpression = let type_args = [ v.ty ] in - let ty = Adt (Assumed Result, mk_generic_args_from_types type_args) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types type_args) in let id = - AdtCons { adt_id = Assumed Result; variant_id = Some result_return_id } + AdtCons { adt_id = TAssumed Result; variant_id = Some result_return_id } in let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in @@ -562,7 +562,7 @@ let mk_result_return_texpression (v : texpression) : texpression = (** Create a [Fail err] pattern which captures the error *) let mk_result_fail_pattern (error_pat : pattern) (ty : ty) : typed_pattern = let error_pat : typed_pattern = { value = error_pat; ty = mk_error_ty } in - let ty = Adt (Assumed Result, mk_generic_args_from_types [ ty ]) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types [ ty ]) in let value = PatAdt { variant_id = Some result_fail_id; field_values = [ error_pat ] } in @@ -574,7 +574,7 @@ let mk_result_fail_pattern_ignore_error (ty : ty) : typed_pattern = mk_result_fail_pattern error_pat ty let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = Adt (Assumed Result, mk_generic_args_from_types [ v.ty ]) in + let ty = TAdt (TAssumed Result, mk_generic_args_from_types [ v.ty ]) in let value = PatAdt { variant_id = Some result_return_id; field_values = [ v ] } in diff --git a/compiler/ReorderDecls.ml b/compiler/ReorderDecls.ml index 10b68da3..c82d625f 100644 --- a/compiler/ReorderDecls.ml +++ b/compiler/ReorderDecls.ml @@ -46,8 +46,8 @@ let compute_body_fun_deps (e : texpression) : FunIdSet.t = | Pure _ -> () | FromLlbc (fid, lp_id, rg_id) -> ( match fid with - | FunId (Assumed _) -> () - | TraitMethod (_, _, fid) | FunId (Regular fid) -> + | FunId (FAssumed _) -> () + | TraitMethod (_, _, fid) | FunId (FRegular fid) -> let id = { def_id = fid; lp_id; rg_id } in ids := FunIdSet.add id !ids)) end diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 23f618e2..b4eee9f8 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -9,20 +9,20 @@ module E = Expressions module A = LlbcAst module C = Contexts -type ('r1, 'r2) subst = { - r_subst : 'r1 -> 'r2; - ty_subst : T.TypeVarId.id -> 'r2 T.ty; +type subst = { + r_subst : T.region -> T.region; + ty_subst : T.TypeVarId.id -> T.ty; cg_subst : T.ConstGenericVarId.id -> T.const_generic; (** Substitution from *local* trait clause to trait instance *) - tr_subst : T.TraitClauseId.id -> 'r2 T.trait_instance_id; + tr_subst : T.TraitClauseId.id -> T.trait_instance_id; (** Substitution for the [Self] trait instance *) - tr_self : 'r2 T.trait_instance_id; + tr_self : T.trait_instance_id; } -let ty_substitute_visitor (subst : ('r1, 'r2) subst) = +let st_substitute_visitor (subst : subst) = object - inherit [_] T.map_ty - method visit_'r _ r = subst.r_subst r + inherit [_] A.map_statement + method! visit_region _ r = subst.r_subst r method! visit_TypeVar _ id = subst.ty_subst id method! visit_type_var_id _ _ = @@ -43,25 +43,30 @@ let ty_substitute_visitor (subst : ('r1, 'r2) subst) = **IMPORTANT**: this doesn't normalize the types. *) -let ty_substitute (subst : ('r1, 'r2) subst) (ty : 'r1 T.ty) : 'r2 T.ty = - let visitor = ty_substitute_visitor subst in +let ty_substitute (subst : subst) (ty : T.ty) : T.ty = + let visitor = st_substitute_visitor subst in visitor#visit_ty () ty (** **IMPORTANT**: this doesn't normalize the types. *) -let trait_ref_substitute (subst : ('r1, 'r2) subst) (tr : 'r1 T.trait_ref) : - 'r2 T.trait_ref = - let visitor = ty_substitute_visitor subst in +let trait_ref_substitute (subst : subst) (tr : T.trait_ref) : T.trait_ref = + let visitor = st_substitute_visitor subst in visitor#visit_trait_ref () tr (** **IMPORTANT**: this doesn't normalize the types. *) -let generic_args_substitute (subst : ('r1, 'r2) subst) (g : 'r1 T.generic_args) - : 'r2 T.generic_args = - let visitor = ty_substitute_visitor subst in +let trait_instance_id_substitute (subst : subst) (tr : T.trait_instance_id) : + T.trait_instance_id = + let visitor = st_substitute_visitor subst in + visitor#visit_trait_instance_id () tr + +(** **IMPORTANT**: this doesn't normalize the types. *) +let generic_args_substitute (subst : subst) (g : T.generic_args) : + T.generic_args = + let visitor = st_substitute_visitor subst in visitor#visit_generic_args () g -let erase_regions_subst : ('r, T.erased_region) subst = +let erase_regions_subst : subst = { - r_subst = (fun _ -> T.Erased); + r_subst = (fun _ -> T.RErased); ty_subst = (fun vid -> T.TypeVar vid); cg_subst = (fun id -> T.ConstGenericVar id); tr_subst = (fun id -> T.Clause id); @@ -69,11 +74,18 @@ let erase_regions_subst : ('r, T.erased_region) subst = } (** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : 'r T.ty) : T.ety = ty_substitute erase_regions_subst ty +let erase_regions (ty : T.ty) : T.ty = ty_substitute erase_regions_subst ty -let trait_ref_erase_regions (tr : 'r T.trait_ref) : T.etrait_ref = +let trait_ref_erase_regions (tr : T.trait_ref) : T.trait_ref = trait_ref_substitute erase_regions_subst tr +let trait_instance_id_erase_regions (tr : T.trait_instance_id) : + T.trait_instance_id = + trait_instance_id_substitute erase_regions_subst tr + +let generic_args_erase_regions (tr : T.generic_args) : T.generic_args = + generic_args_substitute erase_regions_subst tr + (** Generate fresh regions for region variables. Return the list of new regions and appropriate substitutions from the @@ -83,60 +95,62 @@ let trait_ref_erase_regions (tr : 'r T.trait_ref) : T.etrait_ref = *) let fresh_regions_with_substs (region_vars : T.region_var list) : T.RegionId.id list - * (T.RegionVarId.id -> T.RegionId.id) - * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = + * (T.RegionId.id -> T.RegionId.id) + * (T.region -> T.region) = (* Generate fresh regions *) let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in (* Generate the map from region var ids to regions *) let ls = List.combine region_vars fresh_region_ids in let rid_map = List.fold_left - (fun mp ((k : T.region_var), v) -> T.RegionVarId.Map.add k.T.index v mp) - T.RegionVarId.Map.empty ls + (fun mp ((k : T.region_var), v) -> T.RegionId.Map.add k.T.index v mp) + T.RegionId.Map.empty ls in (* Generate the substitution from region var id to region *) - let rid_subst id = T.RegionVarId.Map.find id rid_map in + let rid_subst id = T.RegionId.Map.find id rid_map in (* Generate the substitution from region to region *) - let r_subst r = - match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) + let r_subst (r : T.region) = + match r with + | T.RStatic | T.RErased -> r + | T.RVar id -> T.RVar (rid_subst id) in (* Return *) (fresh_region_ids, rid_subst, r_subst) (** Erase the regions in a type and perform a substitution *) -let erase_regions_substitute_types (ty_subst : T.TypeVarId.id -> T.ety) +let erase_regions_substitute_types (ty_subst : T.TypeVarId.id -> T.ty) (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.etrait_instance_id) - (tr_self : T.etrait_instance_id) (ty : 'r T.ty) : T.ety = - let r_subst (_ : 'r) : T.erased_region = T.Erased in + (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) + (tr_self : T.trait_instance_id) (ty : T.ty) : T.ty = + let r_subst (_ : T.region) : T.region = T.RErased in let subst = { r_subst; ty_subst; cg_subst; tr_subst; tr_self } in ty_substitute subst ty (** Create a region substitution from a list of region variable ids and a list of regions (with which to substitute the region variable ids *) -let make_region_subst (var_ids : T.RegionVarId.id list) - (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = +let make_region_subst (var_ids : T.RegionId.id list) (regions : T.region list) : + T.region -> T.region = let ls = List.combine var_ids regions in let mp = List.fold_left - (fun mp (k, v) -> T.RegionVarId.Map.add k v mp) - T.RegionVarId.Map.empty ls + (fun mp (k, v) -> T.RegionId.Map.add k v mp) + T.RegionId.Map.empty ls in fun r -> match r with - | T.Static -> T.Static - | T.Var id -> T.RegionVarId.Map.find id mp + | T.RStatic | T.RErased -> r + | T.RVar id -> T.RegionId.Map.find id mp let make_region_subst_from_vars (vars : T.region_var list) - (regions : 'r T.region list) : T.RegionVarId.id T.region -> 'r T.region = + (regions : T.region list) : T.region -> T.region = make_region_subst (List.map (fun (x : T.region_var) -> x.T.index) vars) regions (** Create a type substitution from a list of type variable ids and a list of types (with which to substitute the type variable ids) *) -let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : - T.TypeVarId.id -> 'r T.ty = +let make_type_subst (var_ids : T.TypeVarId.id list) (tys : T.ty list) : + T.TypeVarId.id -> T.ty = let ls = List.combine var_ids tys in let mp = List.fold_left @@ -145,8 +159,8 @@ let make_type_subst (var_ids : T.TypeVarId.id list) (tys : 'r T.ty list) : in fun id -> T.TypeVarId.Map.find id mp -let make_type_subst_from_vars (vars : T.type_var list) (tys : 'r T.ty list) : - T.TypeVarId.id -> 'r T.ty = +let make_type_subst_from_vars (vars : T.type_var list) (tys : T.ty list) : + T.TypeVarId.id -> T.ty = make_type_subst (List.map (fun (x : T.type_var) -> x.T.index) vars) tys (** Create a const generic substitution from a list of const generic variable ids and a list of @@ -170,7 +184,7 @@ let make_const_generic_subst_from_vars (vars : T.const_generic_var list) (** Create a trait substitution from a list of trait clause ids and a list of trait refs *) let make_trait_subst (clause_ids : T.TraitClauseId.id list) - (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = let ls = List.combine clause_ids trs in let mp = List.fold_left @@ -180,15 +194,13 @@ let make_trait_subst (clause_ids : T.TraitClauseId.id list) fun id -> T.TraitClauseId.Map.find id mp let make_trait_subst_from_clauses (clauses : T.trait_clause list) - (trs : 'r T.trait_ref list) : T.TraitClauseId.id -> 'r T.trait_instance_id = + (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = make_trait_subst (List.map (fun (x : T.trait_clause) -> x.T.clause_id) clauses) trs -let make_subst_from_generics (params : T.generic_params) - (args : 'r T.region T.generic_args) - (tr_self : 'r T.region T.trait_instance_id) : - (T.region_var_id T.region, 'r T.region) subst = +let make_subst_from_generics (params : T.generic_params) (args : T.generic_args) + (tr_self : T.trait_instance_id) : subst = let r_subst = make_region_subst_from_vars params.T.regions args.T.regions in let ty_subst = make_type_subst_from_vars params.T.types args.T.types in let cg_subst = @@ -200,36 +212,12 @@ let make_subst_from_generics (params : T.generic_params) in { r_subst; ty_subst; cg_subst; tr_subst; tr_self } -let make_subst_from_generics_no_regions : - 'r. - T.generic_params -> - 'r T.generic_args -> - 'r T.trait_instance_id -> - (T.region_var_id T.region, 'r) subst = - fun params args tr_self -> - let r_subst _ = raise (Failure "Unexpected region") in - let ty_subst = make_type_subst_from_vars params.T.types args.T.types in - let cg_subst = - make_const_generic_subst_from_vars params.T.const_generics - args.T.const_generics - in - let tr_subst = - make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs - in - { r_subst; ty_subst; cg_subst; tr_subst; tr_self } - -let make_esubst_from_generics (params : T.generic_params) - (generics : T.egeneric_args) (tr_self : T.etrait_instance_id) = - let r_subst _ = T.Erased in - let ty_subst = make_type_subst_from_vars params.types generics.T.types in - let cg_subst = - make_const_generic_subst_from_vars params.const_generics - generics.T.const_generics - in - let tr_subst = - make_trait_subst_from_clauses params.trait_clauses generics.T.trait_refs - in - { r_subst; ty_subst; cg_subst; tr_subst; tr_self } +let make_subst_from_generics_erase_regions (params : T.generic_params) + (generics : T.generic_args) (tr_self : T.trait_instance_id) = + let generics = generic_args_erase_regions generics in + let tr_self = trait_instance_id_erase_regions tr_self in + let subst = make_subst_from_generics params generics tr_self in + { subst with r_subst = (fun _ -> T.RErased) } (** Instantiate the type variables in an ADT definition, and return, for every variant, the list of the types of its fields. @@ -237,8 +225,8 @@ let make_esubst_from_generics (params : T.generic_params) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) - (generics : T.rgeneric_args) : (T.VariantId.id option * T.rty list) list = +let type_decl_get_instantiated_variants_fields_types (def : T.type_decl) + (generics : T.generic_args) : (T.VariantId.id option * T.ty list) list = (* There shouldn't be any reference to Self *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = make_subst_from_generics def.T.generics generics tr_self in @@ -266,9 +254,9 @@ let type_decl_get_instantiated_variants_fields_rtypes (def : T.type_decl) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let type_decl_get_instantiated_field_rtypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.rgeneric_args) : - T.rty list = +let type_decl_get_instantiated_field_types (def : T.type_decl) + (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : + T.ty list = (* For now, check that there are no clauses - otherwise we might need to normalize the types *) assert (def.generics.trait_clauses = []); @@ -284,11 +272,11 @@ let type_decl_get_instantiated_field_rtypes (def : T.type_decl) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) +let ctx_adt_get_instantiated_field_types (ctx : C.eval_ctx) (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.rgeneric_args) : T.rty list = + (generics : T.generic_args) : T.ty list = let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_rtypes def opt_variant_id generics + type_decl_get_instantiated_field_types def opt_variant_id generics (** Return the types of the properly instantiated ADT value (note that here, ADT is understood in its broad meaning: ADT, assumed value or tuple). @@ -296,122 +284,55 @@ let ctx_adt_get_instantiated_field_rtypes (ctx : C.eval_ctx) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_value_get_instantiated_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.rgeneric_args) : - T.rty list = +let ctx_adt_value_get_instantiated_field_types (ctx : C.eval_ctx) + (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list + = match id with | T.AdtId id -> (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_rtypes ctx id adt.V.variant_id generics + ctx_adt_get_instantiated_field_types ctx id adt.V.variant_id generics | T.Tuple -> assert (generics.regions = []); generics.types - | T.Assumed aty -> ( + | T.TAssumed aty -> ( match aty with - | T.Box -> + | T.TBox -> assert (generics.regions = []); assert (List.length generics.types = 1); assert (generics.const_generics = []); generics.types - | T.Array | T.Slice | T.Str -> + | T.TArray | T.TSlice | T.TStr -> (* Those types don't have fields *) raise (Failure "Unreachable")) -(** Instantiate the type variables in an ADT definition, and return the list - of types of the fields for the chosen variant. - - **IMPORTANT**: this function doesn't normalize the types, you may want to - use the [AssociatedTypes] equivalent instead. -*) -let type_decl_get_instantiated_field_etypes (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.egeneric_args) : - T.ety list = - (* For now, check that there are no clauses - otherwise we might need - to normalize the types *) - assert (def.generics.trait_clauses = []); - (* There shouldn't be any reference to Self *) - let tr_self : T.erased_region T.trait_instance_id = - T.UnknownTrait __FUNCTION__ - in - let { r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = - make_esubst_from_generics def.T.generics generics tr_self - in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map - (fun (f : T.field) -> - erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self - f.T.field_ty) - fields - -(** Return the types of the properly instantiated ADT's variant, provided a - context. - - **IMPORTANT**: this function doesn't normalize the types, you may want to - use the [AssociatedTypes] equivalent instead. - *) -let ctx_adt_get_instantiated_field_etypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.egeneric_args) : T.ety list = - let def = C.ctx_lookup_type_decl ctx def_id in - type_decl_get_instantiated_field_etypes def opt_variant_id generics - -let statement_substitute_visitor - (subst : (T.erased_region, T.erased_region) subst) = - (* Keep in synch with [ty_substitute_visitor] *) - object - inherit [_] A.map_statement - method! visit_'r _ r = subst.r_subst r - method! visit_TypeVar _ id = subst.ty_subst id - - method! visit_type_var_id _ _ = - (* We should never get here because we reimplemented [visit_TypeVar] *) - raise (Failure "Unexpected") - - method! visit_ConstGenericVar _ id = subst.cg_subst id - - method! visit_const_generic_var_id _ _ = - (* We should never get here because we reimplemented [visit_Var] *) - raise (Failure "Unexpected") - - method! visit_Clause _ id = subst.tr_subst id - method! visit_Self _ = subst.tr_self - end - (** Apply a type substitution to a place *) -let place_substitute (subst : (T.erased_region, T.erased_region) subst) - (p : E.place) : E.place = +let place_substitute (subst : subst) (p : E.place) : E.place = (* There is in fact nothing to do *) - (statement_substitute_visitor subst)#visit_place () p + (st_substitute_visitor subst)#visit_place () p (** Apply a type substitution to an operand *) -let operand_substitute (subst : (T.erased_region, T.erased_region) subst) - (op : E.operand) : E.operand = - (statement_substitute_visitor subst)#visit_operand () op +let operand_substitute (subst : subst) (op : E.operand) : E.operand = + (st_substitute_visitor subst)#visit_operand () op (** Apply a type substitution to an rvalue *) -let rvalue_substitute (subst : (T.erased_region, T.erased_region) subst) - (rv : E.rvalue) : E.rvalue = - (statement_substitute_visitor subst)#visit_rvalue () rv +let rvalue_substitute (subst : subst) (rv : E.rvalue) : E.rvalue = + (st_substitute_visitor subst)#visit_rvalue () rv (** Apply a type substitution to an assertion *) -let assertion_substitute (subst : (T.erased_region, T.erased_region) subst) - (a : A.assertion) : A.assertion = - (statement_substitute_visitor subst)#visit_assertion () a +let assertion_substitute (subst : subst) (a : A.assertion) : A.assertion = + (st_substitute_visitor subst)#visit_assertion () a (** Apply a type substitution to a call *) -let call_substitute (subst : (T.erased_region, T.erased_region) subst) - (call : A.call) : A.call = - (statement_substitute_visitor subst)#visit_call () call +let call_substitute (subst : subst) (call : A.call) : A.call = + (st_substitute_visitor subst)#visit_call () call (** Apply a type substitution to a statement *) -let statement_substitute (subst : (T.erased_region, T.erased_region) subst) - (st : A.statement) : A.statement = - (statement_substitute_visitor subst)#visit_statement () st +let statement_substitute (subst : subst) (st : A.statement) : A.statement = + (st_substitute_visitor subst)#visit_statement () st (** Apply a type substitution to a function body. Return the local variables and the body. *) -let fun_body_substitute_in_body - (subst : (T.erased_region, T.erased_region) subst) (body : A.fun_body) : +let fun_body_substitute_in_body (subst : subst) (body : A.fun_body) : A.var list * A.statement = let locals = List.map @@ -421,10 +342,10 @@ let fun_body_substitute_in_body let body = statement_substitute subst body.body in (locals, body) -let trait_type_constraint_substitute (subst : ('r1, 'r2) subst) - (ttc : 'r1 T.trait_type_constraint) : 'r2 T.trait_type_constraint = +let trait_type_constraint_substitute (subst : subst) + (ttc : T.trait_type_constraint) : T.trait_type_constraint = let { T.trait_ref; generics; type_name; ty } = ttc in - let visitor = ty_substitute_visitor subst in + let visitor = st_substitute_visitor subst in let trait_ref = visitor#visit_trait_ref () trait_ref in let generics = visitor#visit_generic_args () generics in let ty = visitor#visit_ty () ty in @@ -435,22 +356,24 @@ let trait_type_constraint_substitute (subst : ('r1, 'r2) subst) **IMPORTANT:** this function doesn't normalize the types. *) let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionVarId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.rty) + (r_subst : T.RegionId.id -> T.RegionId.id) + (ty_subst : T.TypeVarId.id -> T.ty) (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.rtrait_instance_id) - (tr_self : T.rtrait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = - let r_subst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = - match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) + (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) + (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + let r_subst' (r : T.region) : T.region = + match r with + | T.RStatic | T.RErased -> r + | T.RVar rid -> T.RVar (r_subst rid) in let subst = { r_subst = r_subst'; ty_subst; cg_subst; tr_subst; tr_self } in let inputs = List.map (ty_substitute subst) sg.A.inputs in let output = ty_substitute subst sg.A.output in - let subst_region_group (rg : T.region_var_group) : A.abs_region_group = + let subst_region_group (rg : T.region_group) : A.abs_region_group = let id = asubst rg.id in let regions = List.map r_subst rg.regions in let parents = List.map asubst rg.parents in - { id; regions; parents } + ({ id; regions; parents } : A.abs_region_group) in let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in let trait_type_constraints = @@ -461,9 +384,9 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) { A.inputs; output; regions_hierarchy; trait_type_constraints } (** Substitute variable identifiers in a type *) -let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : 'r T.ty) - : 'r T.ty = +let statement_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) + (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : T.ty) : + T.ty = let open T in let visitor = object @@ -476,80 +399,39 @@ let ty_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) visitor#visit_ty () ty -(* This visitor is a mess... - - We want to write a class which visits abstractions, values, etc. *and their - types* to substitute identifiers. - - The issue is that we derive two specialized types (ety and rty) from a - polymorphic type (ty). Because of this, there are typing issues with - [visit_'r] if we define a class which visits objects of types [ety] and [rty] - while inheriting a class which visit [ty]... -*) let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) = - let subst_rty = - object - inherit [_] T.map_ty - - method visit_'r _ r = - match r with T.Static -> T.Static | T.Var rid -> T.Var (r_subst rid) - - method! visit_type_var_id _ id = ty_subst id - method! visit_const_generic_var_id _ id = cg_subst id - end - in - - let visitor = - object (self : 'self) - inherit [_] C.map_env - method! visit_borrow_id _ bid = bsubst bid - method! visit_loan_id _ bid = bsubst bid - method! visit_ety _ ty = ty_substitute_ids ty_subst cg_subst ty - method! visit_rty env ty = subst_rty#visit_ty env ty - method! visit_symbolic_value_id _ id = ssubst id - - (** We *do* visit meta-values *) - method! visit_msymbolic_value env sv = self#visit_symbolic_value env sv - - (** We *do* visit meta-values *) - method! visit_mvalue env v = self#visit_typed_value env v - - method! visit_region_id _ id = r_subst id - method! visit_region_var_id _ id = rvsubst id - method! visit_abstraction_id _ id = asubst id - end - in - - object - method visit_ety (x : T.ety) : T.ety = visitor#visit_ety () x - method visit_rty (x : T.rty) : T.rty = visitor#visit_rty () x - - method visit_typed_value (x : V.typed_value) : V.typed_value = - visitor#visit_typed_value () x - - method visit_typed_avalue (x : V.typed_avalue) : V.typed_avalue = - visitor#visit_typed_avalue () x - - method visit_abs (x : V.abs) : V.abs = visitor#visit_abs () x - method visit_env (env : C.env) : C.env = visitor#visit_env () env + object (self : 'self) + inherit [_] C.map_env + method! visit_type_var_id _ id = ty_subst id + method! visit_const_generic_var_id _ id = cg_subst id + method! visit_region_id _ rid = r_subst rid + method! visit_borrow_id _ bid = bsubst bid + method! visit_loan_id _ bid = bsubst bid + method! visit_symbolic_value_id _ id = ssubst id + + (** We *do* visit meta-values *) + method! visit_msymbolic_value env sv = self#visit_symbolic_value env sv + + (** We *do* visit meta-values *) + method! visit_mvalue env v = self#visit_typed_value env v + + method! visit_abstraction_id _ id = asubst id end let typed_value_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_value) : V.typed_value = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_typed_value v + let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in + vis#visit_typed_value () v let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (v : V.typed_value) : V.typed_value = @@ -558,61 +440,57 @@ let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (fun x -> x) (fun x -> x) (fun x -> x) - (fun x -> x) v let typed_avalue_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_avalue) : V.typed_avalue = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_typed_avalue v + let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in + vis#visit_typed_avalue () v let abs_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : V.abs) : V.abs = - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_abs x + let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in + vis#visit_abs () x let env_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (rvsubst : T.RegionVarId.id -> T.RegionVarId.id) (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) (bsubst : V.BorrowId.id -> V.BorrowId.id) (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : C.env) : C.env = - (subst_ids_visitor r_subst rvsubst ty_subst cg_subst ssubst bsubst asubst) - #visit_env x + let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in + vis#visit_env () x let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : V.typed_avalue) : V.typed_avalue = let asubst _ = raise (Failure "Unreachable") in - (subst_ids_visitor r_subst - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - asubst) - #visit_typed_avalue - x + let vis = + subst_ids_visitor r_subst + (fun x -> x) + (fun x -> x) + (fun x -> x) + (fun x -> x) + asubst + in + vis#visit_typed_avalue () x let env_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : C.env) : C.env = - (subst_ids_visitor r_subst - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x) - (fun x -> x)) - #visit_env - x + let vis = + subst_ids_visitor r_subst + (fun x -> x) + (fun x -> x) + (fun x -> x) + (fun x -> x) + (fun x -> x) + in + vis#visit_env () x diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 4df8fec7..927544b2 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -43,7 +43,7 @@ type call = { borrows (we need to perform lookups). *) abstractions : V.AbstractionId.id list; - generics : T.egeneric_args; + generics : T.generic_args; args : V.typed_value list; args_places : mplace option list; (** Meta information *) dest : V.symbolic_value; @@ -65,30 +65,22 @@ type global_decl_id = A.GlobalDeclId.id [@@deriving show] type 'a symbolic_value_id_map = 'a V.SymbolicValueId.Map.t [@@deriving show] type 'a region_group_id_map = 'a T.RegionGroupId.Map.t [@@deriving show] -(** Ancestor for {!expression} iter visitor *) +(** Ancestor for {!expression} iter visitor. + + We could make it inherit the visitor for {!eval_ctx}, but in all the uses + of this visitor we don't need to explore {!eval_ctx}, so we make it inherit + the abstraction visitors instead. + *) class ['self] iter_expression_base = object (self : 'self) - inherit [_] VisitorsRuntime.iter + inherit [_] V.iter_abs method visit_eval_ctx : 'env -> Contexts.eval_ctx -> unit = fun _ _ -> () - method visit_typed_value : 'env -> V.typed_value -> unit = fun _ _ -> () method visit_call : 'env -> call -> unit = fun _ _ -> () - method visit_abs : 'env -> V.abs -> unit = fun _ _ -> () method visit_loop_id : 'env -> V.loop_id -> unit = fun _ _ -> () - method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () - - method visit_const_generic_var_id : 'env -> T.const_generic_var_id -> unit = - fun _ _ -> () - - method visit_symbolic_value_id : 'env -> V.symbolic_value_id -> unit = - fun _ _ -> () - - method visit_symbolic_value : 'env -> V.symbolic_value -> unit = - fun _ _ -> () method visit_region_group_id : 'env -> T.RegionGroupId.id -> unit = fun _ _ -> () - method visit_global_decl_id : 'env -> global_decl_id -> unit = fun _ _ -> () method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () method visit_meta : 'env -> meta -> unit = fun _ _ -> () @@ -115,14 +107,8 @@ class ['self] iter_expression_base = fun env s -> V.SymbolicValueId.Set.iter (self#visit_symbolic_value_id env) s - method visit_integer_type : 'env -> T.integer_type -> unit = fun _ _ -> () - method visit_scalar_value : 'env -> V.scalar_value -> unit = fun _ _ -> () - method visit_symbolic_expansion : 'env -> V.symbolic_expansion -> unit = fun _ _ -> () - - method visit_etrait_ref : 'env -> T.etrait_ref -> unit = fun _ _ -> () - method visit_egeneric_args : 'env -> T.egeneric_args -> unit = fun _ _ -> () end (** **Rem.:** here, {!expression} is not at all equivalent to the expressions @@ -224,7 +210,7 @@ and loop = { fresh_svalues : V.symbolic_value_id_set; (** The symbolic values introduced by the loop fixed-point *) rg_to_given_back_tys : - ((T.RegionId.Set.t * T.rty list) T.RegionGroupId.Map.t[@opaque]); + ((T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t[@opaque]); (** The map from region group ids to the types of the values given back by the corresponding loop abstractions. *) @@ -254,13 +240,13 @@ and expansion = (* Remark: this type doesn't have to be mutually recursive with the other types, but it makes it easy to generate the visitors *) and value_aggregate = - | SingleValue of V.typed_value (** Regular case *) - | Array of V.typed_value list + | VaSingleValue of V.typed_value (** Regular case *) + | VaArray of V.typed_value list (** This is used when introducing array aggregates *) - | ConstGenericValue of T.const_generic_var_id + | VaConstGenericValue of T.const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) - | TraitConstValue of T.etrait_ref * T.egeneric_args * string + | VaTraitConstValue of T.trait_ref * T.generic_args * string (** A trait constant value *) [@@deriving show, diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 2ce8c706..97755438 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -213,14 +213,12 @@ let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = ctx.trait_decls_ctx ctx.trait_impls_ctx ctx.fun_decl let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = - let rvar_to_string = Print.Types.region_var_id_to_string in - let r_to_string = Print.Types.region_id_to_string in + let region_id_to_string = Print.Types.region_id_to_string in let type_var_id_to_string = Print.Types.type_var_id_to_string in let var_id_to_string = Print.Expressions.var_id_to_string in let ast_fmt = bs_ctx_to_ast_formatter ctx in { - Print.Values.rvar_to_string; - r_to_string; + Print.Values.region_id_to_string; type_var_id_to_string; type_decl_id_to_string = ast_fmt.type_decl_id_to_string; const_generic_var_id_to_string = ast_fmt.const_generic_var_id_to_string; @@ -242,30 +240,29 @@ let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types generics.const_generics -let ctx_egeneric_args_to_string (ctx : bs_ctx) (args : T.egeneric_args) : string - = +let ctx_generic_args_to_string (ctx : bs_ctx) (args : T.generic_args) : string = let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_etype_formatter fmt in - Print.PT.egeneric_args_to_string fmt args + let fmt = Print.PC.ctx_to_type_formatter fmt in + Print.PT.generic_args_to_string fmt args let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_rtype_formatter fmt in + let fmt = Print.PC.ctx_to_type_formatter fmt in Print.PV.symbolic_value_to_string fmt sv let typed_value_to_string (ctx : bs_ctx) (v : V.typed_value) : string = let fmt = bs_ctx_to_ctx_formatter ctx in Print.PV.typed_value_to_string fmt v -let ty_to_string (ctx : bs_ctx) (ty : ty) : string = +let pure_ty_to_string (ctx : bs_ctx) (ty : ty) : string = let fmt = bs_ctx_to_pp_ast_formatter ctx in let fmt = PrintPure.ast_to_type_formatter fmt in PrintPure.ty_to_string fmt false ty -let rty_to_string (ctx : bs_ctx) (ty : T.rty) : string = +let ty_to_string (ctx : bs_ctx) (ty : T.ty) : string = let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_rtype_formatter fmt in - Print.PT.rty_to_string fmt ty + let fmt = Print.PC.ctx_to_type_formatter fmt in + Print.PT.ty_to_string fmt ty let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let type_decls = ctx.type_context.llbc_type_decls in @@ -343,13 +340,13 @@ let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : (* TODO: move *) let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = - let id = (E.Regular def_id, back_id) in + let id = (E.FRegular def_id, back_id) in (RegularFunIdNotLoopMap.find id ctx.fun_context.fun_sigs).sg (* Some generic translation functions (we need to translate different "flavours" - of types: sty, forward types, backward types, etc.) *) -let rec translate_generic_args (translate_ty : 'r T.ty -> ty) - (generics : 'r T.generic_args) : generic_args = + of types: forward types, backward types, etc.) *) +let rec translate_generic_args (translate_ty : T.ty -> ty) + (generics : T.generic_args) : generic_args = (* We ignore the regions: if they didn't cause trouble for the symbolic execution, then everything's fine *) let types = List.map translate_ty generics.types in @@ -359,7 +356,7 @@ let rec translate_generic_args (translate_ty : 'r T.ty -> ty) in { types; const_generics; trait_refs } -and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : +and translate_trait_ref (translate_ty : T.ty -> ty) (tr : T.trait_ref) : trait_ref = let trait_id = translate_trait_instance_id translate_ty tr.trait_id in let generics = translate_generic_args translate_ty tr.generics in @@ -368,13 +365,13 @@ and translate_trait_ref (translate_ty : 'r T.ty -> ty) (tr : 'r T.trait_ref) : in { trait_id; generics; trait_decl_ref } -and translate_trait_decl_ref (translate_ty : 'r T.ty -> ty) - (tr : 'r T.trait_decl_ref) : trait_decl_ref = +and translate_trait_decl_ref (translate_ty : T.ty -> ty) (tr : T.trait_decl_ref) + : trait_decl_ref = let decl_generics = translate_generic_args translate_ty tr.decl_generics in { trait_decl_id = tr.trait_decl_id; decl_generics } -and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) - (id : 'r T.trait_instance_id) : trait_instance_id = +and translate_trait_instance_id (translate_ty : T.ty -> ty) + (id : T.trait_instance_id) : trait_instance_id = let translate_trait_instance_id = translate_trait_instance_id translate_ty in match id with | T.Self -> Self @@ -393,19 +390,20 @@ and translate_trait_instance_id (translate_ty : 'r T.ty -> ty) | FnPointer _ -> raise (Failure "TODO") | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) -let rec translate_sty (ty : T.sty) : ty = +(** Translate a signature type - TODO: factor out the different translation functions *) +let rec translate_sty (ty : T.ty) : ty = let translate = translate_sty in match ty with - | T.Adt (type_id, generics) -> ( + | T.TAdt (type_id, generics) -> ( let generics = translate_sgeneric_args generics in match type_id with - | T.AdtId adt_id -> Adt (AdtId adt_id, generics) + | T.AdtId adt_id -> TAdt (AdtId adt_id, generics) | T.Tuple -> assert (generics.const_generics = []); mk_simpl_tuple_ty generics.types - | T.Assumed aty -> ( + | T.TAssumed aty -> ( match aty with - | T.Box -> ( + | T.TBox -> ( (* Eliminate the boxes *) match generics.types with | [ ty ] -> ty @@ -414,31 +412,31 @@ let rec translate_sty (ty : T.sty) : ty = (Failure "Box/vec/option type with incorrect number of arguments") ) - | T.Array -> Adt (Assumed Array, generics) - | T.Slice -> Adt (Assumed Slice, generics) - | T.Str -> Adt (Assumed Str, generics))) + | T.TArray -> TAdt (TAssumed Array, generics) + | T.TSlice -> TAdt (TAssumed Slice, generics) + | T.TStr -> TAdt (TAssumed Str, generics))) | TypeVar vid -> TypeVar vid - | Literal ty -> Literal ty + | TLiteral ty -> TLiteral ty | Never -> raise (Failure "Unreachable") | Ref (_, rty, _) -> translate rty | RawPtr (ty, rkind) -> let mut = match rkind with Mut -> Mut | Shared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in - Adt (Assumed (RawPtr mut), generics) + TAdt (TAssumed (RawPtr mut), generics) | TraitType (trait_ref, generics, type_name) -> let trait_ref = translate_strait_ref trait_ref in let generics = translate_sgeneric_args generics in TraitType (trait_ref, generics, type_name) | Arrow _ -> raise (Failure "TODO") -and translate_sgeneric_args (generics : T.sgeneric_args) : generic_args = +and translate_sgeneric_args (generics : T.generic_args) : generic_args = translate_generic_args translate_sty generics -and translate_strait_ref (tr : T.strait_ref) : trait_ref = +and translate_strait_ref (tr : T.trait_ref) : trait_ref = translate_trait_ref translate_sty tr -and translate_strait_instance_id (id : T.strait_instance_id) : trait_instance_id +and translate_strait_instance_id (id : T.trait_instance_id) : trait_instance_id = translate_trait_instance_id translate_sty id @@ -447,7 +445,7 @@ let translate_trait_clause (clause : T.trait_clause) : trait_clause = let generics = translate_sgeneric_args generics in { clause_id; trait_id; generics } -let translate_strait_type_constraint (ttc : T.strait_type_constraint) : +let translate_strait_type_constraint (ttc : T.trait_type_constraint) : trait_type_constraint = let { T.trait_ref; generics; type_name; ty } = ttc in let trait_ref = translate_strait_ref trait_ref in @@ -509,38 +507,43 @@ let translate_type_decl (def : T.type_decl) : type_decl = let translate_type_id (id : T.type_id) : type_id = match id with | AdtId adt_id -> AdtId adt_id - | T.Assumed aty -> + | T.TAssumed aty -> let aty = match aty with - | T.Array -> Array - | T.Slice -> Slice - | T.Str -> Str - | T.Box -> + | T.TArray -> Array + | T.TSlice -> Slice + | T.TStr -> Str + | T.TBox -> (* Boxes have to be eliminated: this type id shouldn't be translated *) raise (Failure "Unreachable") in - Assumed aty + TAssumed aty | T.Tuple -> Tuple (** Translate a type, seen as an input/output of a forward function - (preserve all borrows, etc.) + (preserve all borrows, etc.). + + Remark: it doesn't matter whether the types has regions or erased regions + (both cases happen, actually). + + TODO: factor out the various translation functions. *) -let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = +let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = let translate = translate_fwd_ty type_infos in match ty with - | T.Adt (type_id, generics) -> ( + | T.TAdt (type_id, generics) -> ( let t_generics = translate_fwd_generic_args type_infos generics in (* Eliminate boxes and simplify tuples *) match type_id with - | AdtId _ | T.Assumed (T.Array | T.Slice | T.Str) -> + | AdtId _ | T.TAssumed (T.TArray | T.TSlice | T.TStr) -> let type_id = translate_type_id type_id in - Adt (type_id, t_generics) + TAdt (type_id, t_generics) | Tuple -> (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the identity *) mk_simpl_tuple_ty t_generics.types - | T.Assumed T.Box -> ( + | T.TAssumed T.TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) assert ( @@ -557,13 +560,13 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = parameter"))) | TypeVar vid -> TypeVar vid | Never -> raise (Failure "Unreachable") - | Literal lty -> Literal lty + | TLiteral lty -> TLiteral lty | Ref (_, rty, _) -> translate rty | RawPtr (ty, rkind) -> let mut = match rkind with Mut -> Mut | Shared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in - Adt (Assumed (RawPtr mut), generics) + TAdt (TAssumed (RawPtr mut), generics) | TraitType (trait_ref, generics, type_name) -> let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in @@ -571,25 +574,25 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 'r T.ty) : ty = | Arrow _ -> raise (Failure "TODO") and translate_fwd_generic_args (type_infos : TA.type_infos) - (generics : 'r T.generic_args) : generic_args = + (generics : T.generic_args) : generic_args = translate_generic_args (translate_fwd_ty type_infos) generics -and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : 'r T.trait_ref) : +and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : T.trait_ref) : trait_ref = translate_trait_ref (translate_fwd_ty type_infos) tr and translate_fwd_trait_instance_id (type_infos : TA.type_infos) - (id : 'r T.trait_instance_id) : trait_instance_id = + (id : T.trait_instance_id) : trait_instance_id = translate_trait_instance_id (translate_fwd_ty type_infos) id (** Simply calls [translate_fwd_ty] *) -let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : 'r T.ty) : ty = +let ctx_translate_fwd_ty (ctx : bs_ctx) (ty : T.ty) : ty = let type_infos = ctx.type_context.type_infos in translate_fwd_ty type_infos ty (** Simply calls [translate_fwd_generic_args] *) -let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : 'r T.generic_args) - : generic_args = +let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : + generic_args = let type_infos = ctx.type_context.type_infos in translate_fwd_generic_args type_infos generics @@ -600,20 +603,21 @@ let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : 'r T.generic_args) [inside_mut]: are we inside a mutable borrow? *) let rec translate_back_ty (type_infos : TA.type_infos) - (keep_region : 'r -> bool) (inside_mut : bool) (ty : 'r T.ty) : ty option = + (keep_region : T.region -> bool) (inside_mut : bool) (ty : T.ty) : ty option + = let translate = translate_back_ty type_infos keep_region inside_mut in (* A small helper for "leave" types *) let wrap ty = if inside_mut then Some ty else None in match ty with - | T.Adt (type_id, generics) -> ( + | T.TAdt (type_id, generics) -> ( match type_id with - | T.AdtId _ | Assumed (T.Array | T.Slice | T.Str) -> + | T.AdtId _ | TAssumed (T.TArray | T.TSlice | T.TStr) -> let type_id = translate_type_id type_id in if inside_mut then (* We do not want to filter anything, so we translate the generics as "forward" types *) let generics = translate_fwd_generic_args type_infos generics in - Some (Adt (type_id, generics)) + Some (TAdt (type_id, generics)) else (* If not inside a mutable reference: check if at least one of the generics contains a mutable reference (i.e., is not @@ -624,9 +628,9 @@ let rec translate_back_ty (type_infos : TA.type_infos) let types = List.filter_map translate generics.types in if types <> [] then let generics = translate_fwd_generic_args type_infos generics in - Some (Adt (type_id, generics)) + Some (TAdt (type_id, generics)) else None - | Assumed T.Box -> ( + | TAssumed T.TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); (* Eliminate the box *) @@ -647,7 +651,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) Some (mk_simpl_tuple_ty tys_t))) | TypeVar vid -> wrap (TypeVar vid) | Never -> raise (Failure "Unreachable") - | Literal lty -> wrap (Literal lty) + | TLiteral lty -> wrap (TLiteral lty) | Ref (r, rty, rkind) -> ( match rkind with | T.Shared -> @@ -673,7 +677,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) - (inside_mut : bool) (ty : 'r T.ty) : ty option = + (inside_mut : bool) (ty : T.ty) : ty option = let type_infos = ctx.type_context.type_infos in translate_back_ty type_infos keep_region inside_mut ty @@ -682,7 +686,7 @@ let mk_type_check_ctx (ctx : bs_ctx) : PureTypeCheck.tc_ctx = T.ConstGenericVarId.Map.of_list (List.map (fun (cg : T.const_generic_var) -> - (cg.index, ctx_translate_fwd_ty ctx (T.Literal cg.ty))) + (cg.index, ctx_translate_fwd_ty ctx (T.TLiteral cg.ty))) ctx.sg.generics.const_generics) in let env = VarId.Map.empty in @@ -807,7 +811,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with - | TraitMethod (_, _, fid) | FunId (Regular fid) -> + | TraitMethod (_, _, fid) | FunId (FRegular fid) -> let info = A.FunDeclId.Map.find fid fun_infos in let stateful_group = info.stateful in let stateful = @@ -820,7 +824,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) can_diverge = info.can_diverge; is_rec = info.is_rec || Option.is_some lid; } - | FunId (Assumed aid) -> + | FunId (FAssumed aid) -> assert (lid = None); { can_fail = Assumed.assumed_fun_can_fail aid; @@ -861,21 +865,21 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) (* Create the context *) let ctx = let region_groups = - List.map (fun (g : T.region_var_group) -> g.id) sg.regions_hierarchy + List.map (fun (g : T.region_group) -> g.id) sg.regions_hierarchy in let ctx = InterpreterUtils.initialize_eval_context decls_ctx region_groups sg.generics.types sg.generics.const_generics in (* Compute the normalization map for the *sty* types and add it to the context *) - AssociatedTypes.ctx_add_norm_trait_stypes_from_preds ctx + AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx sg.preds.trait_type_constraints in (* Normalize the signature *) let sg = let ({ A.inputs; output; _ } : A.fun_sig) = sg in - let norm = AssociatedTypes.ctx_normalize_sty ctx in + let norm = AssociatedTypes.ctx_normalize_ty ctx in let inputs = List.map norm inputs in let output = norm output in { sg with A.inputs; output } @@ -893,14 +897,14 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) * so just check that there aren't parent regions *) assert (T.RegionGroupId.Set.is_empty parents); (* Small helper to translate types for backward functions *) - let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.sty -> ty option - = + let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.ty -> ty option = let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in - let regions = T.RegionVarId.Set.of_list rg.regions in + let regions = T.RegionId.Set.of_list rg.regions in let keep_region r = match r with - | T.Static -> raise Unimplemented - | T.Var r -> T.RegionVarId.Set.mem r regions + | T.RStatic -> raise Unimplemented + | T.RErased -> raise (Failure "Unexpected erased region") + | T.RVar r -> T.RegionId.Set.mem r regions in let inside_mut = false in translate_back_ty type_infos keep_region inside_mut @@ -1042,7 +1046,7 @@ let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = (* Return *) (ctx, state_pat) -let fresh_var_llbc_ty (basename : string option) (ty : 'r T.ty) (ctx : bs_ctx) : +let fresh_var_llbc_ty (basename : string option) (ty : T.ty) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) let id, var_counter = VarId.fresh ctx.var_counter in @@ -1106,7 +1110,7 @@ let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = (** Peel boxes as long as the value is of the form [Box] *) let rec unbox_typed_value (v : V.typed_value) : V.typed_value = match (v.value, v.ty) with - | V.Adt av, T.Adt (T.Assumed T.Box, _) -> ( + | V.VAdt av, T.TAdt (T.TAssumed T.TBox, _) -> ( match av.field_values with | [ bv ] -> unbox_typed_value bv | _ -> raise (Failure "Unreachable")) @@ -1145,13 +1149,13 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (* Translate the value *) let value = match v.value with - | V.Literal cv -> { e = Const cv; ty } - | Adt av -> ( + | V.VLiteral cv -> { e = Const cv; ty } + | VAdt av -> ( let variant_id = av.variant_id in let field_values = List.map translate av.field_values in (* Eliminate the tuple wrapper if it is a tuple with exactly one field *) match v.ty with - | T.Adt (T.Tuple, _) -> + | T.TAdt (T.Tuple, _) -> assert (variant_id = None); mk_simpl_tuple_texpression field_values | _ -> @@ -1229,7 +1233,7 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (* For now, only tuples can contain borrows *) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> + | T.AdtId _ | T.TAssumed (T.TBox | T.TArray | T.TSlice | T.TStr) -> assert (field_values = []); None | T.Tuple -> @@ -1374,7 +1378,7 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) * vector value upon visiting the "abstraction borrow" node *) let adt_id, _ = TypesUtils.ty_as_adt av.ty in match adt_id with - | T.AdtId _ | T.Assumed (T.Box | T.Array | T.Slice | T.Str) -> + | T.AdtId _ | T.TAssumed (T.TBox | T.TArray | T.TSlice | T.TStr) -> assert (field_values = []); (ctx, None) | T.Tuple -> @@ -1645,7 +1649,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : log#ldebug (lazy ("translate_function_call:\n" - ^ ctx_egeneric_args_to_string ctx call.generics)); + ^ ctx_generic_args_to_string ctx call.generics)); (* Translate the function call *) let generics = ctx_translate_fwd_generic_args ctx call.generics in let args = @@ -1845,11 +1849,12 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ("translate_end_abstraction_synth_input:" ^ "\n\n- given back variables types:\n" ^ Print.list_to_string - (fun (v : var) -> ty_to_string ctx v.ty) + (fun (v : var) -> pure_ty_to_string ctx v.ty) given_back_variables ^ "\n\n- consumed values:\n" ^ Print.list_to_string - (fun e -> texpression_to_string ctx e ^ " : " ^ ty_to_string ctx e.ty) + (fun e -> + texpression_to_string ctx e ^ " : " ^ pure_ty_to_string ctx e.ty) consumed_values ^ "\n")); @@ -1948,7 +1953,8 @@ and translate_end_abstraction_fun_call (ectx : C.eval_ctx) (abs : V.abs) ^ "\n- inst_sg.inputs (" ^ string_of_int (List.length inst_sg.inputs) ^ "): " - ^ String.concat ", " (List.map (ty_to_string ctx) inst_sg.inputs))); + ^ String.concat ", " + (List.map (pure_ty_to_string ctx) inst_sg.inputs))); List.iter (fun (x, ty) -> assert ((x : texpression).ty = ty)) (List.combine inputs inst_sg.inputs); @@ -2070,8 +2076,9 @@ and translate_end_abstraction_synth_ret (ectx : C.eval_ctx) (abs : V.abs) log#ldebug (lazy ("\n- given_back ty: " - ^ ty_to_string ctx given_back.ty - ^ "\n- sig input ty: " ^ ty_to_string ctx input.ty)); + ^ pure_ty_to_string ctx given_back.ty + ^ "\n- sig input ty: " + ^ pure_ty_to_string ctx input.ty)); assert (given_back.ty = input.ty)) given_back_inputs; (* Translate the next expression *) @@ -2098,7 +2105,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Actually the same case as [SynthInput] *) translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.LoopCall -> - let fun_id = E.Regular ctx.fun_decl.A.def_id in + let fun_id = E.FRegular ctx.fun_decl.A.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fun_id) (Some vloop_id) (Some rg_id) @@ -2229,7 +2236,7 @@ and translate_assertion (ectx : C.eval_ctx) (v : V.typed_value) let func = { id = FunOrOp (Fun (Pure Assert)); generics = empty_generic_args } in - let func_ty = mk_arrow (Literal Bool) mk_unit_ty in + let func_ty = mk_arrow (TLiteral TBool) mk_unit_ty in let func = { e = Qualif func; ty = func_ty } in let assertion = mk_apps func args in mk_let monadic (mk_dummy_pattern mk_unit_ty) assertion next_e @@ -2325,12 +2332,12 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) (* We don't need to update the context: we don't introduce any * new values/variables *) let branch = translate_expression branch_e ctx in - let pat = mk_typed_pattern_from_literal (PV.Scalar v) in + let pat = mk_typed_pattern_from_literal (PV.VScalar v) in { pat; branch } in let branches = List.map translate_branch branches in let otherwise = translate_expression otherwise ctx in - let pat_ty = Literal (Integer int_ty) in + let pat_ty = TLiteral (TInteger int_ty) in let otherwise_pat : typed_pattern = { value = PatDummy; ty = pat_ty } in let otherwise : match_branch = { pat = otherwise_pat; branch = otherwise } @@ -2433,7 +2440,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_simpl_tuple_pattern vars) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.Assumed T.Box -> + | T.TAssumed T.TBox -> (* There should be exactly one variable *) let var = match vars with [ v ] -> v | _ -> raise (Failure "Unreachable") @@ -2445,7 +2452,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_typed_pattern_from_var var None) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.Assumed (T.Array | T.Slice | T.Str) -> + | T.TAssumed (T.TArray | T.TSlice | T.TStr) -> (* We can't expand those values: we can access the fields only * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number @@ -2469,19 +2476,19 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) *) let v = match v with - | SingleValue v -> typed_value_to_texpression ctx ectx v - | Array values -> + | VaSingleValue v -> typed_value_to_texpression ctx ectx v + | VaArray values -> (* We use a struct update to encode the array aggregate, in order to preserve the structure and allow generating code of the shape `[x0, ...., xn]` *) let values = List.map (typed_value_to_texpression ctx ectx) values in let values = FieldId.mapi (fun fid v -> (fid, v)) values in let su : struct_update = - { struct_id = Assumed Array; init = None; updates = values } + { struct_id = TAssumed Array; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } - | ConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } - | TraitConstValue (trait_ref, generics, const_name) -> + | VaConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } + | VaTraitConstValue (trait_ref, generics, const_name) -> let type_infos = ctx.type_context.type_infos in let trait_ref = translate_fwd_trait_ref type_infos trait_ref in let generics = translate_fwd_generic_args type_infos generics in @@ -2558,7 +2565,7 @@ and translate_forward_end (ectx : C.eval_ctx) let org_args = args in (* Lookup the effect info for the loop function *) - let fid = E.Regular ctx.fun_decl.A.def_id in + let fid = E.FRegular ctx.fun_decl.A.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fid) None ctx.bid in @@ -2661,7 +2668,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = ^ T.RegionGroupId.Map.show (fun (rids, tys) -> "(" ^ T.RegionId.Set.show rids ^ ", " - ^ Print.list_to_string (rty_to_string ctx) tys + ^ Print.list_to_string (ty_to_string ctx) tys ^ ")") loop.rg_to_given_back_tys ^ "\n")); @@ -2925,8 +2932,8 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = | None -> None | Some body -> let effect_info = - get_fun_effect_info ctx.fun_context.fun_infos (FunId (Regular def_id)) - None bid + get_fun_effect_info ctx.fun_context.fun_infos + (FunId (FRegular def_id)) None bid in let body = translate_expression body ctx in (* Add a match over the fuel, if necessary *) @@ -2999,8 +3006,8 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = ^ "\n- back_state: " ^ String.concat ", " (List.map show_var back_state) ^ "\n- signature.inputs: " - ^ String.concat ", " (List.map (ty_to_string ctx) signature.inputs) - )); + ^ String.concat ", " + (List.map (pure_ty_to_string ctx) signature.inputs))); (* TODO: we need to normalize the types *) if !Config.type_check_pure_code then assert ( @@ -3070,7 +3077,7 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) (* The backward functions *) let back_sgs = List.map - (fun (rg : T.region_var_group) -> + (fun (rg : T.region_group) -> let tsg = translate_fun_sig decls_ctx fun_id sg input_names (Some rg.id) in diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 9dd65c84..edd67749 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -32,16 +32,16 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) (* Match on the symbolic value type to know which can of expansion happened *) let expansion = match sv.V.sv_ty with - | T.Literal PV.Bool -> ( + | T.TLiteral PV.TBool -> ( (* Boolean expansion: there should be two branches *) match ls with | [ - (Some (V.SeLiteral (PV.Bool true)), true_exp); - (Some (V.SeLiteral (PV.Bool false)), false_exp); + (Some (V.SeLiteral (PV.VBool true)), true_exp); + (Some (V.SeLiteral (PV.VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) | _ -> raise (Failure "Ill-formed boolean expansion")) - | T.Literal (PV.Integer int_ty) -> + | T.TLiteral (PV.TInteger int_ty) -> (* Switch over an integer: split between the "regular" branches and the "otherwise" branch (which should be the last branch) *) let branches, otherwise = C.List.pop_last ls in @@ -50,7 +50,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) let get_scalar (see : V.symbolic_expansion option) : V.scalar_value = match see with - | Some (V.SeLiteral (PV.Scalar cv)) -> + | Some (V.SeLiteral (PV.VScalar cv)) -> assert (cv.PV.int_ty = int_ty); cv | _ -> raise (Failure "Unreachable") @@ -64,7 +64,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) assert (otherwise_see = None); (* Return *) ExpandInt (int_ty, branches, otherwise) - | T.Adt (_, _) -> + | T.TAdt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) let get_variant (see : V.symbolic_expansion option) : T.VariantId.id option * V.symbolic_value list = @@ -86,7 +86,7 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) | T.TypeVar _ - | T.Literal Char + | T.TLiteral TChar | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> raise (Failure "Ill-formed symbolic expansion") in @@ -99,7 +99,7 @@ let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) synthesize_symbolic_expansion sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) + (abstractions : V.AbstractionId.id list) (generics : T.generic_args) (args : V.typed_value list) (args_places : mplace option list) (dest : V.symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = @@ -126,7 +126,7 @@ let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) let synthesize_regular_function_call (fun_id : A.fun_id_or_trait_method_ref) (call_id : V.FunCallId.id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (generics : T.egeneric_args) + (abstractions : V.AbstractionId.id list) (generics : T.generic_args) (args : V.typed_value list) (args_places : mplace option list) (dest : V.symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = @@ -171,7 +171,7 @@ let synthesize_loop (loop_id : V.LoopId.id) (input_svalues : V.symbolic_value list) (fresh_svalues : V.SymbolicValueId.Set.t) (rg_to_given_back_tys : - (T.RegionId.Set.t * T.rty list) T.RegionGroupId.Map.t) + (T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t) (end_expr : expression option) (loop_expr : expression option) : expression option = match (end_expr, loop_expr) with diff --git a/compiler/Translate.ml b/compiler/Translate.ml index a3d96023..9a6addee 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -61,7 +61,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context *) let forward_sig = - RegularFunIdNotLoopMap.find (E.Regular def_id, None) fun_sigs + RegularFunIdNotLoopMap.find (E.FRegular def_id, None) fun_sigs in let sv_to_var = V.SymbolicValueId.Map.empty in let var_counter = Pure.VarId.generator_zero in @@ -188,7 +188,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) in (* Translate the backward functions *) - let translate_backward (rg : T.region_var_group) : Pure.fun_decl = + let translate_backward (rg : T.region_group) : Pure.fun_decl = (* For the backward inputs/outputs initialization: we use the fact that * there are no nested borrows for now, and so that the region groups * can't have parents *) @@ -200,7 +200,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context - note that the ret_ty is not really * useful as we don't translate a body *) let backward_sg = - RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (FRegular def_id, Some back_id) fun_sigs in let ctx = { ctx with bid = Some back_id; sg = backward_sg.sg } in @@ -211,7 +211,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) variables required by the backward function. *) let backward_sg = - RegularFunIdNotLoopMap.find (Regular def_id, Some back_id) fun_sigs + RegularFunIdNotLoopMap.find (FRegular def_id, Some back_id) fun_sigs in (* We need to ignore the forward inputs, and the state input (if there is) *) let backward_inputs = @@ -298,7 +298,7 @@ let translate_crate_to_pure (crate : A.crate) : let assumed_sigs = List.map (fun (info : Assumed.assumed_fun_info) -> - ( E.Assumed info.fun_id, + ( E.FAssumed info.fun_id, List.map (fun _ -> None) info.fun_sig.inputs, info.fun_sig )) Assumed.assumed_fun_infos @@ -314,7 +314,7 @@ let translate_crate_to_pure (crate : A.crate) : (fun (v : A.var) -> v.name) (LlbcAstUtils.fun_body_get_input_vars body) in - (E.Regular fdef.def_id, input_names, fdef.signature)) + (E.FRegular fdef.def_id, input_names, fdef.signature)) (A.FunDeclId.Map.values crate.functions) in let sigs = List.append assumed_sigs local_sigs in diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 38d350b1..6318c624 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -77,9 +77,8 @@ let partial_type_info_to_type_decl_info (info : partial_type_info) : let partial_type_info_to_ty_info (info : partial_type_info) : ty_info = info.borrows_info -let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) - (infos : type_infos) (ty_info : partial_type_info) (ty : 'r ty) : - partial_type_info = +let analyze_full_ty (updated : bool ref) (infos : type_infos) + (ty_info : partial_type_info) (ty : ty) : partial_type_info = (* Small utility *) let check_update_bool (original : bool) (nv : bool) : bool = if nv && not original then ( @@ -87,6 +86,7 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) nv) else original in + let r_is_static (r : region) : bool = r = RStatic in (* Update a partial_type_info, while registering if we actually performed an update *) let update_ty_info (ty_info : partial_type_info) @@ -119,9 +119,9 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) (* The recursive function which explores the type *) let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) - (ty : 'r ty) : partial_type_info = + (ty : ty) : partial_type_info = match ty with - | Literal _ | Never | TraitType _ -> ty_info + | TLiteral _ | Never | TraitType _ -> ty_info | TypeVar var_id -> ( (* Update the information for the proper parameter, if necessary *) match ty_info.param_infos with @@ -171,12 +171,12 @@ let analyze_full_ty (r_is_static : 'r -> bool) (updated : bool ref) | RawPtr (rty, _) -> (* TODO: not sure what to do here *) analyze expl_info ty_info rty - | Adt ((Tuple | Assumed (Box | Slice | Array | Str)), generics) -> + | TAdt ((Tuple | TAssumed (TBox | TSlice | TArray | TStr)), generics) -> (* Nothing to update: just explore the type parameters *) List.fold_left (fun ty_info ty -> analyze expl_info ty_info ty) ty_info generics.types - | Adt (AdtId adt_id, generics) -> + | TAdt (AdtId adt_id, generics) -> (* Lookup the information for this type definition *) let adt_info = TypeDeclId.Map.find adt_id infos in (* Update the type info with the information from the adt *) @@ -255,7 +255,7 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) if type_decl_is_opaque def then infos else (* Retrieve all the types of all the fields of all the variants *) - let fields_tys : sty list = + let fields_tys : ty list = match def.kind with | Struct fields -> List.map (fun f -> f.field_ty) fields | Enum variants -> @@ -266,13 +266,12 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) | Opaque -> raise (Failure "unreachable") in (* Explore the types and accumulate information *) - let r_is_static r = r = Static in let type_decl_info = TypeDeclId.Map.find def.def_id infos in let type_decl_info = type_decl_info_to_partial_type_info type_decl_info in let type_decl_info = List.fold_left (fun type_decl_info ty -> - analyze_full_ty r_is_static updated infos type_decl_info ty) + analyze_full_ty updated infos type_decl_info ty) type_decl_info fields_tys in let type_decl_info = partial_type_info_to_type_decl_info type_decl_info in @@ -324,12 +323,11 @@ let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) (** Analyze a type to check whether it contains borrows, etc., provided we have already analyzed the type definitions in the context. *) -let analyze_ty (infos : type_infos) (ty : 'r ty) : ty_info = +let analyze_ty (infos : type_infos) (ty : ty) : ty_info = (* We don't use [updated] but need to give it as parameter *) let updated = ref false in (* We don't need to compute whether the type contains 'static or not *) - let r_is_static _ = false in let ty_info = initialize_g_type_info None in - let ty_info = analyze_full_ty r_is_static updated infos ty_info ty in + let ty_info = analyze_full_ty updated infos ty_info ty in (* Convert the ty_info *) partial_type_info_to_ty_info ty_info diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml index c7f0fbc3..54a12023 100644 --- a/compiler/TypesUtils.ml +++ b/compiler/TypesUtils.ml @@ -1,4 +1,5 @@ open Types +open Utils include Charon.TypesUtils module TA = TypesAnalysis @@ -8,7 +9,7 @@ module TA = TypesAnalysis we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, and when a type uses 'static this region doesn't appear in the region parameters. *) -let ty_has_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = +let ty_has_borrows (infos : TA.type_infos) (ty : ty) : bool = let info = TA.analyze_ty infos ty in info.TA.contains_borrow @@ -18,11 +19,91 @@ let ty_has_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, and when a type uses 'static this region doesn't appear in the region parameters. *) -let ty_has_nested_borrows (infos : TA.type_infos) (ty : 'r ty) : bool = +let ty_has_nested_borrows (infos : TA.type_infos) (ty : ty) : bool = let info = TA.analyze_ty infos ty in info.TA.contains_nested_borrows (** Retuns true if the type contains a borrow under a mutable borrow *) -let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : 'r ty) : bool = +let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : ty) : bool = let info = TA.analyze_ty infos ty in info.TA.contains_borrow_under_mut + +(** Small helper *) +let raise_if_erased_ty_visitor = + object + inherit [_] iter_ty + method! visit_RErased _ = raise Found + end + +(** Return [true] if the type is a region type (i.e., it doesn't contain erased regions) *) +let ty_is_rty (ty : ty) : bool = + try + raise_if_erased_ty_visitor#visit_ty () ty; + true + with Found -> false + +(** Small helper *) +let raise_if_not_erased_ty_visitor = + object + inherit [_] iter_ty + method! visit_RStatic _ = raise Found + method! visit_RVar _ = raise Found + end + +(** Return [true] if the type is a region type (i.e., it doesn't contain erased regions) *) +let ty_is_ety (ty : ty) : bool = + try + raise_if_not_erased_ty_visitor#visit_ty () ty; + true + with Found -> false + +let generic_args_only_erased_regions (x : generic_args) : bool = + try + raise_if_not_erased_ty_visitor#visit_generic_args () x; + true + with Found -> false + +(** Small helper *) +let raise_if_region_ty_visitor = + object + inherit [_] iter_ty + method! visit_region _ _ = raise Found + end + +(** Return [true] if the type doesn't contain regions (including erased regions) *) +let ty_no_regions (ty : ty) : bool = + try + raise_if_region_ty_visitor#visit_ty () ty; + true + with Found -> false + +(** Return [true] if the trait ref doesn't contain regions (including erased regions) *) +let trait_ref_no_regions (x : trait_ref) : bool = + try + raise_if_region_ty_visitor#visit_trait_ref () x; + true + with Found -> false + +(** Return [true] if the trait instance id doesn't contain regions (including erased regions) *) +let trait_instance_id_no_regions (x : trait_instance_id) : bool = + try + raise_if_region_ty_visitor#visit_trait_instance_id () x; + true + with Found -> false + +(** Return [true] if the generic args don't contain regions (including erased regions) *) +let generic_args_no_regions (x : generic_args) : bool = + try + raise_if_region_ty_visitor#visit_generic_args () x; + true + with Found -> false + +(** Return [true] if the trait type constraint doesn't contain regions (including erased regions) *) +let trait_type_constraint_no_regions (x : trait_type_constraint) : bool = + try + let { trait_ref; generics; type_name = _; ty } = x in + raise_if_region_ty_visitor#visit_trait_ref () trait_ref; + raise_if_region_ty_visitor#visit_generic_args () generics; + raise_if_region_ty_visitor#visit_ty () ty; + true + with Found -> false diff --git a/compiler/Values.ml b/compiler/Values.ml index de27e7a9..8526ea66 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -58,55 +58,6 @@ type sv_kind = (** A symbolic value we introduce when evaluating a trait associated constant *) [@@deriving show, ord] -(** Ancestor for {!symbolic_value} iter visitor *) -class ['self] iter_symbolic_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.iter - method visit_sv_kind : 'env -> sv_kind -> unit = fun _ _ -> () - method visit_rty : 'env -> rty -> unit = fun _ _ -> () - - method visit_symbolic_value_id : 'env -> symbolic_value_id -> unit = - fun _ _ -> () - end - -(** Ancestor for {!symbolic_value} map visitor for *) -class ['self] map_symbolic_value_base = - object (_self : 'self) - inherit [_] VisitorsRuntime.map - method visit_sv_kind : 'env -> sv_kind -> sv_kind = fun _ x -> x - method visit_rty : 'env -> rty -> rty = fun _ x -> x - - method visit_symbolic_value_id - : 'env -> symbolic_value_id -> symbolic_value_id = - fun _ x -> x - end - -(** A symbolic value *) -type symbolic_value = { - sv_kind : sv_kind; - sv_id : symbolic_value_id; - sv_ty : rty; -} -[@@deriving - show, - ord, - visitors - { - name = "iter_symbolic_value"; - variety = "iter"; - ancestors = [ "iter_symbolic_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_symbolic_value"; - variety = "map"; - ancestors = [ "map_symbolic_value_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - type borrow_id = BorrowId.id [@@deriving show, ord] type borrow_id_set = BorrowId.Set.t [@@deriving show, ord] type loan_id = BorrowId.id [@@deriving show, ord] @@ -115,11 +66,13 @@ type loan_id_set = BorrowId.Set.t [@@deriving show, ord] (** Ancestor for {!typed_value} iter visitor *) class ['self] iter_typed_value_base = object (self : 'self) - inherit [_] iter_symbolic_value - method visit_literal : 'env -> literal -> unit = fun _ _ -> () - method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () + inherit [_] iter_ty + method visit_sv_kind : 'env -> sv_kind -> unit = fun _ _ -> () + + method visit_symbolic_value_id : 'env -> symbolic_value_id -> unit = + fun _ _ -> () + method visit_variant_id : 'env -> variant_id -> unit = fun _ _ -> () - method visit_ety : 'env -> ety -> unit = fun _ _ -> () method visit_borrow_id : 'env -> borrow_id -> unit = fun _ _ -> () method visit_loan_id : 'env -> loan_id -> unit = fun _ _ -> () @@ -133,13 +86,13 @@ class ['self] iter_typed_value_base = (** Ancestor for {!typed_value} map visitor for *) class ['self] map_typed_value_base = object (self : 'self) - inherit [_] map_symbolic_value - method visit_literal : 'env -> literal -> literal = fun _ cv -> cv + inherit [_] map_ty + method visit_sv_kind : 'env -> sv_kind -> sv_kind = fun _ x -> x - method visit_erased_region : 'env -> erased_region -> erased_region = - fun _ r -> r + method visit_symbolic_value_id + : 'env -> symbolic_value_id -> symbolic_value_id = + fun _ x -> x - method visit_ety : 'env -> ety -> ety = fun _ ty -> ty method visit_variant_id : 'env -> variant_id -> variant_id = fun _ x -> x method visit_borrow_id : 'env -> borrow_id -> borrow_id = fun _ id -> id method visit_loan_id : 'env -> loan_id -> loan_id = fun _ id -> id @@ -151,10 +104,17 @@ class ['self] map_typed_value_base = fun env ids -> BorrowId.Set.map (self#visit_loan_id env) ids end -(** An untyped value, used in the environments *) -type value = - | Literal of literal (** Non-symbolic primitive value *) - | Adt of adt_value (** Enumerations and structures *) +(** A symbolic value *) +type symbolic_value = { + sv_kind : sv_kind; + sv_id : symbolic_value_id; + sv_ty : ty; (** This should be a type with regions *) +} + +(** An untyped value, used in the environments - TODO: prefix the names with "V" *) +and value = + | VLiteral of literal (** Non-symbolic primitive value *) + | VAdt of adt_value (** Enumerations and structures *) | Bottom (** No value (uninitialized or moved value) *) | Borrow of borrow_content (** A borrowed value *) | Loan of loan_content (** A loaned value *) @@ -215,25 +175,14 @@ and loan_content = | SharedLoan of loan_id_set * typed_value | MutLoan of loan_id -(** "Meta"-value: information we store for the synthesis. - - Note that we never automatically visit the meta-values with the - visitors: they really are meta information, and shouldn't be considered - as part of the environment during a symbolic execution. - - TODO: we may want to create wrappers, to prevent accidently mixing meta - values and regular values. - *) -and mvalue = typed_value - (** "Regular" typed value (we map variables to typed values) *) -and typed_value = { value : value; ty : ety } +and typed_value = { value : value; ty : ty } [@@deriving show, ord, visitors { - name = "iter_typed_value_visit_mvalue"; + name = "iter_typed_value"; variety = "iter"; ancestors = [ "iter_typed_value_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); @@ -241,13 +190,24 @@ and typed_value = { value : value; ty : ety } }, visitors { - name = "map_typed_value_visit_mvalue"; + name = "map_typed_value"; variety = "map"; ancestors = [ "map_typed_value_base" ]; nude = true (* Don't inherit {!VisitorsRuntime.iter} *); concrete = true; }] +(** "Meta"-value: information we store for the synthesis. + + Note that we never automatically visit the meta-values with the + visitors: they really are meta information, and shouldn't be considered + as part of the environment during a symbolic execution. + + TODO: we may want to create wrappers, to prevent accidently mixing meta + values and regular values. + *) +type mvalue = typed_value [@@deriving show, ord] + (** "Meta"-symbolic value. See the explanations for {!mvalue} @@ -257,28 +217,47 @@ and typed_value = { value : value; ty : ety } *) type msymbolic_value = symbolic_value [@@deriving show, ord] -class ['self] iter_typed_value = - object (_self : 'self) - inherit [_] iter_typed_value_visit_mvalue +type region_id = RegionId.id [@@deriving show, ord] +type region_id_set = RegionId.Set.t [@@deriving show, ord] +type abstraction_id = AbstractionId.id [@@deriving show, ord] +type abstraction_id_set = AbstractionId.Set.t [@@deriving show, ord] - (** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) - method! visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () +(** Ancestor for {!typed_avalue} iter visitor *) +class ['self] iter_typed_avalue_base = + object (self : 'self) + inherit [_] iter_typed_value + method visit_mvalue : 'env -> mvalue -> unit = fun _ _ -> () method visit_msymbolic_value : 'env -> msymbolic_value -> unit = fun _ _ -> () - end -class ['self] map_typed_value = - object (_self : 'self) - inherit [_] map_typed_value_visit_mvalue + method visit_region_id_set : 'env -> region_id_set -> unit = + fun env ids -> RegionId.Set.iter (self#visit_region_id env) ids + + method visit_abstraction_id : 'env -> abstraction_id -> unit = fun _ _ -> () - (** We have to override the {!iter_typed_value_visit_mvalue.visit_mvalue} method, - to ignore meta-values *) - method! visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x + method visit_abstraction_id_set : 'env -> abstraction_id_set -> unit = + fun env ids -> AbstractionId.Set.iter (self#visit_abstraction_id env) ids + end + +(** Ancestor for {!typed_avalue} map visitor *) +class ['self] map_typed_avalue_base = + object (self : 'self) + inherit [_] map_typed_value + method visit_mvalue : 'env -> mvalue -> mvalue = fun _ x -> x method visit_msymbolic_value : 'env -> msymbolic_value -> msymbolic_value = fun _ m -> m + + method visit_region_id_set : 'env -> region_id_set -> region_id_set = + fun env ids -> RegionId.Set.map (self#visit_region_id env) ids + + method visit_abstraction_id : 'env -> abstraction_id -> abstraction_id = + fun _ x -> x + + method visit_abstraction_id_set + : 'env -> abstraction_id_set -> abstraction_id_set = + fun env ids -> AbstractionId.Set.map (self#visit_abstraction_id env) ids end (** When giving shared borrows to functions (i.e., inserting shared borrows inside @@ -297,62 +276,12 @@ class ['self] map_typed_value = *) type abstract_shared_borrow = | AsbBorrow of borrow_id - | AsbProjReborrows of symbolic_value * rty -[@@deriving - show, - ord, - visitors - { - name = "iter_abstract_shared_borrow"; - variety = "iter"; - ancestors = [ "iter_typed_value" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_abstract_shared_borrow"; - variety = "map"; - ancestors = [ "map_typed_value" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] + | AsbProjReborrows of symbolic_value * ty (** A set of abstract shared borrows *) -type abstract_shared_borrows = abstract_shared_borrow list -[@@deriving - show, - ord, - visitors - { - name = "iter_abstract_shared_borrows"; - variety = "iter"; - ancestors = [ "iter_abstract_shared_borrow" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_abstract_shared_borrows"; - variety = "map"; - ancestors = [ "map_abstract_shared_borrow" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -(** Ancestor for {!aproj} iter visitor *) -class ['self] iter_aproj_base = - object (_self : 'self) - inherit [_] iter_abstract_shared_borrows - end - -(** Ancestor for {!aproj} map visitor *) -class ['self] map_aproj_base = - object (_self : 'self) - inherit [_] map_abstract_shared_borrows - end +and abstract_shared_borrows = abstract_shared_borrow list -type aproj = +and aproj = | AProjLoans of symbolic_value * (msymbolic_value * aproj) list (** A projector of loans over a symbolic value. @@ -393,7 +322,7 @@ type aproj = anywhere in the context below a projector of borrows which intersects this projector of loans. *) - | AProjBorrows of symbolic_value * rty + | AProjBorrows of symbolic_value * ty (** Note that an AProjBorrows only operates on a value which is not below a shared loan: under a shared loan, we use {!abstract_shared_borrow}. @@ -414,82 +343,6 @@ type aproj = ending the borrow. *) | AIgnoredProjBorrows -[@@deriving - show, - ord, - visitors - { - name = "iter_aproj"; - variety = "iter"; - ancestors = [ "iter_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }, - visitors - { - name = "map_aproj"; - variety = "map"; - ancestors = [ "map_aproj_base" ]; - nude = true (* Don't inherit {!VisitorsRuntime.iter} *); - concrete = true; - }] - -type region = RegionVarId.id Types.region [@@deriving show, ord] -type region_var_id = RegionVarId.id [@@deriving show, ord] -type region_id = RegionId.id [@@deriving show, ord] -type region_id_set = RegionId.Set.t [@@deriving show, ord] -type abstraction_id = AbstractionId.id [@@deriving show, ord] -type abstraction_id_set = AbstractionId.Set.t [@@deriving show, ord] - -(** Ancestor for {!typed_avalue} iter visitor *) -class ['self] iter_typed_avalue_base = - object (self : 'self) - inherit [_] iter_aproj - method visit_region_var_id : 'env -> region_var_id -> unit = fun _ _ -> () - - method visit_region : 'env -> region -> unit = - fun env r -> - match r with - | Static -> () - | Var rid -> self#visit_region_var_id env rid - - method visit_region_id : 'env -> region_id -> unit = fun _ _ -> () - - method visit_region_id_set : 'env -> region_id_set -> unit = - fun env ids -> RegionId.Set.iter (self#visit_region_id env) ids - - method visit_abstraction_id : 'env -> abstraction_id -> unit = fun _ _ -> () - - method visit_abstraction_id_set : 'env -> abstraction_id_set -> unit = - fun env ids -> AbstractionId.Set.iter (self#visit_abstraction_id env) ids - end - -(** Ancestor for {!typed_avalue} map visitor *) -class ['self] map_typed_avalue_base = - object (self : 'self) - inherit [_] map_aproj - - method visit_region_var_id : 'env -> region_var_id -> region_var_id = - fun _ x -> x - - method visit_region : 'env -> region -> region = - fun env r -> - match r with - | Static -> Static - | Var rid -> Var (self#visit_region_var_id env rid) - - method visit_region_id : 'env -> region_id -> region_id = fun _ x -> x - - method visit_region_id_set : 'env -> region_id_set -> region_id_set = - fun env ids -> RegionId.Set.map (self#visit_region_id env) ids - - method visit_abstraction_id : 'env -> abstraction_id -> abstraction_id = - fun _ x -> x - - method visit_abstraction_id_set - : 'env -> abstraction_id_set -> abstraction_id_set = - fun env ids -> AbstractionId.Set.map (self#visit_abstraction_id env) ids - end (** Abstraction values are used inside of abstractions to properly model borrowing relations introduced by function calls. @@ -497,7 +350,7 @@ class ['self] map_typed_avalue_base = When calling a function, we lose information about the borrow graph: part of it is thus "abstracted" away. *) -type avalue = +and avalue = | AAdt of adt_avalue | ABottom (* TODO: remove once we change the way internal borrows are ended *) | ALoan of aloan_content @@ -875,7 +728,10 @@ and aborrow_content = To be more precise, shared aloans have the borrow type (i.e., a shared aloan has type [& (mut) T] instead of [T]). *) -and typed_avalue = { value : avalue; ty : rty } +and typed_avalue = { + value : avalue; + ty : ty; (** This should be a type with regions *) +} [@@deriving show, ord, diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 527434c1..24485002 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -9,13 +9,27 @@ include PrimitiveValuesUtils exception FoundSymbolicValue of symbolic_value let mk_unit_value : typed_value = - { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } + { value = VAdt { variant_id = None; field_values = [] }; ty = mk_unit_ty } -let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } -let mk_typed_avalue (ty : rty) (value : avalue) : typed_avalue = { value; ty } -let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } -let mk_abottom (ty : rty) : typed_avalue = { value = ABottom; ty } -let mk_aignored (ty : rty) : typed_avalue = { value = AIgnored; ty } +let mk_typed_value (ty : ty) (value : value) : typed_value = + assert (ty_is_ety ty); + { value; ty } + +let mk_typed_avalue (ty : ty) (value : avalue) : typed_avalue = + assert (ty_is_rty ty); + { value; ty } + +let mk_bottom (ty : ty) : typed_value = + assert (ty_is_ety ty); + { value = Bottom; ty } + +let mk_abottom (ty : ty) : typed_avalue = + assert (ty_is_rty ty); + { value = ABottom; ty } + +let mk_aignored (ty : ty) : typed_avalue = + assert (ty_is_rty ty); + { value = AIgnored; ty } let value_as_symbolic (v : value) : symbolic_value = match v with Symbolic v -> v | _ -> raise (Failure "Unexpected") @@ -23,7 +37,7 @@ let value_as_symbolic (v : value) : symbolic_value = (** Box a value *) let mk_box_value (v : typed_value) : typed_value = let box_ty = mk_box_ty v.ty in - let box_v = Adt { variant_id = None; field_values = [ v ] } in + let box_v = VAdt { variant_id = None; field_values = [ v ] } in mk_typed_value box_ty box_v let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false @@ -46,7 +60,7 @@ let is_unit (v : typed_value) : bool = ty_is_unit v.ty && match v.value with - | Adt av -> av.variant_id = None && av.field_values = [] + | VAdt av -> av.variant_id = None && av.field_values = [] | _ -> false (** Check if a value contains a *concrete* borrow (i.e., a [Borrow] value - -- cgit v1.2.3 From 0a5859fbb7bcd99bfa221eaf1af029ff660bf963 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 12 Nov 2023 19:35:24 +0100 Subject: Rename some variants --- compiler/Assumed.ml | 2 +- compiler/ExtractTypes.ml | 6 +++--- compiler/Interpreter.ml | 2 +- compiler/InterpreterExpressions.ml | 2 +- compiler/PrintPure.ml | 6 +++--- compiler/PureUtils.ml | 2 +- compiler/Substitute.ml | 4 ++-- compiler/SymbolicAst.ml | 2 +- compiler/SymbolicToPure.ml | 4 ++-- 9 files changed, 15 insertions(+), 15 deletions(-) diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index d8f19173..5622ef26 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -43,7 +43,7 @@ module Sig = struct let tvar_id_0 = T.TypeVarId.of_int 0 let tvar_0 : T.ty = T.TypeVar tvar_id_0 let cgvar_id_0 = T.ConstGenericVarId.of_int 0 - let cgvar_0 : T.const_generic = T.ConstGenericVar cgvar_id_0 + let cgvar_0 : T.const_generic = T.CGVar cgvar_id_0 (** Region 'a of id 0 *) let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 48273023..902b7e25 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1119,11 +1119,11 @@ let extract_arrow (fmt : F.formatter) () : unit = let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (cg : const_generic) : unit = match cg with - | ConstGenericGlobal id -> + | CGGlobal 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 -> + | CGValue v -> ctx.fmt.extract_literal fmt inside v + | CGVar id -> let s = ctx_get_const_generic_var id ctx in F.pp_print_string fmt s diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index bc28bcd6..b1178aa7 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -74,7 +74,7 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) 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) + (fun (v : T.const_generic_var) -> T.CGVar v.T.index) const_generics in (* Annoying that we have to generate this substitution here *) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index f4430c77..c7fcc1af 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -329,7 +329,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ( ctx0, None, value_as_symbolic v.value, - SymbolicAst.VaConstGenericValue vid, + SymbolicAst.VaCGValue vid, e ))) | E.CFnPtr _ -> raise (Failure "TODO")) | E.Copy p -> diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index cd156215..7c52c423 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -211,9 +211,9 @@ let type_id_to_string (fmt : type_formatter) (id : type_id) : string = let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : string = match cg with - | ConstGenericGlobal id -> fmt.global_decl_id_to_string id - | ConstGenericVar id -> fmt.const_generic_var_id_to_string id - | ConstGenericValue lit -> literal_to_string lit + | CGGlobal id -> fmt.global_decl_id_to_string id + | CGVar id -> fmt.const_generic_var_id_to_string id + | CGValue lit -> literal_to_string lit let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = match ty with diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 5e46d551..49c8dd70 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -111,7 +111,7 @@ let ty_substitute (subst : subst) (ty : ty) : ty = object inherit [_] map_ty method! visit_TypeVar _ var_id = subst.ty_subst var_id - method! visit_ConstGenericVar _ var_id = subst.cg_subst var_id + method! visit_CGVar _ var_id = subst.cg_subst var_id method! visit_Clause _ id = subst.tr_subst id method! visit_Self _ = subst.tr_self end diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index b4eee9f8..490574a2 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -29,7 +29,7 @@ let st_substitute_visitor (subst : subst) = (* We should never get here because we reimplemented [visit_TypeVar] *) raise (Failure "Unexpected") - method! visit_ConstGenericVar _ id = subst.cg_subst id + method! visit_CGVar _ id = subst.cg_subst id method! visit_const_generic_var_id _ _ = (* We should never get here because we reimplemented [visit_Var] *) @@ -68,7 +68,7 @@ let erase_regions_subst : subst = { r_subst = (fun _ -> T.RErased); ty_subst = (fun vid -> T.TypeVar vid); - cg_subst = (fun id -> T.ConstGenericVar id); + cg_subst = (fun id -> T.CGVar id); tr_subst = (fun id -> T.Clause id); tr_self = T.Self; } diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 927544b2..d114f18d 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -243,7 +243,7 @@ and value_aggregate = | VaSingleValue of V.typed_value (** Regular case *) | VaArray of V.typed_value list (** This is used when introducing array aggregates *) - | VaConstGenericValue of T.const_generic_var_id + | VaCGValue of T.const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) | VaTraitConstValue of T.trait_ref * T.generic_args * string diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 97755438..91edbf04 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2487,7 +2487,7 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) { struct_id = TAssumed Array; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } - | VaConstGenericValue cg_id -> { e = CVar cg_id; ty = var.ty } + | VaCGValue cg_id -> { e = CVar cg_id; ty = var.ty } | VaTraitConstValue (trait_ref, generics, const_name) -> let type_infos = ctx.type_context.type_infos in let trait_ref = translate_fwd_trait_ref type_infos trait_ref in @@ -2740,7 +2740,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = in let const_generics = List.map - (fun (cg : T.const_generic_var) -> T.ConstGenericVar cg.T.index) + (fun (cg : T.const_generic_var) -> T.CGVar cg.T.index) const_generics in let trait_refs = -- cgit v1.2.3 From 6ef68fa9ffd4caec09677ee2800a778080d6da34 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 12 Nov 2023 20:04:11 +0100 Subject: Prefix variants related to types with "T" --- compiler/AssociatedTypes.ml | 22 ++--- compiler/Assumed.ml | 12 +-- compiler/Extract.ml | 14 ++-- compiler/ExtractBase.ml | 27 ++++--- compiler/ExtractTypes.ml | 142 ++++++++++++++++----------------- compiler/Interpreter.ml | 2 +- compiler/InterpreterBorrows.ml | 4 +- compiler/InterpreterBorrowsCore.ml | 10 +-- compiler/InterpreterExpansion.ml | 16 ++-- compiler/InterpreterExpressions.ml | 16 ++-- compiler/InterpreterLoopsFixedPoint.ml | 2 +- compiler/InterpreterLoopsMatchCtxs.ml | 10 +-- compiler/InterpreterPaths.ml | 12 +-- compiler/InterpreterProjectors.ml | 8 +- compiler/InterpreterStatements.ml | 8 +- compiler/Invariants.ml | 12 +-- compiler/PrePasses.ml | 2 +- compiler/Print.ml | 8 +- compiler/PrintPure.ml | 70 ++++++++-------- compiler/Pure.ml | 24 +++--- compiler/PureMicroPasses.ml | 12 +-- compiler/PureTypeCheck.ml | 18 ++--- compiler/PureUtils.ml | 58 +++++++------- compiler/Substitute.ml | 8 +- compiler/SymbolicToPure.ml | 104 ++++++++++++------------ compiler/SynthesizeSymbolic.ml | 6 +- compiler/TypesAnalysis.ml | 14 ++-- 27 files changed, 320 insertions(+), 321 deletions(-) diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index c76af138..d5c9596e 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -55,7 +55,7 @@ let compute_norm_trait_types_from_preds that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) assert (TU.trait_type_constraint_no_regions c); - let trait_ty = T.TraitType (c.trait_ref, c.generics, c.type_name) in + let trait_ty = T.TTraitType (c.trait_ref, c.generics, c.type_name) in let trait_ty_ref = get_ref trait_ty in let ty_ref = get_ref c.ty in let new_repr = UF.get ty_ref in @@ -76,7 +76,7 @@ let compute_norm_trait_types_from_preds List.filter_map (fun (k, v) -> match k with - | T.TraitType (trait_ref, generics, type_name) -> + | T.TTraitType (trait_ref, generics, type_name) -> assert (generics = TypesUtils.mk_empty_generic_args); Some ({ C.trait_ref; type_name }, v) | _ -> None) @@ -182,18 +182,18 @@ let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = log#ldebug (lazy ("ctx_normalize_ty: " ^ ty_to_string ctx ty)); match ty with | T.TAdt (id, generics) -> TAdt (id, ctx_normalize_generic_args ctx generics) - | TypeVar _ | TLiteral _ | Never -> ty - | Ref (r, ty, rkind) -> + | TVar _ | TLiteral _ | TNever -> ty + | TRef (r, ty, rkind) -> let ty = ctx_normalize_ty ctx ty in - T.Ref (r, ty, rkind) - | RawPtr (ty, rkind) -> + T.TRef (r, ty, rkind) + | TRawPtr (ty, rkind) -> let ty = ctx_normalize_ty ctx ty in - RawPtr (ty, rkind) - | Arrow (inputs, output) -> + TRawPtr (ty, rkind) + | TArrow (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) -> ( + TArrow (inputs, output) + | TTraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy ("ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty @@ -250,7 +250,7 @@ let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); - T.TraitType (trait_ref, generics, type_name) + T.TTraitType (trait_ref, generics, type_name) in let tr : C.trait_type_ref = { C.trait_ref; type_name } in (* Lookup the representative, if there is *) diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 5622ef26..cf81502c 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -41,7 +41,7 @@ module Sig = struct let rvar_0 : T.region = T.RVar rvar_id_0 let rg_id_0 = T.RegionGroupId.of_int 0 let tvar_id_0 = T.TypeVarId.of_int 0 - let tvar_0 : T.ty = T.TypeVar tvar_id_0 + let tvar_0 : T.ty = T.TVar tvar_id_0 let cgvar_id_0 = T.ConstGenericVarId.of_int 0 let cgvar_0 : T.const_generic = T.CGVar cgvar_id_0 @@ -150,13 +150,13 @@ module Sig = struct let mk_array_slice_index_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) + if is_array then mk_array_ty (T.TVar id) cgvar_0 + else mk_slice_ty (T.TVar id) in (* usize *) let index_ty = usize_ty in (* T *) - let output_ty id = T.TypeVar id in + let output_ty id = T.TVar id in let cgs = if is_array then [ cg_param_0 ] else [] in mk_array_slice_borrow_sig cgs input_ty (Some index_ty) output_ty is_mut @@ -165,9 +165,9 @@ module Sig = struct let array_to_slice_sig (is_mut : bool) : A.fun_sig = (* Array *) - let input_ty id = mk_array_ty (T.TypeVar id) cgvar_0 in + let input_ty id = mk_array_ty (T.TVar id) cgvar_0 in (* Slice *) - let output_ty id = mk_slice_ty (T.TypeVar id) in + let output_ty id = mk_slice_ty (T.TVar id) in let cgs = [ cg_param_0 ] in mk_array_slice_borrow_sig cgs input_ty None output_ty is_mut diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 24999c7d..04f6c2c3 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -124,7 +124,7 @@ let extract_adt_g_value (inside : bool) (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : extraction_ctx = match ty with - | TAdt (Tuple, generics) -> + | TAdt (TTuple, generics) -> (* Tuple *) (* For now, we only support fully applied tuple constructors *) assert (List.length generics.types = List.length field_values); @@ -871,7 +871,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) thus extracted to unit. We need to check that by looking up the definition *) let extract_as_unit = match (!backend, supd.struct_id) with - | HOL4, AdtId adt_id -> + | HOL4, TAdtId adt_id -> let d = TypeDeclId.Map.find adt_id ctx.trans_ctx.type_ctx.type_decls in d.kind = Struct [] | _ -> false @@ -885,7 +885,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) - this is an array *) match supd.struct_id with - | AdtId _ -> + | TAdtId _ -> F.pp_open_hvbox fmt 0; F.pp_open_hvbox fmt ctx.indent_incr; (* Inner/outer brackets: there are several syntaxes for the field updates. @@ -966,7 +966,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) if need_paren then F.pp_print_string fmt ")"; print_bracket false orb; F.pp_close_box fmt () - | TAssumed Array -> + | TAssumed TArray -> (* Open the boxes *) F.pp_open_hvbox fmt ctx.indent_incr; let need_paren = inside in @@ -974,7 +974,7 @@ and extract_StructUpdate (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for `Array.replicate T N [` *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print the array constructor *) - let cs = ctx_get_struct (TAssumed Array) ctx in + let cs = ctx_get_struct (TAssumed TArray) ctx in F.pp_print_string fmt cs; (* Print the parameters *) let _, generics = ty_as_adt e_ty in @@ -2662,7 +2662,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "="; F.pp_print_space fmt (); - let success = ctx_get_variant (TAssumed Result) result_return_id ctx in + let success = ctx_get_variant (TAssumed TResult) result_return_id ctx in F.pp_print_string fmt (success ^ " ())") | Coq -> F.pp_print_string fmt "Check"; @@ -2691,7 +2691,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt (); F.pp_print_string fmt "=="; F.pp_print_space fmt (); - let success = ctx_get_variant (TAssumed Result) result_return_id ctx in + let success = ctx_get_variant (TAssumed TResult) result_return_id ctx in F.pp_print_string fmt ("." ^ success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 272e6396..d5eac6f4 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -672,11 +672,11 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = (* TODO: factorize the pretty-printing with what is in PrintPure *) let get_type_name (id : type_id) : string = match id with - | AdtId id -> + | TAdtId id -> let def = TypeDeclId.Map.find id type_decls in Print.name_to_string def.name | TAssumed aty -> show_assumed_ty aty - | Tuple -> raise (Failure "Unreachable") + | TTuple -> raise (Failure "Unreachable") in match id with | GlobalId gid -> @@ -744,26 +744,26 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | VariantId (id, variant_id) -> let variant_name = match id with - | Tuple -> raise (Failure "Unreachable") - | TAssumed Result -> + | TTuple -> raise (Failure "Unreachable") + | TAssumed TResult -> if variant_id = result_return_id then "@result::Return" else if variant_id = result_fail_id then "@result::Fail" else raise (Failure "Unreachable") - | TAssumed Error -> + | TAssumed TError -> if variant_id = error_failure_id then "@error::Failure" else if variant_id = error_out_of_fuel_id then "@error::OutOfFuel" else raise (Failure "Unreachable") - | TAssumed Fuel -> + | TAssumed TFuel -> if variant_id = fuel_zero_id then "@fuel::0" else if variant_id = fuel_succ_id then "@fuel::Succ" else raise (Failure "Unreachable") - | TAssumed (State | Array | Slice | Str | RawPtr _) -> + | TAssumed (TState | TArray | TSlice | TStr | TRawPtr _) -> raise (Failure ("Unreachable: variant id (" ^ VariantId.to_string variant_id ^ ") for " ^ show_type_id id)) - | AdtId id -> ( + | TAdtId id -> ( let def = TypeDeclId.Map.find id type_decls in match def.kind with | Struct _ | Opaque -> raise (Failure "Unreachable") @@ -775,12 +775,13 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | FieldId (id, field_id) -> let field_name = match id with - | Tuple -> raise (Failure "Unreachable") + | TTuple -> raise (Failure "Unreachable") | TAssumed - (State | Result | Error | Fuel | Array | Slice | Str | RawPtr _) -> + ( TState | TResult | TError | TFuel | TArray | TSlice | TStr + | TRawPtr _ ) -> (* We can't directly have access to the fields of those types *) raise (Failure "Unreachable") - | AdtId id -> ( + | TAdtId id -> ( let def = TypeDeclId.Map.find id type_decls in match def.kind with | Enum _ | Opaque -> raise (Failure "Unreachable") @@ -954,11 +955,11 @@ let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) ctx_get_function (FromLlbc (FunId (FRegular id), lp, rg)) ctx let ctx_get_type (id : type_id) (ctx : extraction_ctx) : string = - assert (id <> Tuple); + assert (id <> TTuple); ctx_get (TypeId id) ctx let ctx_get_local_type (id : TypeDeclId.id) (ctx : extraction_ctx) : string = - ctx_get_type (AdtId id) ctx + ctx_get_type (TAdtId id) ctx let ctx_get_assumed_type (id : assumed_ty) (ctx : extraction_ctx) : string = ctx_get_type (TAssumed id) ctx diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 902b7e25..553d5863 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -226,69 +226,69 @@ 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"); + (TState, "State"); + (TResult, "Result"); + (TError, "Error"); + (TFuel, "Nat"); + (TArray, "Array"); + (TSlice, "Slice"); + (TStr, "Str"); + (TRawPtr Mut, "MutRawPtr"); + (TRawPtr 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"); + (TState, "state"); + (TResult, "result"); + (TError, "error"); + (TFuel, if !backend = HOL4 then "num" else "nat"); + (TArray, "array"); + (TSlice, "slice"); + (TStr, "str"); + (TRawPtr Mut, "mut_raw_ptr"); + (TRawPtr 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") ] + | Lean -> [ (TArray, "Array.make") ] + | Coq -> [ (TArray, "mk_array") ] + | FStar -> [ (TArray, "mk_array") ] + | HOL4 -> [ (TArray, "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"); + (TResult, result_return_id, "Return"); + (TResult, result_fail_id, "Fail"); + (TError, error_failure_id, "Failure"); + (TError, 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"); + (TResult, result_return_id, "Return"); + (TResult, result_fail_id, "Fail_"); + (TError, error_failure_id, "Failure"); + (TError, error_out_of_fuel_id, "OutOfFuel"); + (TFuel, fuel_zero_id, "O"); + (TFuel, fuel_succ_id, "S"); ] | Lean -> [ - (Result, result_return_id, "ret"); - (Result, result_fail_id, "fail"); - (Error, error_failure_id, "panic"); + (TResult, result_return_id, "ret"); + (TResult, result_fail_id, "fail"); + (TError, 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"); + (TResult, result_return_id, "Return"); + (TResult, result_fail_id, "Fail"); + (TError, error_failure_id, "Failure"); (* No Fuel::Zero on purpose *) (* No Fuel::Succ on purpose *) ] @@ -801,18 +801,18 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) match ty with | TAdt (type_id, generics) -> ( match type_id with - | Tuple -> + | TTuple -> (* The "pair" case is frequent enough to have its special treatment *) if List.length generics.types = 2 then "p" else "t" - | TAssumed Result -> "r" - | TAssumed Error -> ConstStrings.error_basename - | TAssumed Fuel -> ConstStrings.fuel_basename - | TAssumed Array -> "a" - | TAssumed Slice -> "s" - | TAssumed Str -> "s" - | TAssumed State -> ConstStrings.state_basename - | TAssumed (RawPtr _) -> "p" - | AdtId adt_id -> + | TAssumed TResult -> "r" + | TAssumed TError -> ConstStrings.error_basename + | TAssumed TFuel -> ConstStrings.fuel_basename + | TAssumed TArray -> "a" + | TAssumed TSlice -> "s" + | TAssumed TStr -> "s" + | TAssumed TState -> ConstStrings.state_basename + | TAssumed (TRawPtr _) -> "p" + | TAdtId 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" @@ -821,15 +821,15 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) * be an ident *) let cl = List.nth def.name (List.length def.name - 1) in name_from_type_ident (Names.as_ident cl)) - | TypeVar _ -> ( + | TVar _ -> ( (* TODO: use "t" also for F* *) match !backend with | FStar -> "x" (* lacking inspiration here... *) | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) | TLiteral lty -> ( match lty with TBool -> "b" | TChar -> "c" | TInteger _ -> "i") - | Arrow _ -> "f" - | TraitType (_, _, name) -> name_from_type_ident name) + | TArrow _ -> "f" + | TTraitType (_, _, 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 *) @@ -1161,7 +1161,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) | TAdt (type_id, generics) -> ( let has_params = generics <> empty_generic_args in match type_id with - | Tuple -> + | TTuple -> (* 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 ()) @@ -1181,7 +1181,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_space fmt ()) (extract_rec true) generics.types; F.pp_print_string fmt ")") - | AdtId _ | TAssumed _ -> ( + | TAdtId _ | TAssumed _ -> ( (* HOL4 behaves differently. Where in Coq/FStar/Lean we would write: `tree a b` @@ -1200,7 +1200,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) argument for `Vec`). *) let generics = match type_id with - | AdtId id -> ( + | TAdtId id -> ( match TypeDeclId.Map.find_opt id ctx.types_filter_type_args_map with @@ -1223,7 +1223,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) assert (const_generics = []); let print_tys = match type_id with - | AdtId id -> not (TypeDeclId.Set.mem id no_params_tys) + | TAdtId id -> not (TypeDeclId.Set.mem id no_params_tys) | TAssumed _ -> true | _ -> raise (Failure "Unreachable") in @@ -1243,9 +1243,9 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter) 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) + | TVar vid -> F.pp_print_string fmt (ctx_get_type_var vid ctx) | TLiteral lty -> extract_literal_type ctx fmt lty - | Arrow (arg_ty, ret_ty) -> + | TArrow (arg_ty, ret_ty) -> if inside then F.pp_print_string fmt "("; extract_rec false arg_ty; F.pp_print_space fmt (); @@ -1253,7 +1253,7 @@ 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) -> ( + | TTraitType (trait_ref, generics, type_name) -> ( if !parameterize_trait_types then raise (Failure "Unimplemented") else let type_name = @@ -1445,7 +1445,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : | 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 + let ctx = ctx_add (TypeId (TAdtId 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 @@ -1487,11 +1487,11 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let ctx = List.fold_left (fun ctx (fid, name) -> - ctx_add (FieldId (AdtId def.def_id, fid)) name ctx) + ctx_add (FieldId (TAdtId def.def_id, fid)) name ctx) ctx field_names in (* Add the constructor name *) - ctx_add (StructId (AdtId def.def_id)) cons_name ctx + ctx_add (StructId (TAdtId def.def_id)) cons_name ctx | Enum variants -> let variant_names = match info with @@ -1527,7 +1527,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : in List.fold_left (fun ctx (vid, vname) -> - ctx_add (VariantId (AdtId def.def_id, vid)) vname ctx) + ctx_add (VariantId (TAdtId def.def_id, vid)) vname ctx) ctx variant_names | Opaque -> (* Nothing to do *) @@ -1730,7 +1730,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 ( - F.pp_print_string fmt (ctx_get_struct (AdtId def.def_id) ctx); + F.pp_print_string fmt (ctx_get_struct (TAdtId def.def_id) ctx); F.pp_print_string fmt " "); (match !backend with | Lean -> () @@ -1744,7 +1744,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) | Lean -> F.pp_open_vbox fmt 0); (* Print the fields *) let print_field (field_id : FieldId.id) (f : field) : unit = - let field_name = ctx_get_field (AdtId def.def_id) field_id ctx in + let field_name = ctx_get_field (TAdtId def.def_id) field_id ctx in (* Open a box for the field *) F.pp_open_box fmt ctx.indent_incr; F.pp_print_string fmt field_name; @@ -1779,7 +1779,7 @@ let extract_type_decl_struct_body (ctx : extraction_ctx) (fmt : F.formatter) 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 + if !backend = Lean then "mk" else ctx_get_struct (TAdtId 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 @@ -2223,7 +2223,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) match decl.kind with | Opaque -> () | Struct fields -> - let adt_id = AdtId decl.def_id in + let adt_id = TAdtId decl.def_id in (* Generate the instruction for the record constructor *) let cons_name = ctx_get_struct adt_id ctx in extract_coq_arguments_instruction ctx fmt cons_name num_params; @@ -2241,7 +2241,7 @@ let extract_type_decl_coq_arguments (ctx : extraction_ctx) (fmt : F.formatter) (* Generate the instructions *) VariantId.iteri (fun vid (_ : variant) -> - let cons_name = ctx_get_variant (AdtId decl.def_id) vid ctx in + let cons_name = ctx_get_variant (TAdtId decl.def_id) vid ctx in extract_coq_arguments_instruction ctx fmt cons_name num_params) variants; (* Add breaks to insert new lines between definitions *) @@ -2270,7 +2270,7 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) 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 cons_name = ctx_get_struct (TAdtId 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 *) @@ -2281,7 +2281,7 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) F.pp_open_hovbox fmt ctx.indent_incr; F.pp_print_string fmt "Definition"; F.pp_print_space fmt (); - let field_name = ctx_get_field (AdtId decl.def_id) field_id ctx in + let field_name = ctx_get_field (TAdtId decl.def_id) field_id ctx in F.pp_print_string fmt field_name; (* Print the generics *) let as_implicits = true in @@ -2364,7 +2364,7 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) 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 + let field_name = ctx_get_field (TAdtId decl.def_id) field_id ctx in F.pp_print_string fmt ("\"" ^ record_var ^ " .(" ^ field_name ^ ")\""); F.pp_print_space fmt (); F.pp_print_string fmt ":="; @@ -2421,7 +2421,7 @@ let extract_state_type (fmt : F.formatter) (ctx : extraction_ctx) * one line *) F.pp_open_hvbox fmt 0; (* Retrieve the name *) - let state_name = ctx_get_assumed_type State ctx in + let state_name = ctx_get_assumed_type TState ctx in (* The syntax for Lean and Coq is almost identical. *) let print_axiom () = let axiom = diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index b1178aa7..395c0c80 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -71,7 +71,7 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) let generics = let { T.regions; types; const_generics; trait_clauses } = sg.generics in let regions = List.map (fun _ -> T.RErased) regions in - let types = List.map (fun (v : T.type_var) -> T.TypeVar v.T.index) types in + let types = List.map (fun (v : T.type_var) -> T.TVar v.T.index) types in let const_generics = List.map (fun (v : T.const_generic_var) -> T.CGVar v.T.index) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index d4dbf80a..c54d55d4 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1889,7 +1889,7 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) match bc with | SharedBorrow bid -> assert (ty_no_regions ref_ty); - let ty = T.Ref (T.RVar r_id, ref_ty, kind) in + let ty = T.TRef (T.RVar r_id, ref_ty, kind) in let value = V.ABorrow (V.ASharedBorrow bid) in ([ { V.value; ty } ], v) | MutBorrow (bid, bv) -> @@ -1897,7 +1897,7 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx bv.V.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ty = T.Ref (T.RVar r_id, ref_ty, kind) in + let ty = T.TRef (T.RVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in let av = V.ABorrow (V.AMutBorrow (bid, ignored)) in let av = { V.value = av; ty } in diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index cf8e5994..8807f3ef 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -107,10 +107,10 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) assert (ty_is_rty ty1 && ty_is_rty ty2); (* Normalize the associated types *) match (ty1, ty2) with - | T.TLiteral lit1, T.TLiteral lit2 -> + | TLiteral lit1, TLiteral lit2 -> assert (lit1 = lit2); default - | T.TAdt (id1, generics1), T.TAdt (id2, generics2) -> + | TAdt (id1, generics1), TAdt (id2, generics2) -> assert (id1 = id2); (* There are no regions in the const generics, so we ignore them, but we still check they are the same, for sanity *) @@ -146,7 +146,7 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) in (* Combine *) combine params_b tys_b - | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> + | TRef (r1, ty1, kind1), TRef (r2, ty2, kind2) -> (* Sanity check *) assert (kind1 = kind2); (* Explanation for the case where we check if projections intersect: @@ -155,10 +155,10 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) let regions_b = compare_regions r1 r2 in let tys_b = compare ty1 ty2 in combine regions_b tys_b - | T.TypeVar id1, T.TypeVar id2 -> + | TVar id1, TVar id2 -> assert (id1 = id2); default - | T.TraitType _, T.TraitType _ -> + | TTraitType _, TTraitType _ -> (* The types should have been normalized. If after normalization we get trait types, we can consider them as variables *) assert (ty1 = ty2); diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 48688893..b07f2629 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -272,10 +272,10 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.generic_args) (ctx : C.eval_ctx) : V.symbolic_expansion list = match (adt_id, generics.regions, generics.types) with - | T.AdtId def_id, _, _ -> + | T.TAdtId def_id, _, _ -> compute_expanded_symbolic_non_assumed_adt_value expand_enumerations kind def_id generics ctx - | T.Tuple, [], _ -> + | T.TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind generics.types ] | T.TAssumed T.TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] @@ -306,7 +306,7 @@ let expand_symbolic_value_shared_borrow (config : C.config) V.abstract_shared_borrows option = if same_symbolic_id sv original_sv then match proj_ty with - | T.Ref (r, ref_ty, T.Shared) -> + | T.TRef (r, ref_ty, T.Shared) -> (* Projector over the shared value *) let shared_asb = V.AsbProjReborrows (sv, ref_ty) in (* Check if the region is in the set of projected regions *) @@ -548,7 +548,7 @@ let expand_symbolic_value_no_branching (config : C.config) S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see expr (* Borrows *) - | T.Ref (region, ref_ty, rkind) -> + | T.TRef (region, ref_ty, rkind) -> expand_symbolic_value_borrow config original_sv original_sv_place region ref_ty rkind cf ctx | _ -> @@ -665,7 +665,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ^ symbolic_value_to_string ctx sv)); let cc : cm_fun = match sv.V.sv_ty with - | T.TAdt (AdtId def_id, _) -> + | T.TAdt (TAdtId 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 *) @@ -690,7 +690,7 @@ 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.TAdt ((Tuple | TAssumed TBox), _) | T.Ref (_, _, _) -> + | T.TAdt ((TTuple | TAssumed TBox), _) | T.TRef (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None | T.TAdt (TAssumed (TArray | TSlice | TStr), _) -> @@ -698,8 +698,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.TLiteral _ | Never | T.TraitType _ | T.Arrow _ - | T.RawPtr _ -> + | T.TVar _ | T.TLiteral _ | TNever | T.TTraitType _ | T.TArrow _ + | T.TRawPtr _ -> raise (Failure "Unreachable") in (* Compose and continue *) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index c7fcc1af..7865d7be 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -144,9 +144,9 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) (match v.V.ty with | T.TAdt (T.TAssumed T.TBox, _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.TAdt (T.AdtId _, _) as ty -> + | T.TAdt (T.TAdtId _, _) as ty -> assert (allow_adt_copy || ty_is_primitively_copyable ty) - | T.TAdt (T.Tuple, _) -> () (* Ok *) + | T.TAdt (T.TTuple, _) -> () (* Ok *) | T.TAdt ( T.TAssumed (TSlice | T.TArray), { @@ -670,7 +670,7 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) | E.TwoPhaseMut -> T.Mut | _ -> raise (Failure "Unreachable") in - let rv_ty = T.Ref (T.RErased, v.ty, ref_kind) in + let rv_ty = T.TRef (T.RErased, v.ty, ref_kind) in let bc = match bkind with | E.Shared | E.Shallow -> @@ -698,7 +698,7 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) fun ctx -> (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) let bid = C.fresh_borrow_id () in - let rv_ty = T.Ref (T.RErased, v.ty, Mut) in + let rv_ty = T.TRef (T.RErased, v.ty, Mut) in let rv : V.typed_value = { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } in @@ -725,15 +725,15 @@ let eval_rvalue_aggregate (config : C.config) match aggregate_kind with | E.AggregatedAdt (type_id, opt_variant_id, generics) -> ( match type_id with - | Tuple -> + | TTuple -> let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in let v = V.VAdt { variant_id = None; field_values = values } in let generics = TypesUtils.mk_generic_args [] tys [] [] in - let ty = T.TAdt (T.Tuple, generics) in + let ty = T.TAdt (T.TTuple, generics) in let aggregated : V.typed_value = { V.value = v; ty } in (* Call the continuation *) cf aggregated ctx - | AdtId def_id -> + | TAdtId def_id -> (* Sanity checks *) let type_decl = C.ctx_lookup_type_decl ctx def_id in assert ( @@ -750,7 +750,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.TAdt (T.AdtId def_id, generics) in + let aty = T.TAdt (T.TAdtId def_id, generics) in let aggregated : V.typed_value = { V.value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 3447131c..2f7e8f3d 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -170,7 +170,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = let child_av = mk_aignored child_rty in (* Create the shared loan *) - let loan_rty = T.Ref (T.RVar nrid, rty, T.Shared) in + let loan_rty = T.TRef (T.RVar nrid, rty, T.Shared) in let loan_value = V.ALoan (V.ASharedLoan (V.BorrowId.Set.singleton nlid, nsv, child_av)) in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 9bc25626..27020efb 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -172,20 +172,20 @@ let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) in let generics = { T.regions; types; const_generics; trait_refs } in TAdt (id, generics) - | TypeVar vid0, TypeVar vid1 -> + | TVar vid0, TVar vid1 -> assert (vid0 = vid1); let vid = vid0 in - TypeVar vid + TVar vid | TLiteral lty0, TLiteral lty1 -> assert (lty0 = lty1); ty0 - | Never, Never -> ty0 - | Ref (r0, ty0, k0), Ref (r1, ty1, k1) -> + | TNever, TNever -> ty0 + | TRef (r0, ty0, k0), TRef (r1, ty1, k1) -> let r = match_regions r0 r1 in let ty = match_rec ty0 ty1 in assert (k0 = k1); let k = k0 in - Ref (r, ty, k) + TRef (r, ty, k) | _ -> match_distinct_types ty0 ty1 module MakeMatcher (M : PrimMatcher) : Matcher = struct diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 728e5226..36af1db4 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -101,7 +101,7 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) T.TAdt (type_id, _) ) -> ( (* Check consistency *) (match (proj_kind, type_id) with - | ProjAdt (def_id, opt_variant_id), T.AdtId def_id' -> + | ProjAdt (def_id, opt_variant_id), T.TAdtId def_id' -> assert (def_id = def_id'); assert (opt_variant_id = adt.variant_id) | _ -> raise (Failure "Unreachable")); @@ -118,7 +118,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.VAdt adt, T.TAdt (T.Tuple, _) -> ( + | Field (ProjTuple arity, field_id), V.VAdt adt, T.TAdt (T.TTuple, _) -> ( assert (arity = List.length adt.field_values); let fv = T.FieldId.nth adt.field_values field_id in (* Project *) @@ -372,7 +372,7 @@ let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in let av = V.VAdt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.TAdt (T.AdtId def_id, generics) in + let ty = T.TAdt (TAdtId def_id, generics) in { V.value = av; V.ty } let compute_expanded_bottom_tuple_value (field_types : T.ety list) : @@ -381,7 +381,7 @@ let compute_expanded_bottom_tuple_value (field_types : T.ety list) : let fields = List.map mk_bottom field_types in let v = V.VAdt { variant_id = None; field_values = fields } in let generics = TypesUtils.mk_generic_args [] field_types [] [] in - let ty = T.TAdt (T.Tuple, generics) in + let ty = T.TAdt (TTuple, generics) in { V.value = v; V.ty } (** Auxiliary helper to expand {!V.Bottom} values. @@ -433,13 +433,13 @@ 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.TAdt (T.AdtId def_id', generics) ) -> + T.TAdt (TAdtId def_id', generics) ) -> assert (def_id = def_id'); compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics (* Tuples *) | ( Field (ProjTuple arity, _), T.TAdt - ( T.Tuple, + ( TTuple, { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) -> assert (arity = List.length types); diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 70a77be5..e47886ec 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -43,7 +43,7 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) in List.concat proj_fields | V.Bottom, _ -> raise (Failure "Unreachable") - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + | V.Borrow bc, TRef (r, ref_ty, kind) -> (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) let bid, asb = (* Not in the set: dive *) @@ -121,7 +121,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) in V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } | V.Bottom, _ -> raise (Failure "Unreachable") - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + | V.Borrow bc, TRef (r, ref_ty, kind) -> if (* Check if the region is in the set of projected regions (note that * we never project over static regions) *) @@ -277,7 +277,7 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) field_values in (V.AAdt { V.variant_id; field_values }, original_sv_ty) - | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> + | SeMutRef (bid, spc), TRef (r, ref_ty, T.Mut) -> (* Sanity check *) assert (spc.V.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) @@ -295,7 +295,7 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) if region_in_set r ancestors_regions then Some bid else None in (V.ALoan (V.AIgnoredMutLoan (opt_bid, child_av)), ref_ty) - | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> + | SeSharedRef (bids, spc), TRef (r, ref_ty, T.Shared) -> (* Sanity check *) assert (spc.V.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index cdcea2cc..cf9b840b 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -232,7 +232,7 @@ let set_discriminant (config : C.config) (p : E.place) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> match (v.V.ty, v.V.value) with - | T.TAdt ((T.AdtId _ as type_id), generics), V.VAdt av -> ( + | T.TAdt ((T.TAdtId _ as type_id), generics), V.VAdt av -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -248,16 +248,16 @@ let set_discriminant (config : C.config) (p : E.place) (* Replace the value *) let bottom_v = match type_id with - | T.AdtId def_id -> + | T.TAdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | T.TAdt ((T.AdtId _ as type_id), generics), V.Bottom -> + | T.TAdt ((T.TAdtId _ as type_id), generics), V.Bottom -> let bottom_v = match type_id with - | T.AdtId def_id -> + | T.TAdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics | _ -> raise (Failure "Unreachable") diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 01de6fd0..8895bd8e 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -419,7 +419,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (match (tv.V.value, tv.V.ty) with | V.VLiteral cv, T.TLiteral ty -> check_literal_type cv ty (* ADT case *) - | V.VAdt av, T.TAdt (T.AdtId def_id, generics) -> + | V.VAdt av, T.TAdt (T.TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in @@ -445,7 +445,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.VAdt av, T.TAdt (T.Tuple, generics) -> + | V.VAdt av, T.TAdt (T.TTuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); assert (av.V.variant_id = None); @@ -486,7 +486,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | (T.TSlice | T.TStr), _, _, _, _ -> raise (Failure "Unexpected") | _ -> raise (Failure "Erroneous type")) | V.Bottom, _ -> (* Nothing to check *) () - | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( + | V.Borrow bc, T.TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | V.SharedBorrow bid, T.Shared | V.ReservedMutBorrow bid, T.Mut -> ( (* Lookup the borrowed value to check it has the proper type *) @@ -533,7 +533,7 @@ 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.TAdt (T.AdtId def_id, generics) -> + | V.AAdt av, T.TAdt (T.TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in @@ -562,7 +562,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) fields_with_types (* Tuple case *) - | V.AAdt av, T.TAdt (T.Tuple, generics) -> + | V.AAdt av, T.TAdt (T.TTuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); assert (av.V.variant_id = None); @@ -589,7 +589,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = assert (boxed_value.V.ty = boxed_ty) | _ -> raise (Failure "Erroneous type")) | V.ABottom, _ -> (* Nothing to check *) () - | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( + | V.ABorrow bc, T.TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | V.AMutBorrow (_, av), T.Mut -> (* Check that the child value has the proper type *) diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index ee06fa07..67063af9 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 (AggregatedAdt (Tuple, _, _), []) -> not must_end_with_exit + | Aggregate (AggregatedAdt (TTuple, _, _), []) -> 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 dd24767e..7494dc2a 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -73,10 +73,10 @@ module Values = struct List.map (typed_value_to_string fmt) av.field_values in match v.ty with - | T.TAdt (T.Tuple, _) -> + | T.TAdt (T.TTuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.TAdt (T.AdtId def_id, _) -> + | T.TAdt (T.TAdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -177,10 +177,10 @@ module Values = struct List.map (typed_avalue_to_string fmt) av.field_values in match v.ty with - | T.TAdt (T.Tuple, _) -> + | T.TAdt (T.TTuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.TAdt (T.AdtId def_id, _) -> + | T.TAdt (T.TAdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 7c52c423..8b737cb5 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -191,20 +191,20 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let assumed_ty_to_string (aty : assumed_ty) : string = match aty with - | State -> "State" - | Result -> "Result" - | Error -> "Error" - | Fuel -> "Fuel" - | Array -> "Array" - | Slice -> "Slice" - | Str -> "Str" - | RawPtr Mut -> "MutRawPtr" - | RawPtr Const -> "ConstRawPtr" + | TState -> "State" + | TResult -> "Result" + | TError -> "Error" + | TFuel -> "Fuel" + | TArray -> "Array" + | TSlice -> "Slice" + | TStr -> "Str" + | TRawPtr Mut -> "MutRawPtr" + | TRawPtr Const -> "ConstRawPtr" let type_id_to_string (fmt : type_formatter) (id : type_id) : string = match id with - | AdtId id -> fmt.type_decl_id_to_string id - | Tuple -> "" + | TAdtId id -> fmt.type_decl_id_to_string id + | TTuple -> "" | TAssumed aty -> assumed_ty_to_string aty (* TODO: duplicates Charon.PrintTypes.const_generic_to_string *) @@ -219,24 +219,24 @@ let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = match ty with | TAdt (id, generics) -> ( match id with - | Tuple -> + | TTuple -> let generics = generic_args_to_strings fmt false generics in "(" ^ String.concat " * " generics ^ ")" - | AdtId _ | TAssumed _ -> + | TAdtId _ | TAssumed _ -> 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 ^ generics_s in if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) - | TypeVar tv -> fmt.type_var_id_to_string tv + | TVar tv -> fmt.type_var_id_to_string tv | TLiteral lty -> literal_type_to_string lty - | Arrow (arg_ty, ret_ty) -> + | TArrow (arg_ty, ret_ty) -> let ty = 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) -> + | TTraitType (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 @@ -378,8 +378,8 @@ let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) (variant_id : VariantId.id option) : string = match adt_id with - | Tuple -> "Tuple" - | AdtId def_id -> ( + | TTuple -> "Tuple" + | TAdtId def_id -> ( (* "Regular" ADT *) match variant_id with | Some vid -> fmt.adt_variant_to_string def_id vid @@ -387,21 +387,21 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) | TAssumed aty -> ( (* Assumed type *) match aty with - | State | Array | Slice | Str | RawPtr _ -> + | TState | TArray | TSlice | TStr | TRawPtr _ -> (* Those types are opaque: we can't get there *) raise (Failure "Unreachable") - | Result -> + | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then "@Result::Return" else if variant_id = result_fail_id then "@Result::Fail" else raise (Failure "Unreachable: improper variant id for result type") - | Error -> + | TError -> let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" else raise (Failure "Unreachable: improper variant id for error type") - | Fuel -> + | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then "@Fuel::Zero" else if variant_id = fuel_succ_id then "@Fuel::Succ" @@ -410,10 +410,10 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (field_id : FieldId.id) : string = match adt_id with - | Tuple -> + | TTuple -> raise (Failure "Unreachable") (* Tuples don't use the opaque field id for the field indices, but [int] *) - | AdtId def_id -> ( + | TAdtId def_id -> ( (* "Regular" ADT *) let fields = fmt.adt_field_names def_id None in match fields with @@ -422,10 +422,10 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) | TAssumed aty -> ( (* Assumed type *) match aty with - | State | Fuel | Array | Slice | Str -> + | TState | TFuel | TArray | TSlice | TStr -> (* Opaque types: we can't get there *) raise (Failure "Unreachable") - | Result | Error | RawPtr _ -> + | TResult | TError | TRawPtr _ -> (* Enumerations: we can't get there *) raise (Failure "Unreachable")) @@ -437,10 +437,10 @@ let adt_g_value_to_string (fmt : value_formatter) (field_values : 'v list) (ty : ty) : string = let field_values = List.map value_to_string field_values in match ty with - | TAdt (Tuple, _) -> + | TAdt (TTuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | TAdt (AdtId def_id, _) -> + | TAdt (TAdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match variant_id with @@ -465,10 +465,10 @@ let adt_g_value_to_string (fmt : value_formatter) | TAdt (TAssumed aty, _) -> ( (* Assumed type *) match aty with - | State | RawPtr _ -> + | TState | TRawPtr _ -> (* This type is opaque: we can't get there *) raise (Failure "Unreachable") - | Result -> + | TResult -> let variant_id = Option.get variant_id in if variant_id = result_return_id then match field_values with @@ -480,13 +480,13 @@ let adt_g_value_to_string (fmt : value_formatter) | _ -> raise (Failure "Result::Fail takes exactly one value") else raise (Failure "Unreachable: improper variant id for result type") - | Error -> + | TError -> assert (field_values = []); let variant_id = Option.get variant_id in if variant_id = error_failure_id then "@Error::Failure" else if variant_id = error_out_of_fuel_id then "@Error::OutOfFuel" else raise (Failure "Unreachable: improper variant id for error type") - | Fuel -> + | TFuel -> let variant_id = Option.get variant_id in if variant_id = fuel_zero_id then ( assert (field_values = []); @@ -496,7 +496,7 @@ 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") - | Array | Slice | Str -> + | TArray | TSlice | TStr -> assert (variant_id = None); let field_values = List.mapi (fun i v -> string_of_int i ^ " -> " ^ v) field_values @@ -650,7 +650,7 @@ let rec texpression_to_string (fmt : ast_formatter) (inside : bool) let indent2 = indent1 ^ indent_incr in (* The id should be a custom type decl id or an array *) match supd.struct_id with - | AdtId aid -> + | TAdtId aid -> let field_names = Option.get (fmt.adt_field_names aid None) in let fields = List.map @@ -664,7 +664,7 @@ let rec texpression_to_string (fmt : ast_formatter) (inside : bool) in let bl = if fields = [] then "" else "\n" ^ indent in "{" ^ s ^ String.concat "" fields ^ bl ^ "}" - | TAssumed Array -> + | TAssumed TArray -> let fields = List.map (fun (_, fe) -> diff --git a/compiler/Pure.ml b/compiler/Pure.ml index ffbd1f09..72a6400e 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -68,14 +68,14 @@ type mutability = Mut | Const [@@deriving show, ord] TODO: add a prefix "T" *) type assumed_ty = - | State - | Result - | Error - | Fuel - | Array - | Slice - | Str - | RawPtr of mutability + | TState + | TResult + | TError + | TFuel + | TArray + | TSlice + | TStr + | TRawPtr 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 @@ -146,7 +146,7 @@ class virtual ['self] mapreduce_type_id_base = fun _ x -> (x, self#zero) end -type type_id = AdtId of type_decl_id | Tuple | TAssumed of assumed_ty +type type_id = TAdtId of type_decl_id | TTuple | TAssumed of assumed_ty [@@deriving show, ord, @@ -276,10 +276,10 @@ type ty = be able to only give back part of the ADT. We need a way to encode such "partial" ADTs. *) - | TypeVar of type_var_id + | TVar of type_var_id | TLiteral of literal_type - | Arrow of ty * ty - | TraitType of trait_ref * generic_args * string + | TArrow of ty * ty + | TTraitType of trait_ref * generic_args * string (** The string is for the name of the associated type *) and trait_ref = { diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index d62a028e..8872571f 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -582,7 +582,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = match app.e with | Qualif { - id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; + id = AdtCons { adt_id = TAdtId adt_id; variant_id = None }; generics = _; } -> (* Lookup the def *) @@ -606,7 +606,7 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = (!Config.backend <> Lean && !Config.backend <> Coq) || not is_rec then - let struct_id = AdtId adt_id in + let struct_id = TAdtId adt_id in let init = None in let updates = FieldId.mapi @@ -1085,7 +1085,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = match app.e with | Qualif { - id = AdtCons { adt_id = AdtId adt_id; variant_id = None }; + id = AdtCons { adt_id = TAdtId adt_id; variant_id = None }; generics; } -> (* This is a struct *) @@ -1114,7 +1114,7 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ( Qualif { id = - Proj { adt_id = AdtId proj_adt_id; field_id }; + Proj { adt_id = TAdtId proj_adt_id; field_id }; generics = proj_generics; }, Var v ) -> @@ -1157,13 +1157,13 @@ let simplify_aggregates (ctx : trans_ctx) (def : fun_decl) : fun_decl = match (proj.e, x.e) with | ( Qualif { - id = Proj { adt_id = AdtId proj_adt_id; field_id }; + id = Proj { adt_id = TAdtId proj_adt_id; field_id }; generics = _; }, Var v ) -> (* We check that this is the proper ADT, and the proper field *) if - AdtId proj_adt_id = struct_id + TAdtId proj_adt_id = struct_id && field_id = fid && x.ty = adt_ty then Some v else None diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index f8b5de6a..ea1851f0 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -12,41 +12,41 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) (type_id : type_id) (variant_id : VariantId.id option) (generics : generic_args) : ty list = match type_id with - | Tuple -> + | TTuple -> (* Tuple *) assert (generics.const_generics = []); assert (generics.trait_refs = []); assert (variant_id = None); generics.types - | AdtId def_id -> + | TAdtId def_id -> (* "Regular" ADT *) let def = TypeDeclId.Map.find def_id type_decls in type_decl_get_instantiated_fields_types def variant_id generics | TAssumed aty -> ( (* Assumed type *) match aty with - | State -> + | TState -> (* This type is opaque *) raise (Failure "Unreachable: opaque type") - | Result -> + | TResult -> 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 -> + | TError -> 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); [] - | Fuel -> + | TFuel -> let variant_id = Option.get variant_id in 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 | RawPtr _ -> + | TArray | TSlice | TStr | TRawPtr _ -> (* 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")) @@ -208,7 +208,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = assert (adt_id = supd.struct_id); (* The id can only be: a custom type decl or an array *) match adt_id with - | AdtId _ -> + | TAdtId _ -> let variant_id = None in let expected_field_tys = get_adt_field_types ctx.type_decls adt_id variant_id adt_generics @@ -219,7 +219,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = assert (expected_field_ty = fe.ty); check_texpression ctx fe) supd.updates - | TAssumed Array -> + | TAssumed TArray -> let expected_field_ty = Collections.List.to_cons_nil adt_generics.types in diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 49c8dd70..4cc7ef91 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -59,7 +59,7 @@ module FunLoopIdSet = Collections.MakeSet (FunLoopIdOrderedType) let dest_arrow_ty (ty : ty) : ty * ty = match ty with - | Arrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) + | TArrow (arg_ty, ret_ty) -> (arg_ty, ret_ty) | _ -> raise (Failure "Unreachable") let compute_literal_type (cv : literal) : literal_type = @@ -110,7 +110,7 @@ let ty_substitute (subst : subst) (ty : ty) : ty = let obj = object inherit [_] map_ty - method! visit_TypeVar _ var_id = subst.ty_subst var_id + method! visit_TVar _ var_id = subst.ty_subst var_id method! visit_CGVar _ var_id = subst.cg_subst var_id method! visit_Clause _ id = subst.tr_subst id method! visit_Self _ = subst.tr_self @@ -249,12 +249,12 @@ let remove_meta (e : texpression) : texpression = in obj#visit_texpression () e -let mk_arrow (ty0 : ty) (ty1 : ty) : ty = Arrow (ty0, ty1) +let mk_arrow (ty0 : ty) (ty1 : ty) : ty = TArrow (ty0, ty1) (** Construct a type as a list of arrows: ty1 -> ... tyn *) let mk_arrows (inputs : ty list) (output : ty) = let rec aux (tys : ty list) : ty = - match tys with [] -> output | ty :: tys' -> Arrow (ty, aux tys') + match tys with [] -> output | ty :: tys' -> TArrow (ty, aux tys') in aux inputs @@ -305,7 +305,7 @@ let destruct_apps (e : texpression) : texpression * texpression list = (** Make an [App (app, arg)] expression *) let mk_app (app : texpression) (arg : texpression) : texpression = match app.ty with - | Arrow (ty0, ty1) -> + | TArrow (ty0, ty1) -> (* Sanity check *) assert (ty0 = arg.ty); let e = App (app, arg) in @@ -340,7 +340,7 @@ let opt_destruct_function_call (e : texpression) : let opt_destruct_result (ty : ty) : ty option = match ty with - | TAdt (TAssumed Result, generics) -> + | TAdt (TAssumed TResult, generics) -> assert (generics.const_generics = []); assert (generics.trait_refs = []); Some (Collections.List.to_cons_nil generics.types) @@ -350,14 +350,14 @@ let destruct_result (ty : ty) : ty = Option.get (opt_destruct_result ty) let opt_destruct_tuple (ty : ty) : ty list option = match ty with - | TAdt (Tuple, generics) -> + | TAdt (TTuple, generics) -> assert (generics.const_generics = []); assert (generics.trait_refs = []); Some generics.types | _ -> None let mk_abs (x : typed_pattern) (e : texpression) : texpression = - let ty = Arrow (x.ty, e.ty) in + let ty = TArrow (x.ty, e.ty) in let e = Abs (x, e) in { e; ty } @@ -370,12 +370,12 @@ let rec destruct_abs_list (e : texpression) : typed_pattern list * texpression = let destruct_arrow (ty : ty) : ty * ty = match ty with - | Arrow (ty0, ty1) -> (ty0, ty1) + | TArrow (ty0, ty1) -> (ty0, ty1) | _ -> raise (Failure "Not an arrow type") let rec destruct_arrows (ty : ty) : ty list * ty = match ty with - | Arrow (ty0, ty1) -> + | TArrow (ty0, ty1) -> let tys, out_ty = destruct_arrows ty1 in (ty0 :: tys, out_ty) | _ -> ([], ty) @@ -427,13 +427,13 @@ let mk_switch (scrut : texpression) (sb : switch_body) : texpression = let mk_simpl_tuple_ty (tys : ty list) : ty = match tys with | [ ty ] -> ty - | _ -> TAdt (Tuple, mk_generic_args_from_types tys) + | _ -> TAdt (TTuple, mk_generic_args_from_types tys) let mk_bool_ty : ty = TLiteral TBool -let mk_unit_ty : ty = TAdt (Tuple, empty_generic_args) +let mk_unit_ty : ty = TAdt (TTuple, empty_generic_args) let mk_unit_rvalue : texpression = - let id = AdtCons { adt_id = Tuple; variant_id = None } in + let id = AdtCons { adt_id = TTuple; variant_id = None } in let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in let ty = mk_unit_ty in @@ -474,7 +474,7 @@ let mk_simpl_tuple_pattern (vl : typed_pattern list) : typed_pattern = | [ v ] -> v | _ -> let tys = List.map (fun (v : typed_pattern) -> v.ty) vl in - let ty = TAdt (Tuple, mk_generic_args_from_types tys) in + let ty = TAdt (TTuple, mk_generic_args_from_types tys) in let value = PatAdt { variant_id = None; field_values = vl } in { value; ty } @@ -485,10 +485,10 @@ 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 = TAdt (Tuple, mk_generic_args_from_types tys) in + let ty = TAdt (TTuple, 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 id = AdtCons { adt_id = TTuple; variant_id = None } in let qualif = { id; generics = mk_generic_args_from_types tys } in (* Put everything together *) let cons = { e = Qualif qualif; ty } in @@ -507,17 +507,17 @@ let ty_as_integer (t : ty) : T.integer_type = let ty_as_literal (t : ty) : T.literal_type = match t with TLiteral ty -> ty | _ -> raise (Failure "Unreachable") -let mk_state_ty : ty = TAdt (TAssumed State, empty_generic_args) +let mk_state_ty : ty = TAdt (TAssumed TState, empty_generic_args) let mk_result_ty (ty : ty) : ty = - TAdt (TAssumed Result, mk_generic_args_from_types [ ty ]) + TAdt (TAssumed TResult, mk_generic_args_from_types [ ty ]) -let mk_error_ty : ty = TAdt (TAssumed Error, empty_generic_args) -let mk_fuel_ty : ty = TAdt (TAssumed Fuel, empty_generic_args) +let mk_error_ty : ty = TAdt (TAssumed TError, empty_generic_args) +let mk_fuel_ty : ty = TAdt (TAssumed TFuel, empty_generic_args) let mk_error (error : VariantId.id) : texpression = let ty = mk_error_ty in - let id = AdtCons { adt_id = TAssumed Error; variant_id = Some error } in + let id = AdtCons { adt_id = TAssumed TError; variant_id = Some error } in let qualif = { id; generics = empty_generic_args } in let e = Qualif qualif in { e; ty } @@ -525,16 +525,16 @@ let mk_error (error : VariantId.id) : texpression = let unwrap_result_ty (ty : ty) : ty = match ty with | TAdt - (TAssumed Result, { types = [ ty ]; const_generics = []; trait_refs = [] }) - -> + ( TAssumed TResult, + { 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 = TAdt (TAssumed Result, mk_generic_args_from_types type_args) in + let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = - AdtCons { adt_id = TAssumed Result; variant_id = Some result_fail_id } + AdtCons { adt_id = TAssumed TResult; variant_id = Some result_fail_id } in let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in @@ -549,9 +549,9 @@ let mk_result_fail_texpression_with_error_id (error : VariantId.id) (ty : ty) : let mk_result_return_texpression (v : texpression) : texpression = let type_args = [ v.ty ] in - let ty = TAdt (TAssumed Result, mk_generic_args_from_types type_args) in + let ty = TAdt (TAssumed TResult, mk_generic_args_from_types type_args) in let id = - AdtCons { adt_id = TAssumed Result; variant_id = Some result_return_id } + AdtCons { adt_id = TAssumed TResult; variant_id = Some result_return_id } in let qualif = { id; generics = mk_generic_args_from_types type_args } in let cons_e = Qualif qualif in @@ -562,7 +562,7 @@ let mk_result_return_texpression (v : texpression) : texpression = (** Create a [Fail err] pattern which captures the error *) let mk_result_fail_pattern (error_pat : pattern) (ty : ty) : typed_pattern = let error_pat : typed_pattern = { value = error_pat; ty = mk_error_ty } in - let ty = TAdt (TAssumed Result, mk_generic_args_from_types [ ty ]) in + let ty = TAdt (TAssumed TResult, mk_generic_args_from_types [ ty ]) in let value = PatAdt { variant_id = Some result_fail_id; field_values = [ error_pat ] } in @@ -574,7 +574,7 @@ let mk_result_fail_pattern_ignore_error (ty : ty) : typed_pattern = mk_result_fail_pattern error_pat ty let mk_result_return_pattern (v : typed_pattern) : typed_pattern = - let ty = TAdt (TAssumed Result, mk_generic_args_from_types [ v.ty ]) in + let ty = TAdt (TAssumed TResult, mk_generic_args_from_types [ v.ty ]) in let value = PatAdt { variant_id = Some result_return_id; field_values = [ v ] } in diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 490574a2..166c237a 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -23,7 +23,7 @@ let st_substitute_visitor (subst : subst) = object inherit [_] A.map_statement method! visit_region _ r = subst.r_subst r - method! visit_TypeVar _ id = subst.ty_subst id + method! visit_TVar _ id = subst.ty_subst id method! visit_type_var_id _ _ = (* We should never get here because we reimplemented [visit_TypeVar] *) @@ -67,7 +67,7 @@ let generic_args_substitute (subst : subst) (g : T.generic_args) : let erase_regions_subst : subst = { r_subst = (fun _ -> T.RErased); - ty_subst = (fun vid -> T.TypeVar vid); + ty_subst = (fun vid -> T.TVar vid); cg_subst = (fun id -> T.CGVar id); tr_subst = (fun id -> T.Clause id); tr_self = T.Self; @@ -288,10 +288,10 @@ let ctx_adt_value_get_instantiated_field_types (ctx : C.eval_ctx) (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list = match id with - | T.AdtId id -> + | T.TAdtId id -> (* Retrieve the types of the fields *) ctx_adt_get_instantiated_field_types ctx id adt.V.variant_id generics - | T.Tuple -> + | T.TTuple -> assert (generics.regions = []); generics.types | T.TAssumed aty -> ( diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 91edbf04..60020d9a 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -397,8 +397,8 @@ let rec translate_sty (ty : T.ty) : ty = | T.TAdt (type_id, generics) -> ( let generics = translate_sgeneric_args generics in match type_id with - | T.AdtId adt_id -> TAdt (AdtId adt_id, generics) - | T.Tuple -> + | T.TAdtId adt_id -> TAdt (TAdtId adt_id, generics) + | T.TTuple -> assert (generics.const_generics = []); mk_simpl_tuple_ty generics.types | T.TAssumed aty -> ( @@ -412,23 +412,23 @@ let rec translate_sty (ty : T.ty) : ty = (Failure "Box/vec/option type with incorrect number of arguments") ) - | T.TArray -> TAdt (TAssumed Array, generics) - | T.TSlice -> TAdt (TAssumed Slice, generics) - | T.TStr -> TAdt (TAssumed Str, generics))) - | TypeVar vid -> TypeVar vid + | T.TArray -> TAdt (TAssumed TArray, generics) + | T.TSlice -> TAdt (TAssumed TSlice, generics) + | T.TStr -> TAdt (TAssumed TStr, generics))) + | TVar vid -> TVar vid | TLiteral ty -> TLiteral ty - | Never -> raise (Failure "Unreachable") - | Ref (_, rty, _) -> translate rty - | RawPtr (ty, rkind) -> + | TNever -> raise (Failure "Unreachable") + | TRef (_, rty, _) -> translate rty + | TRawPtr (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 - TAdt (TAssumed (RawPtr mut), generics) - | TraitType (trait_ref, generics, type_name) -> + TAdt (TAssumed (TRawPtr mut), generics) + | TTraitType (trait_ref, generics, type_name) -> let trait_ref = translate_strait_ref trait_ref in let generics = translate_sgeneric_args generics in - TraitType (trait_ref, generics, type_name) - | Arrow _ -> raise (Failure "TODO") + TTraitType (trait_ref, generics, type_name) + | TArrow _ -> raise (Failure "TODO") and translate_sgeneric_args (generics : T.generic_args) : generic_args = translate_generic_args translate_sty generics @@ -506,20 +506,20 @@ let translate_type_decl (def : T.type_decl) : type_decl = let translate_type_id (id : T.type_id) : type_id = match id with - | AdtId adt_id -> AdtId adt_id - | T.TAssumed aty -> + | TAdtId adt_id -> TAdtId adt_id + | TAssumed aty -> let aty = match aty with - | T.TArray -> Array - | T.TSlice -> Slice - | T.TStr -> Str + | T.TArray -> TArray + | T.TSlice -> TSlice + | T.TStr -> TStr | T.TBox -> (* Boxes have to be eliminated: this type id shouldn't be translated *) raise (Failure "Unreachable") in TAssumed aty - | T.Tuple -> Tuple + | TTuple -> TTuple (** Translate a type, seen as an input/output of a forward function (preserve all borrows, etc.). @@ -536,14 +536,14 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : 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.TAssumed (T.TArray | T.TSlice | T.TStr) -> + | TAdtId _ | TAssumed (TArray | TSlice | TStr) -> let type_id = translate_type_id type_id in TAdt (type_id, t_generics) - | Tuple -> + | TTuple -> (* Note that if there is exactly one type, [mk_simpl_tuple_ty] is the identity *) mk_simpl_tuple_ty t_generics.types - | T.TAssumed T.TBox -> ( + | TAssumed TBox -> ( (* We eliminate boxes *) (* No general parametricity for now *) assert ( @@ -558,20 +558,20 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = (Failure "Unreachable: box/vec/option receives exactly one type \ parameter"))) - | TypeVar vid -> TypeVar vid - | Never -> raise (Failure "Unreachable") + | TVar vid -> TVar vid + | TNever -> raise (Failure "Unreachable") | TLiteral lty -> TLiteral lty - | Ref (_, rty, _) -> translate rty - | RawPtr (ty, rkind) -> + | TRef (_, rty, _) -> translate rty + | TRawPtr (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 - TAdt (TAssumed (RawPtr mut), generics) - | TraitType (trait_ref, generics, type_name) -> + TAdt (TAssumed (TRawPtr mut), generics) + | TTraitType (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) - | Arrow _ -> raise (Failure "TODO") + TTraitType (trait_ref, generics, type_name) + | TArrow _ -> raise (Failure "TODO") and translate_fwd_generic_args (type_infos : TA.type_infos) (generics : T.generic_args) : generic_args = @@ -611,7 +611,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) match ty with | T.TAdt (type_id, generics) -> ( match type_id with - | T.AdtId _ | TAssumed (T.TArray | T.TSlice | T.TStr) -> + | TAdtId _ | TAssumed (TArray | TSlice | TStr) -> let type_id = translate_type_id type_id in if inside_mut then (* We do not want to filter anything, so we translate the generics @@ -630,7 +630,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) let generics = translate_fwd_generic_args type_infos generics in Some (TAdt (type_id, generics)) else None - | TAssumed T.TBox -> ( + | TAssumed TBox -> ( (* Don't accept ADTs (which are not tuples) with borrows for now *) assert (not (TypesUtils.ty_has_borrows type_infos ty)); (* Eliminate the box *) @@ -640,7 +640,7 @@ let rec translate_back_ty (type_infos : TA.type_infos) raise (Failure "Unreachable: boxes receive exactly one type parameter") ) - | T.Tuple -> ( + | TTuple -> ( (* Tuples can contain borrows (which we eliminate) *) let tys_t = List.filter_map translate generics.types in match tys_t with @@ -649,10 +649,10 @@ let rec translate_back_ty (type_infos : TA.type_infos) (* Note that if there is exactly one type, [mk_simpl_tuple_ty] * is the identity *) Some (mk_simpl_tuple_ty tys_t))) - | TypeVar vid -> wrap (TypeVar vid) - | Never -> raise (Failure "Unreachable") + | TVar vid -> wrap (TVar vid) + | TNever -> raise (Failure "Unreachable") | TLiteral lty -> wrap (TLiteral lty) - | Ref (r, rty, rkind) -> ( + | TRef (r, rty, rkind) -> ( match rkind with | T.Shared -> (* Ignore shared references, unless we are below a mutable borrow *) @@ -663,17 +663,17 @@ 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 _ -> + | TRawPtr _ -> (* TODO: not sure what to do here *) None - | TraitType (trait_ref, generics, type_name) -> + | TTraitType (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)) - | Arrow _ -> raise (Failure "TODO") + Some (TTraitType (trait_ref, generics, type_name)) + | TArrow _ -> raise (Failure "TODO") (** Simply calls [translate_back_ty] *) let ctx_translate_back_ty (ctx : bs_ctx) (keep_region : 'r -> bool) @@ -1155,7 +1155,7 @@ 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.TAdt (T.Tuple, _) -> + | TAdt (TTuple, _) -> assert (variant_id = None); mk_simpl_tuple_texpression field_values | _ -> @@ -1233,10 +1233,10 @@ 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.TAssumed (T.TBox | T.TArray | T.TSlice | T.TStr) -> + | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> assert (field_values = []); None - | T.Tuple -> + | TTuple -> (* Return *) if field_values = [] then None else @@ -1378,10 +1378,10 @@ 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.TAssumed (T.TBox | T.TArray | T.TSlice | T.TStr) -> + | TAdtId _ | TAssumed (TBox | TArray | TSlice | TStr) -> assert (field_values = []); (ctx, None) - | T.Tuple -> + | TTuple -> (* Return *) let variant_id = adt_v.variant_id in assert (variant_id = None); @@ -2386,7 +2386,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) let ctx, vars = fresh_vars_for_symbolic_values svl ctx in let branch = translate_expression branch ctx in match type_id with - | T.AdtId adt_id -> + | TAdtId adt_id -> (* Detect if this is an enumeration or not *) let tdef = bs_ctx_lookup_llbc_type_decl adt_id ctx in let is_enum = TypesUtils.type_decl_is_enum tdef in @@ -2433,14 +2433,14 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) let field_proj = gen_field_proj fid var in mk_let monadic (mk_typed_pattern_from_var var None) field_proj e) id_var_pairs branch - | T.Tuple -> + | TTuple -> let vars = List.map (fun x -> mk_typed_pattern_from_var x None) vars in let monadic = false in mk_let monadic (mk_simpl_tuple_pattern vars) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.TAssumed T.TBox -> + | TAssumed TBox -> (* There should be exactly one variable *) let var = match vars with [ v ] -> v | _ -> raise (Failure "Unreachable") @@ -2452,7 +2452,7 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) (mk_typed_pattern_from_var var None) (mk_opt_mplace_texpression scrutinee_mplace scrutinee) branch - | T.TAssumed (T.TArray | T.TSlice | T.TStr) -> + | TAssumed (TArray | TSlice | TStr) -> (* We can't expand those values: we can access the fields only * through the functions provided by the API (note that we don't * know how to expand values like vectors or arrays, because they have a variable number @@ -2484,7 +2484,7 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) let values = List.map (typed_value_to_texpression ctx ectx) values in let values = FieldId.mapi (fun fid v -> (fid, v)) values in let su : struct_update = - { struct_id = TAssumed Array; init = None; updates = values } + { struct_id = TAssumed TArray; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } | VaCGValue cg_id -> { e = CVar cg_id; ty = var.ty } @@ -2735,9 +2735,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = 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 types = List.map (fun (ty : T.type_var) -> TVar ty.T.index) types in let const_generics = List.map (fun (cg : T.const_generic_var) -> T.CGVar cg.T.index) diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index edd67749..ddb9d681 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -80,14 +80,14 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) ls in ExpandAdt exp - | T.Ref (_, _, _) -> ( + | T.TRef (_, _, _) -> ( (* Reference expansion: there should be one branch *) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TypeVar _ + | T.TVar _ | T.TLiteral TChar - | Never | T.TraitType _ | T.Arrow _ | T.RawPtr _ -> + | TNever | T.TTraitType _ | T.TArrow _ | T.TRawPtr _ -> raise (Failure "Ill-formed symbolic expansion") in Some (Expansion (place, sv, expansion)) diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 6318c624..eddc1e42 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -121,8 +121,8 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) let rec analyze (expl_info : expl_info) (ty_info : partial_type_info) (ty : ty) : partial_type_info = match ty with - | TLiteral _ | Never | TraitType _ -> ty_info - | TypeVar var_id -> ( + | TLiteral _ | TNever | TTraitType _ -> ty_info + | TVar var_id -> ( (* Update the information for the proper parameter, if necessary *) match ty_info.param_infos with | None -> ty_info @@ -144,7 +144,7 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) in let param_infos = Some param_infos in { ty_info with param_infos }) - | Ref (r, rty, rkind) -> + | TRef (r, rty, rkind) -> (* Update the type info *) let contains_static = r_is_static r in let contains_borrow = true in @@ -168,15 +168,15 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) in (* Continue exploring *) analyze expl_info ty_info rty - | RawPtr (rty, _) -> + | TRawPtr (rty, _) -> (* TODO: not sure what to do here *) analyze expl_info ty_info rty - | TAdt ((Tuple | TAssumed (TBox | TSlice | TArray | TStr)), generics) -> + | TAdt ((TTuple | TAssumed (TBox | TSlice | TArray | TStr)), generics) -> (* Nothing to update: just explore the type parameters *) List.fold_left (fun ty_info ty -> analyze expl_info ty_info ty) ty_info generics.types - | TAdt (AdtId adt_id, generics) -> + | TAdt (TAdtId 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 *) @@ -233,7 +233,7 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) in (* Return *) ty_info - | Arrow (inputs, output) -> + | TArrow (inputs, output) -> (* Just dive into the arrow *) let ty_info = List.fold_left -- cgit v1.2.3 From 746239e8f29de85f848d14e44eac8690e2065a1d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 12 Nov 2023 20:41:58 +0100 Subject: Add the "V" prefix to most variants related to values --- compiler/InterpreterBorrows.ml | 338 ++++++++++++++++----------------- compiler/InterpreterBorrowsCore.ml | 105 +++++----- compiler/InterpreterExpansion.ml | 29 ++- compiler/InterpreterExpressions.ml | 106 +++++------ compiler/InterpreterLoopsFixedPoint.ml | 18 +- compiler/InterpreterLoopsMatchCtxs.ml | 76 ++++---- compiler/InterpreterPaths.ml | 84 ++++---- compiler/InterpreterProjectors.ml | 112 +++++------ compiler/InterpreterStatements.ml | 38 ++-- compiler/InterpreterUtils.ml | 8 +- compiler/Invariants.ml | 277 +++++++++++++-------------- compiler/Print.ml | 25 +-- compiler/SymbolicToPure.ml | 20 +- compiler/Values.ml | 18 +- compiler/ValuesUtils.ml | 20 +- 15 files changed, 629 insertions(+), 645 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index c54d55d4..566061c2 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -79,10 +79,10 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) | None -> () | Some c -> ( match c with - | V.SharedLoan (bids, _) -> + | VSharedLoan (bids, _) -> raise (FoundPriority (InnerLoans (Borrows bids))) - | V.MutLoan bid -> raise (FoundPriority (InnerLoans (Borrow bid))) - )) + | VMutLoan bid -> raise (FoundPriority (InnerLoans (Borrow bid)))) + ) in (* The environment is used to keep track of the outer loans *) @@ -92,18 +92,18 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) (** We reimplement {!visit_Loan} because we may have to update the outer borrows *) - method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) - lc = + method! visit_VLoan + (outer : V.AbstractionId.id option * borrow_ids option) lc = match lc with - | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) - | V.SharedLoan (bids, v) -> + | VMutLoan bid -> VLoan (super#visit_VMutLoan outer bid) + | VSharedLoan (bids, v) -> (* Update the outer borrows before diving into the shared value *) let outer = update_outer_borrows outer (Borrows bids) in - V.Loan (super#visit_SharedLoan outer bids v) + VLoan (super#visit_VSharedLoan outer bids v) - method! visit_Borrow outer bc = + method! visit_VBorrow outer bc = match bc with - | SharedBorrow l' | ReservedMutBorrow l' -> + | VSharedBorrow l' | VReservedMutBorrow l' -> (* Check if this is the borrow we are looking for *) if l = l' then ( (* Check if there are outer borrows or if we are inside an abstraction *) @@ -111,9 +111,9 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) (* Register the update *) set_replaced_bc (fst outer) (Concrete bc); (* Update the value *) - V.Bottom) - else super#visit_Borrow outer bc - | V.MutBorrow (l', bv) -> + VBottom) + else super#visit_VBorrow outer bc + | VMutBorrow (l', bv) -> (* Check if this is the borrow we are looking for *) if l = l' then ( (* Check if there are outer borrows or if we are inside an abstraction *) @@ -121,11 +121,11 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) (* Register the update *) set_replaced_bc (fst outer) (Concrete bc); (* Update the value *) - V.Bottom) + VBottom) else (* Update the outer borrows before diving into the borrowed value *) let outer = update_outer_borrows outer (Borrow l') in - V.Borrow (super#visit_MutBorrow outer l' bv) + VBorrow (super#visit_VMutBorrow outer l' bv) (** We reimplement {!visit_ALoan} because we may have to update the outer borrows *) @@ -136,31 +136,31 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) * need it to properly instantiate the backward functions when generating * the pure translation. *) match lc with - | V.AMutLoan (_, _) -> + | AMutLoan (_, _) -> (* Nothing special to do *) super#visit_ALoan outer lc - | V.ASharedLoan (bids, v, av) -> + | ASharedLoan (bids, v, av) -> (* Explore the shared value - we need to update the outer borrows *) let souter = update_outer_borrows outer (Borrows bids) in let v = super#visit_typed_value souter v in (* Explore the child avalue - we keep the same outer borrows *) let av = super#visit_typed_avalue outer av in (* Reconstruct *) - V.ALoan (V.ASharedLoan (bids, v, av)) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan _ + ALoan (ASharedLoan (bids, v, av)) + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan _ (* The loan has ended, so no need to update the outer borrows *) - | V.AIgnoredMutLoan _ (* Nothing special to do *) - | V.AEndedIgnoredMutLoan + | AIgnoredMutLoan _ (* Nothing special to do *) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } (* Nothing special to do *) - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Nothing special to do *) super#visit_ALoan outer lc method! visit_ABorrow outer bc = match bc with - | V.AMutBorrow (bid, _) -> + | AMutBorrow (bid, _) -> (* Check if this is the borrow we are looking for *) if bid = l then ( (* TODO: treat this case differently. We should not introduce @@ -184,12 +184,12 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) * abstraction (and not really giving the value back to the context) * we do not insert {!AEndedMutBorrow} but rather {!ABottom} *) raise (Failure "Unimplemented") - (* V.ABottom *)) + (* ABottom *)) else (* Update the outer borrows before diving into the child avalue *) let outer = update_outer_borrows outer (Borrow bid) in super#visit_ABorrow outer bc - | V.ASharedBorrow bid -> + | ASharedBorrow bid -> (* Check if this is the borrow we are looking for *) if bid = l then ( (* Check there are outer borrows, or if we need to end the whole @@ -199,16 +199,16 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) set_replaced_bc (fst outer) (Abstract bc); (* Update the value - note that we are necessarily in the second * of the two cases described above *) - V.ABottom) + ABottom) else super#visit_ABorrow outer bc - | V.AIgnoredMutBorrow (_, _) - | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow + | AIgnoredMutBorrow (_, _) + | AEndedMutBorrow _ + | AEndedIgnoredMutBorrow { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedBorrow -> + | AEndedSharedBorrow -> (* Nothing special to do *) super#visit_ABorrow outer bc - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> (* Check if the borrow we are looking for is in the asb *) if borrow_in_asb l asb then ( (* Check there are outer borrows, or if we need to end the whole @@ -219,7 +219,7 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) (* Update the value - note that we are necessarily in the second * of the two cases described above *) let asb = remove_borrow_from_asb l asb in - V.ABorrow (V.AProjSharedBorrow asb)) + ABorrow (AProjSharedBorrow asb)) else (* Nothing special to do *) super#visit_ABorrow outer bc @@ -282,32 +282,32 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) overriding {!visit_ALoan} *) method! visit_typed_value opt_abs (v : V.typed_value) : V.typed_value = match v.V.value with - | V.Loan lc -> + | VLoan lc -> let value = self#visit_typed_Loan opt_abs v.V.ty lc in ({ v with V.value } : V.typed_value) | _ -> super#visit_typed_value opt_abs v method visit_typed_Loan opt_abs ty lc = match lc with - | V.SharedLoan (bids, v) -> + | VSharedLoan (bids, v) -> (* We are giving back a value (i.e., the content of a *mutable* * borrow): nothing special to do *) - V.Loan (super#visit_SharedLoan opt_abs bids v) - | V.MutLoan bid' -> + VLoan (super#visit_VSharedLoan opt_abs bids v) + | VMutLoan bid' -> (* Check if this is the loan we are looking for *) if bid' = bid then ( (* Sanity check *) let expected_ty = ty in - if nv.V.ty <> expected_ty then ( + if nv.ty <> expected_ty then ( log#serror ("give_back_value: improper type:\n- expected: " ^ PA.ty_to_string ctx ty ^ "\n- received: " - ^ PA.ty_to_string ctx nv.V.ty); + ^ PA.ty_to_string ctx nv.ty); raise (Failure "Value given back doesn't have the proper type")); (* Replace *) set_replaced (); - nv.V.value) - else V.Loan (super#visit_MutLoan opt_abs bid') + nv.value) + else VLoan (super#visit_VMutLoan opt_abs bid') (** This is a bit annoying, but as we need the type of the avalue we are exploring, in order to be able to project the value we give @@ -333,7 +333,7 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) * it is necessarily because we ended a parent abstraction, * and the given back value is thus a symbolic value *) match nv.V.value with - | V.Symbolic sv -> + | VSymbolic sv -> let abs = Option.get opt_abs in (* Remember the given back value as a meta-value * TODO: it is a bit annoying to have to deconstruct @@ -374,7 +374,7 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) ty in match lc with - | V.AMutLoan (bid', child) -> + | AMutLoan (bid', child) -> if bid' = bid then ( (* This is the loan we are looking for: apply the projection to * the value we give back and replaced this mutable loan with @@ -391,17 +391,17 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in (* Return the new value *) - V.ALoan (V.AEndedMutLoan { child; given_back; given_back_meta })) + ALoan (AEndedMutLoan { child; given_back; given_back_meta })) else (* Continue exploring *) super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) -> + | ASharedLoan (_, _, _) -> (* We are giving back a value to a *mutable* loan: nothing special to do *) super#visit_ALoan opt_abs lc - | V.AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> + | AEndedMutLoan { child = _; given_back = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> (* Nothing special to do *) super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (opt_bid, child) -> + | AIgnoredMutLoan (opt_bid, child) -> (* This loan is ignored, but we may have to project on a subvalue * of the value which is given back *) if opt_bid = Some bid then @@ -417,12 +417,12 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) in (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in - V.ALoan - (V.AEndedIgnoredMutLoan { given_back; child; given_back_meta }) + ALoan + (AEndedIgnoredMutLoan { given_back; child; given_back_meta }) else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Nothing special to do *) super#visit_ALoan opt_abs lc @@ -624,9 +624,9 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : object inherit [_] C.map_eval_ctx as super - method! visit_Loan opt_abs lc = + method! visit_VLoan opt_abs lc = match lc with - | V.SharedLoan (bids, shared_value) -> + | VSharedLoan (bids, shared_value) -> if V.BorrowId.Set.mem bid bids then ( (* This is the loan we are looking for *) set_replaced (); @@ -635,21 +635,21 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : * loan identifier *) if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value else - V.Loan - (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) + VLoan + (VSharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) else (* Not the loan we are looking for: continue exploring *) - V.Loan (super#visit_SharedLoan opt_abs bids shared_value) - | V.MutLoan bid' -> + VLoan (super#visit_VSharedLoan opt_abs bids shared_value) + | VMutLoan bid' -> (* We are giving back a *shared* borrow: nothing special to do *) - V.Loan (super#visit_MutLoan opt_abs bid') + VLoan (super#visit_VMutLoan opt_abs bid') method! visit_ALoan opt_abs lc = match lc with - | V.AMutLoan (bid, av) -> + | AMutLoan (bid, av) -> (* Nothing special to do (we are giving back a *shared* borrow) *) - V.ALoan (super#visit_AMutLoan opt_abs bid av) - | V.ASharedLoan (bids, shared_value, child) -> + ALoan (super#visit_AMutLoan opt_abs bid av) + | ASharedLoan (bids, shared_value, child) -> if V.BorrowId.Set.mem bid bids then ( (* This is the loan we are looking for *) set_replaced (); @@ -657,24 +657,24 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : * to end the loan. Otherwise, we just remove the current * loan identifier *) if V.BorrowId.Set.cardinal bids = 1 then - V.ALoan (V.AEndedSharedLoan (shared_value, child)) + ALoan (AEndedSharedLoan (shared_value, child)) else - V.ALoan - (V.ASharedLoan + ALoan + (ASharedLoan (V.BorrowId.Set.remove bid bids, shared_value, child))) else (* Not the loan we are looking for: continue exploring *) super#visit_ALoan opt_abs lc - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } (* Nothing special to do (the loan has ended) *) - | V.AEndedSharedLoan (_, _) + | AEndedSharedLoan (_, _) (* Nothing special to do (the loan has ended) *) - | V.AIgnoredMutLoan (_, _) + | AIgnoredMutLoan (_, _) (* Nothing special to do (we are giving back a *shared* borrow) *) - | V.AEndedIgnoredMutLoan + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } (* Nothing special to do *) - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Nothing special to do *) super#visit_ALoan opt_abs lc end @@ -705,15 +705,15 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) object inherit [_] C.map_env as super - method! visit_SharedLoan env bids sv = + method! visit_VSharedLoan env bids sv = (* Shared loan: check if the borrow id we are looking for is in the set of borrow ids. If yes, insert the new borrow id, otherwise explore inside the shared value *) if V.BorrowId.Set.mem original_bid bids then ( set_ref (); let bids' = V.BorrowId.Set.add new_bid bids in - V.SharedLoan (bids', sv)) - else super#visit_SharedLoan env bids sv + VSharedLoan (bids', sv)) + else super#visit_VSharedLoan env bids sv method! visit_ASharedLoan env bids v av = (* This case is similar to the {!SharedLoan} case *) @@ -794,7 +794,7 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } in match bc with - | Concrete (V.MutBorrow (l', tv)) -> + | Concrete (VMutBorrow (l', tv)) -> (* Sanity check *) assert (l' = l); assert (not (loans_in_value tv)); @@ -802,14 +802,14 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); (* Update the context *) give_back_value config l tv ctx - | Concrete (V.SharedBorrow l' | V.ReservedMutBorrow l') -> + | Concrete (VSharedBorrow l' | VReservedMutBorrow l') -> (* Sanity check *) assert (l' = l); (* Check that the borrow is somewhere - purely a sanity check *) assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); (* Update the context *) give_back_shared config l ctx - | Abstract (V.AMutBorrow (l', av)) -> + | Abstract (AMutBorrow (l', av)) -> (* Sanity check *) assert (l' = l); (* Check that the corresponding loan is somewhere - purely a sanity check *) @@ -826,21 +826,21 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) give_back_avalue_to_same_abstraction config l av (mk_typed_value_from_symbolic_value sv) ctx - | Abstract (V.ASharedBorrow l') -> + | Abstract (ASharedBorrow l') -> (* Sanity check *) assert (l' = l); (* Check that the borrow is somewhere - purely a sanity check *) assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); (* Update the context *) give_back_shared config l ctx - | Abstract (V.AProjSharedBorrow asb) -> + | Abstract (AProjSharedBorrow asb) -> (* Sanity check *) assert (borrow_in_asb l asb); (* Update the context *) give_back_shared config l ctx | Abstract - ( V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedSharedBorrow ) -> + ( AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ + | AEndedSharedBorrow ) -> raise (Failure "Unreachable") let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) @@ -970,7 +970,7 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) | Ok (ctx, Some (abs_id_opt, bc)) -> (* Sanity check: the borrowed value shouldn't contain loans *) (match bc with - | Concrete (V.MutBorrow (_, bv)) -> + | Concrete (VMutBorrow (_, bv)) -> assert (Option.is_none (get_first_loan_in_value bv)) | _ -> ()); (* Give back the value *) @@ -1182,8 +1182,8 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) (** We may need to end borrows in "regular" values, because of shared values *) method! visit_borrow_content _ bc = match bc with - | V.SharedBorrow _ | V.MutBorrow (_, _) -> raise (FoundBorrowContent bc) - | V.ReservedMutBorrow _ -> raise (Failure "Unreachable") + | VSharedBorrow _ | VMutBorrow (_, _) -> raise (FoundBorrowContent bc) + | VReservedMutBorrow _ -> raise (Failure "Unreachable") end in (* Lookup the abstraction *) @@ -1272,7 +1272,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) ^ borrow_content_to_string ctx bc)); let ctx = match bc with - | V.SharedBorrow bid -> ( + | VSharedBorrow bid -> ( (* Replace the shared borrow with bottom *) let allow_inner_loans = false in match @@ -1282,7 +1282,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) | Ok (ctx, _) -> (* Give back *) give_back_shared config bid ctx) - | V.MutBorrow (bid, v) -> ( + | VMutBorrow (bid, v) -> ( (* Replace the mut borrow with bottom *) let allow_inner_loans = false in match @@ -1293,7 +1293,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) (* Give the value back - note that the mut borrow was below a * shared borrow: the value is thus unchanged *) give_back_value config bid v ctx) - | V.ReservedMutBorrow _ -> raise (Failure "Unreachable") + | VReservedMutBorrow _ -> raise (Failure "Unreachable") in (* Reexplore *) end_abstraction_borrows config chain abs_id cf ctx @@ -1501,9 +1501,9 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } in match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> + | _, Concrete (VMutLoan _) -> raise (Failure "Expected a shared loan, found a mut loan") - | _, Concrete (V.SharedLoan (bids, sv)) -> + | _, Concrete (VSharedLoan (bids, sv)) -> (* Check that there is only one borrow id (l) and update the loan *) assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); (* We need to check that there aren't any loans in the value: @@ -1515,7 +1515,7 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) (* Check there aren't reserved borrows *) assert (not (reserved_in_value sv)); (* Update the loan content *) - let ctx = update_loan ek l (V.MutLoan l) ctx in + let ctx = update_loan ek l (VMutLoan l) ctx in (* Continue *) cf sv ctx | _, Abstract _ -> @@ -1542,11 +1542,11 @@ let replace_reserved_borrow_with_mut_borrow (l : V.BorrowId.id) (cf : m_fun) in let ctx = match lookup_borrow ek l ctx with - | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> + | Concrete (VSharedBorrow _ | VMutBorrow (_, _)) -> raise (Failure "Expected a reserved mutable borrow") - | Concrete (V.ReservedMutBorrow _) -> + | Concrete (VReservedMutBorrow _) -> (* Update it *) - update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx + update_borrow ek l (VMutBorrow (l, borrowed_value)) ctx | Abstract _ -> (* This can't happen for sure *) raise @@ -1566,8 +1566,8 @@ let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } in match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> raise (Failure "Unreachable") - | _, Concrete (V.SharedLoan (bids, sv)) -> ( + | _, Concrete (VMutLoan _) -> raise (Failure "Unreachable") + | _, Concrete (VSharedLoan (bids, sv)) -> ( (* If there are loans inside the value, end them. Note that there can't be reserved borrows inside the value. If we perform an update, do a recursive call to lookup the updated value *) @@ -1576,8 +1576,8 @@ let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : (* End the loans *) let cc = match lc with - | V.SharedLoan (bids, _) -> end_borrows config bids - | V.MutLoan bid -> end_borrow config bid + | VSharedLoan (bids, _) -> end_borrows config bids + | VMutLoan bid -> end_borrow config bid in (* Recursive call *) let cc = comp cc (promote_reserved_mut_borrow config l) in @@ -1637,8 +1637,8 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) (* Function to explore an avalue and destructure it *) let rec list_avalues (allow_borrows : bool) (push : V.typed_avalue -> unit) (av : V.typed_avalue) : unit = - let ty = av.V.ty in - match av.V.value with + let ty = av.ty in + match av.value with | ABottom | AIgnored -> () | AAdt adt -> (* Simply explore the children *) @@ -1646,17 +1646,17 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) | ALoan lc -> ( (* Explore the loan content *) match lc with - | V.ASharedLoan (bids, sv, child_av) -> + | ASharedLoan (bids, sv, child_av) -> (* We don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.V.value)); + assert (not (value_has_borrows ctx sv.value)); (* Destructure the shared value *) let avl, sv = if destructure_shared_values then list_values sv else ([], sv) in (* Push a value *) - let ignored = mk_aignored child_av.V.ty in - let value = V.ALoan (V.ASharedLoan (bids, sv, ignored)) in - push { V.value; ty }; + let ignored = mk_aignored child_av.ty in + let value = V.ALoan (ASharedLoan (bids, sv, ignored)) in + push { value; ty }; (* Explore the child *) list_avalues false push_fail child_av; (* Push the avalues introduced because we decomposed the inner loans - @@ -1666,25 +1666,25 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) exactly the same way as [list_avalues] (i.e., with a similar signature) *) List.iter push avl - | V.AMutLoan (bid, child_av) -> + | AMutLoan (bid, child_av) -> (* Explore the child *) list_avalues false push_fail child_av; (* Explore the whole loan *) - let ignored = mk_aignored child_av.V.ty in - let value = V.ALoan (V.AMutLoan (bid, ignored)) in - push { V.value; ty } - | V.AIgnoredMutLoan (opt_bid, child_av) -> + let ignored = mk_aignored child_av.ty in + let value = V.ALoan (AMutLoan (bid, ignored)) in + push { value; ty } + | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) assert (not (ty_has_borrows ctx.type_context.type_infos child_av.ty)); assert (opt_bid = None); (* Simply explore the child *) list_avalues false push_fail child_av - | V.AEndedMutLoan + | AEndedMutLoan { child = child_av; given_back = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, child_av) - | V.AEndedIgnoredMutLoan + | AEndedSharedLoan (_, child_av) + | AEndedIgnoredMutLoan { child = child_av; given_back = _; given_back_meta = _ } - | V.AIgnoredSharedLoan child_av -> + | AIgnoredSharedLoan child_av -> (* We don't support nested borrows for now *) assert (not (ty_has_borrows ctx.type_context.type_infos child_av.ty)); (* Simply explore the child *) @@ -1694,34 +1694,34 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) assert allow_borrows; (* Explore the borrow content *) match bc with - | V.AMutBorrow (bid, child_av) -> + | AMutBorrow (bid, child_av) -> (* Explore the child *) list_avalues false push_fail child_av; (* Explore the borrow *) - let ignored = mk_aignored child_av.V.ty in - let value = V.ABorrow (V.AMutBorrow (bid, ignored)) in - push { V.value; ty } - | V.ASharedBorrow _ -> + let ignored = mk_aignored child_av.ty in + let value = V.ABorrow (AMutBorrow (bid, ignored)) in + push { value; ty } + | ASharedBorrow _ -> (* Nothing specific to do: keep the value as it is *) push av - | V.AIgnoredMutBorrow (opt_bid, child_av) -> + | AIgnoredMutBorrow (opt_bid, child_av) -> (* We don't support nested borrows for now *) assert (not (ty_has_borrows ctx.type_context.type_infos child_av.ty)); assert (opt_bid = None); (* Just explore the child *) list_avalues false push_fail child_av - | V.AEndedIgnoredMutBorrow + | AEndedIgnoredMutBorrow { child = child_av; given_back = _; given_back_meta = _ } -> (* We don't support nested borrows for now *) assert (not (ty_has_borrows ctx.type_context.type_infos child_av.ty)); (* Just explore the child *) list_avalues false push_fail child_av - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> (* We don't support nested borrows *) assert (asb = []); (* Nothing specific to do *) () - | V.AEndedMutBorrow _ | V.AEndedSharedBorrow -> + | AEndedMutBorrow _ | AEndedSharedBorrow -> (* If we get there it means the abstraction ended: it should not be in the context anymore (if we end *one* borrow in an abstraction, we have to end them all and remove the abstraction from the context) @@ -1732,29 +1732,29 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) expanded *) assert (not (ty_has_borrows ctx.type_context.type_infos ty)) and list_values (v : V.typed_value) : V.typed_avalue list * V.typed_value = - let ty = v.V.ty in - match v.V.value with + let ty = v.ty in + match v.value with | VLiteral _ -> ([], v) | VAdt adt -> let avll, field_values = List.split (List.map list_values adt.field_values) in let avl = List.concat avll in - let adt = { adt with V.field_values } in - (avl, { v with V.value = VAdt adt }) - | Bottom -> raise (Failure "Unreachable") - | Borrow _ -> + let adt = { adt with field_values } in + (avl, { v with value = VAdt adt }) + | VBottom -> raise (Failure "Unreachable") + | VBorrow _ -> (* We don't support nested borrows for now *) raise (Failure "Unreachable") - | Loan lc -> ( + | VLoan lc -> ( match lc with - | SharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> let avl, sv = list_values sv in if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) assert (ty_no_regions ty); let av : V.typed_avalue = - assert (not (value_has_loans_or_borrows ctx sv.V.value)); + assert (not (value_has_loans_or_borrows ctx sv.value)); (* We introduce fresh ids for the symbolic values *) let mk_value_with_fresh_sids (v : V.typed_value) : V.typed_value = @@ -1770,16 +1770,14 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) in let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) - let value = - V.ALoan (V.ASharedLoan (bids, sv, mk_aignored ty)) - in - { V.value; ty } + let value = V.ALoan (ASharedLoan (bids, sv, mk_aignored ty)) in + { value; ty } in let avl = List.append [ av ] avl in (avl, sv)) - else (avl, { v with V.value = V.Loan (V.SharedLoan (bids, sv)) }) - | MutLoan _ -> raise (Failure "Unreachable")) - | Symbolic _ -> + else (avl, { v with value = VLoan (VSharedLoan (bids, sv)) }) + | VMutLoan _ -> raise (Failure "Unreachable")) + | VSymbolic _ -> (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) assert (not (ty_has_borrows ctx.type_context.type_infos ty)); @@ -1787,10 +1785,10 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) in (* Destructure the avalues *) - List.iter (list_avalues true push_avalue) abs0.V.avalues; + List.iter (list_avalues true push_avalue) abs0.avalues; let avalues = !avalues in (* Update *) - { abs0 with V.avalues; kind = abs_kind; can_end } + { abs0 with avalues; kind = abs_kind; can_end } let abs_is_destructured (destructure_shared_values : bool) (ctx : C.eval_ctx) (abs : V.abs) : bool = @@ -1840,14 +1838,14 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) ("convert_value_to_abstractions: to_avalues:\n- value: " ^ typed_value_to_string ctx v)); - let ty = v.V.ty in - match v.V.value with - | V.VLiteral _ -> ([], v) - | V.Bottom -> + let ty = v.ty in + match v.value with + | VLiteral _ -> ([], v) + | VBottom -> (* Can happen: we *do* convert dummy values to abstractions, and dummy values can contain bottoms *) ([], v) - | V.VAdt adt -> + | VAdt adt -> (* Two cases, depending on whether we have to group all the borrows/loans inside one abstraction or not *) let avl, field_values = @@ -1879,72 +1877,72 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) ([], field_values) in let adt = { adt with field_values } in - (avl, { v with V.value = V.VAdt adt }) - | V.Borrow bc -> ( + (avl, { v with value = VAdt adt }) + | VBorrow bc -> ( let _, ref_ty, kind = ty_as_ref ty in assert (ty_no_regions ref_ty); (* Sanity check *) assert allow_borrows; (* Convert the borrow content *) match bc with - | SharedBorrow bid -> + | VSharedBorrow bid -> assert (ty_no_regions ref_ty); - let ty = T.TRef (T.RVar r_id, ref_ty, kind) in - let value = V.ABorrow (V.ASharedBorrow bid) in + let ty = T.TRef (RVar r_id, ref_ty, kind) in + let value = V.ABorrow (ASharedBorrow bid) in ([ { V.value; ty } ], v) - | MutBorrow (bid, bv) -> + | VMutBorrow (bid, bv) -> let r_id = if group then r_id else C.fresh_region_id () in (* We don't support nested borrows for now *) - assert (not (value_has_borrows ctx bv.V.value)); + assert (not (value_has_borrows ctx bv.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ty = T.TRef (T.RVar r_id, ref_ty, kind) in + let ty = T.TRef (RVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in - let av = V.ABorrow (V.AMutBorrow (bid, ignored)) in + let av = V.ABorrow (AMutBorrow (bid, ignored)) in let av = { V.value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, because we don't support nested borrows for now) *) let avl, bv = to_avalues false true true r_id bv in - let value = { v with V.value = V.Borrow (V.MutBorrow (bid, bv)) } in + let value = { v with value = VBorrow (VMutBorrow (bid, bv)) } in (av :: avl, value) - | ReservedMutBorrow _ -> + | VReservedMutBorrow _ -> (* This borrow should have been activated *) raise (Failure "Unexpected")) - | V.Loan lc -> ( + | VLoan lc -> ( match lc with - | V.SharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> let r_id = if group then r_id else C.fresh_region_id () in (* We don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.V.value)); + assert (not (value_has_borrows ctx sv.value)); (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (T.RVar r_id) ty T.Shared in + let ty = mk_ref_ty (RVar r_id) ty Shared in let ignored = mk_aignored ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in - let av = V.ALoan (V.ASharedLoan (bids, sv, ignored)) in + let av = V.ALoan (ASharedLoan (bids, sv, ignored)) in let av = { V.value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, because we don't support nested borrows for now) *) let value : V.value = - if destructure_shared_values then sv.V.value - else V.Loan (V.SharedLoan (bids, sv)) + if destructure_shared_values then sv.value + else VLoan (VSharedLoan (bids, sv)) in - let value = { v with V.value } in + let value = { v with value } in (av :: avl, value) - | V.MutLoan bid -> + | VMutLoan bid -> (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (T.RVar r_id) ty T.Mut in + let ty = mk_ref_ty (RVar r_id) ty Mut in let ignored = mk_aignored ty in - let av = V.ALoan (V.AMutLoan (bid, ignored)) in + let av = V.ALoan (AMutLoan (bid, ignored)) in let av = { V.value = av; ty } in ([ av ], v)) - | V.Symbolic _ -> + | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - assert (not (value_has_borrows ctx v.V.value)); + assert (not (value_has_borrows ctx v.value)); (* Return nothing *) ([], v) in @@ -2043,8 +2041,8 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : | Abstract _ -> raise (Failure "Unreachable") in (match lc with - | SharedLoan (bids, _) -> push_loans bids (Concrete (ty, lc)) - | MutLoan _ -> raise (Failure "Unreachable")); + | VSharedLoan (bids, _) -> push_loans bids (Concrete (ty, lc)) + | VMutLoan _ -> raise (Failure "Unreachable")); (* Continue *) super#visit_loan_content env lc diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 8807f3ef..cde39e9b 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -222,15 +222,15 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) method! visit_borrow_content env bc = match bc with - | V.SharedBorrow bid -> + | V.VSharedBorrow bid -> (* Nothing specific to do *) - super#visit_SharedBorrow env bid - | V.ReservedMutBorrow bid -> + super#visit_VSharedBorrow env bid + | V.VReservedMutBorrow bid -> (* Nothing specific to do *) - super#visit_ReservedMutBorrow env bid - | V.MutBorrow (bid, mv) -> + super#visit_VReservedMutBorrow env bid + | V.VMutBorrow (bid, mv) -> (* Control the dive *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + if ek.enter_mut_borrows then super#visit_VMutBorrow env bid mv else () (** We reimplement {!visit_Loan} (rather than the more precise functions @@ -240,17 +240,17 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) *) method! visit_loan_content env lc = match lc with - | V.SharedLoan (bids, sv) -> + | V.VSharedLoan (bids, sv) -> (* Check if this is the loan we are looking for, and control the dive *) if V.BorrowId.Set.mem l bids then raise (FoundGLoanContent (Concrete lc)) else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv + super#visit_VSharedLoan env bids sv else () - | V.MutLoan bid -> + | V.VMutLoan bid -> (* Check if this is the loan we are looking for *) if bid = l then raise (FoundGLoanContent (Concrete lc)) - else super#visit_MutLoan env bid + else super#visit_VMutLoan env bid (** Note that we don't control diving inside the abstractions: if we allow to dive inside abstractions, we allow to go anywhere @@ -335,28 +335,28 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.id) method! visit_borrow_content env bc = match bc with - | V.SharedBorrow _ | V.ReservedMutBorrow _ -> + | VSharedBorrow _ | VReservedMutBorrow _ -> (* Nothing specific to do *) super#visit_borrow_content env bc - | V.MutBorrow (bid, mv) -> + | VMutBorrow (bid, mv) -> (* Control the dive into mutable borrows *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) + if ek.enter_mut_borrows then super#visit_VMutBorrow env bid mv + else VMutBorrow (bid, mv) (** We reimplement {!visit_loan_content} (rather than one of the sub- functions) on purpose: exhaustive matches are good for maintenance *) method! visit_loan_content env lc = match lc with - | V.SharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> (* Shared loan: check if this is the loan we are looking for, and control the dive. *) if V.BorrowId.Set.mem l bids then update () else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> + super#visit_VSharedLoan env bids sv + else VSharedLoan (bids, sv) + | VMutLoan bid -> (* Mut loan: checks if this is the loan we are looking for *) - if bid = l then update () else super#visit_MutLoan env bid + if bid = l then update () else super#visit_VMutLoan env bid (** Note that once inside the abstractions, we don't control diving (there are no use cases requiring finer control). @@ -432,42 +432,42 @@ let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) method! visit_borrow_content env bc = match bc with - | V.MutBorrow (bid, mv) -> + | VMutBorrow (bid, mv) -> (* Check the borrow id and control the dive *) if bid = l then raise (FoundGBorrowContent (Concrete bc)) - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else if ek.enter_mut_borrows then super#visit_VMutBorrow env bid mv else () - | V.SharedBorrow bid -> + | VSharedBorrow bid -> (* Check the borrow id *) if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - | V.ReservedMutBorrow bid -> + | VReservedMutBorrow bid -> (* Check the borrow id *) if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () method! visit_loan_content env lc = match lc with - | V.MutLoan bid -> - (* Nothing special to do *) super#visit_MutLoan env bid - | V.SharedLoan (bids, sv) -> + | VMutLoan bid -> + (* Nothing special to do *) super#visit_VMutLoan env bid + | VSharedLoan (bids, sv) -> (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + if ek.enter_shared_loans then super#visit_VSharedLoan env bids sv else () method! visit_aborrow_content env bc = match bc with - | V.AMutBorrow (bid, av) -> + | AMutBorrow (bid, av) -> if bid = l then raise (FoundGBorrowContent (Abstract bc)) else super#visit_AMutBorrow env bid av - | V.ASharedBorrow bid -> + | ASharedBorrow bid -> if bid = l then raise (FoundGBorrowContent (Abstract bc)) else super#visit_ASharedBorrow env bid - | V.AIgnoredMutBorrow (_, _) - | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow + | AIgnoredMutBorrow (_, _) + | AEndedMutBorrow _ + | AEndedIgnoredMutBorrow { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedBorrow -> + | AEndedSharedBorrow -> super#visit_aborrow_content env bc - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> if borrow_in_asb l asb then raise (FoundGBorrowContent (Abstract bc)) else () @@ -516,27 +516,28 @@ let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) method! visit_borrow_content env bc = match bc with - | V.MutBorrow (bid, mv) -> + | VMutBorrow (bid, mv) -> (* Check the id and control dive *) if bid = l then update () - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - | V.SharedBorrow bid -> + else if ek.enter_mut_borrows then super#visit_VMutBorrow env bid mv + else VMutBorrow (bid, mv) + | VSharedBorrow bid -> (* Check the id *) - if bid = l then update () else super#visit_SharedBorrow env bid - | V.ReservedMutBorrow bid -> + if bid = l then update () else super#visit_VSharedBorrow env bid + | VReservedMutBorrow bid -> (* Check the id *) - if bid = l then update () else super#visit_ReservedMutBorrow env bid + if bid = l then update () + else super#visit_VReservedMutBorrow env bid method! visit_loan_content env lc = match lc with - | V.SharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> + if ek.enter_shared_loans then super#visit_VSharedLoan env bids sv + else VSharedLoan (bids, sv) + | VMutLoan bid -> (* Nothing specific to do *) - super#visit_MutLoan env bid + super#visit_VMutLoan env bid method! visit_abs env abs = if ek.enter_abs then super#visit_abs env abs else abs @@ -1192,18 +1193,18 @@ let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : (** We may need to visit loan contents because of shared values *) method! visit_loan_content _ lc = match lc with - | V.MutLoan _ -> + | VMutLoan _ -> (* The mut loan linked to the mutable borrow present in a shared * value in an abstraction should be in an AProjBorrows *) raise (Failure "Unreachable") - | V.SharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) + | VSharedLoan (bids, _) -> raise (FoundBorrowIds (Borrows bids)) method! visit_aproj env sproj = (match sproj with - | V.AProjBorrows (_, _) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> + | AProjBorrows (_, _) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> () - | V.AProjLoans (sv, _) -> raise (ValuesUtils.FoundSymbolicValue sv)); + | AProjLoans (sv, _) -> raise (ValuesUtils.FoundSymbolicValue sv)); super#visit_aproj env sproj end in @@ -1225,7 +1226,7 @@ let lookup_shared_value_opt (ctx : C.eval_ctx) (bid : V.BorrowId.id) : | None -> None | Some (_, lc) -> ( match lc with - | Concrete (SharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> + | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> Some sv | _ -> None) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index b07f2629..2b7ff7d0 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -183,9 +183,9 @@ let replace_symbolic_values (at_most_once : bool) object inherit [_] C.map_eval_ctx as super - method! visit_Symbolic env spc = + method! visit_VSymbolic env spc = if same_symbolic_id spc original_sv then replace () - else super#visit_Symbolic env spc + else super#visit_VSymbolic env spc end in (* Apply the substitution *) @@ -326,11 +326,11 @@ let expand_symbolic_value_shared_borrow (config : C.config) object (self) inherit [_] C.map_eval_ctx as super - method! visit_Symbolic env sv = + method! visit_VSymbolic env sv = if same_symbolic_id sv original_sv then let bid = fresh_borrow () in - V.Borrow (V.SharedBorrow bid) - else super#visit_Symbolic env sv + VBorrow (VSharedBorrow bid) + else super#visit_VSymbolic env sv method! visit_EAbs proj_regions abs = assert (Option.is_none proj_regions); @@ -639,7 +639,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = object inherit [_] C.iter_eval_ctx - method! visit_Symbolic _ sv = + method! visit_VSymbolic _ sv = if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then raise (FoundSymbolicValue sv) else () @@ -664,22 +664,22 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ("greedy_expand_symbolics_with_borrows: about to expand: " ^ symbolic_value_to_string ctx sv)); let cc : cm_fun = - match sv.V.sv_ty with - | T.TAdt (TAdtId def_id, _) -> + match sv.sv_ty with + | TAdt (TAdtId 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 *) let def = C.ctx_lookup_type_decl ctx def_id in (match def.kind with - | T.Struct _ | T.Enum ([] | [ _ ]) -> () - | T.Enum (_ :: _) -> + | Struct _ | Enum ([] | [ _ ]) -> () + | Enum (_ :: _) -> raise (Failure ("Attempted to greedily expand a symbolic enumeration \ with > 1 variants (option \ [greedy_expand_symbolics_with_borrows] of [config]): " ^ Print.name_to_string def.name)) - | T.Opaque -> + | Opaque -> raise (Failure "Attempted to greedily expand an opaque type")); (* Also, we need to check if the definition is recursive *) if C.ctx_type_decl_is_rec ctx def_id then @@ -690,16 +690,15 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = [config]): " ^ Print.name_to_string def.name)) else expand_symbolic_value_no_branching config sv None - | T.TAdt ((TTuple | TAssumed TBox), _) | T.TRef (_, _, _) -> + | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) expand_symbolic_value_no_branching config sv None - | T.TAdt (TAssumed (TArray | TSlice | TStr), _) -> + | TAdt (TAssumed (TArray | TSlice | TStr), _) -> (* We can't expand those *) raise (Failure "Attempted to greedily expand an ADT which can't be expanded ") - | T.TVar _ | T.TLiteral _ | TNever | T.TTraitType _ | T.TArrow _ - | T.TRawPtr _ -> + | TVar _ | TLiteral _ | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> raise (Failure "Unreachable") in (* Compose and continue *) diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 7865d7be..58426cad 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -137,18 +137,18 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) * we reverted the changes: the result was less clear actually. In particular, * the fact that we have exhaustive matches below makes very obvious the cases * in which we need to fail *) - match v.V.value with - | V.VLiteral _ -> (ctx, v) - | V.VAdt av -> + match v.value with + | VLiteral _ -> (ctx, v) + | VAdt av -> (* Sanity check *) - (match v.V.ty with - | T.TAdt (T.TAssumed T.TBox, _) -> + (match v.ty with + | TAdt (TAssumed TBox, _) -> raise (Failure "Can't copy an assumed value other than Option") - | T.TAdt (T.TAdtId _, _) as ty -> + | TAdt (TAdtId _, _) as ty -> assert (allow_adt_copy || ty_is_primitively_copyable ty) - | T.TAdt (T.TTuple, _) -> () (* Ok *) - | T.TAdt - ( T.TAssumed (TSlice | T.TArray), + | TAdt (TTuple, _) -> () (* Ok *) + | TAdt + ( TAssumed (TSlice | TArray), { regions = []; types = [ ty ]; @@ -162,33 +162,33 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) (copy_value allow_adt_copy config) ctx av.field_values in - (ctx, { v with V.value = V.VAdt { av with field_values = fields } }) - | V.Bottom -> raise (Failure "Can't copy ⊥") - | V.Borrow bc -> ( + (ctx, { v with value = VAdt { av with field_values = fields } }) + | VBottom -> raise (Failure "Can't copy ⊥") + | VBorrow bc -> ( (* We can only copy shared borrows *) match bc with - | SharedBorrow bid -> + | VSharedBorrow bid -> (* We need to create a new borrow id for the copied borrow, and * update the context accordingly *) let bid' = C.fresh_borrow_id () in let ctx = InterpreterBorrows.reborrow_shared bid bid' ctx in - (ctx, { v with V.value = V.Borrow (SharedBorrow bid') }) - | MutBorrow (_, _) -> raise (Failure "Can't copy a mutable borrow") - | V.ReservedMutBorrow _ -> + (ctx, { v with value = VBorrow (VSharedBorrow bid') }) + | VMutBorrow (_, _) -> raise (Failure "Can't copy a mutable borrow") + | VReservedMutBorrow _ -> raise (Failure "Can't copy a reserved mut borrow")) - | V.Loan lc -> ( + | VLoan lc -> ( (* We can only copy shared loans *) match lc with - | V.MutLoan _ -> raise (Failure "Can't copy a mutable loan") - | V.SharedLoan (_, sv) -> + | VMutLoan _ -> raise (Failure "Can't copy a mutable loan") + | VSharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) copy_value allow_adt_copy config ctx sv) - | V.Symbolic sp -> + | VSymbolic sp -> (* We can copy only if the type is "primitively" copyable. * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - assert (ty_is_primitively_copyable (Subst.erase_regions sp.V.sv_ty)); + assert (ty_is_primitively_copyable (Subst.erase_regions sp.sv_ty)); (* If the type is copyable, we simply return the current value. Side * remark: what is important to look at when copying symbolic values * is symbolic expansion. The important subcase is the expansion of shared @@ -239,16 +239,16 @@ let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : let prepare : cm_fun = fun cf ctx -> match op with - | E.Constant _ -> + | Constant _ -> (* No need to reorganize the context *) cf ctx - | E.Copy p -> + | 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 - | E.Move p -> + | Move p -> (* Access the value *) let access = Move in let expand_prim_copy = false in @@ -268,11 +268,11 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Evaluate *) match op with - | E.Constant cv -> ( + | Constant cv -> ( match cv.value with - | E.CLiteral lit -> + | CLiteral lit -> cf (literal_to_typed_value (TypesUtils.ty_as_literal cv.ty) lit) ctx - | E.CTraitConst (trait_ref, generics, const_name) -> ( + | CTraitConst (trait_ref, generics, const_name) -> ( assert (generics = TypesUtils.mk_empty_generic_args); match trait_ref.trait_id with | T.TraitImpl _ -> @@ -307,7 +307,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) SymbolicAst.VaTraitConstValue (trait_ref, generics, const_name), e )))) - | E.CVar vid -> ( + | CVar vid -> ( let ctx0 = ctx in (* Lookup the const generic value *) let cv = C.ctx_lookup_const_generic_value ctx vid in @@ -331,8 +331,8 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) value_as_symbolic v.value, SymbolicAst.VaCGValue vid, e ))) - | E.CFnPtr _ -> raise (Failure "TODO")) - | E.Copy p -> + | CFnPtr _ -> raise (Failure "TODO")) + | Copy p -> (* Access the value *) let access = Read in let cc = read_place access p in @@ -353,7 +353,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) in (* Compose and apply *) comp cc copy cf ctx - | E.Move p -> + | Move p -> (* Access the value *) let access = Move in let cc = read_place access p in @@ -362,7 +362,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) fun ctx -> (* Check that there are no bottoms in the value we are about to move *) assert (not (bottom_in_value ctx.ended_regions v)); - let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in + let bottom : V.typed_value = { V.value = VBottom; ty = v.ty } in let ctx = write_place access p bottom ctx in cf v ctx in @@ -622,18 +622,18 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) (cf : V.typed_value -> m_fun) : m_fun = fun ctx -> match bkind with - | E.Shared | E.TwoPhaseMut | E.Shallow -> + | Shared | TwoPhaseMut | Shallow -> (* **REMARK**: we initially treated shallow borrows like shared borrows. In practice this restricted the behaviour too much, so for now we forbid them. *) - assert (bkind <> E.Shallow); + assert (bkind <> Shallow); (* Access the value *) let access = match bkind with - | E.Shared | E.Shallow -> Read - | E.TwoPhaseMut -> Write + | Shared | Shallow -> Read + | TwoPhaseMut -> Write | _ -> raise (Failure "Unreachable") in @@ -648,17 +648,17 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) let bid = C.fresh_borrow_id () in (* Compute the loan value, with which to replace the value at place p *) let nv = - match v.V.value with - | V.Loan (V.SharedLoan (bids, sv)) -> + match v.value with + | VLoan (VSharedLoan (bids, sv)) -> (* Shared loan: insert the new borrow id *) let bids1 = V.BorrowId.Set.add bid bids in - { v with V.value = V.Loan (V.SharedLoan (bids1, sv)) } + { v with value = VLoan (VSharedLoan (bids1, sv)) } | _ -> (* Not a shared loan: add a wrapper *) let v' = - V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) + V.VLoan (VSharedLoan (V.BorrowId.Set.singleton bid, v)) in - { v with V.value = v' } + { v with value = v' } in (* Update the borrowed value in the context *) let ctx = write_place access p nv ctx in @@ -666,27 +666,27 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) * Note that the reference is *mutable* if we do a two-phase borrow *) let ref_kind = match bkind with - | E.Shared | E.Shallow -> T.Shared - | E.TwoPhaseMut -> T.Mut + | Shared | Shallow -> T.Shared + | TwoPhaseMut -> T.Mut | _ -> raise (Failure "Unreachable") in let rv_ty = T.TRef (T.RErased, v.ty, ref_kind) in let bc = match bkind with - | E.Shared | E.Shallow -> + | Shared | Shallow -> (* See the remark at the beginning of the match branch: we handle shallow borrows like shared borrows *) - V.SharedBorrow bid - | E.TwoPhaseMut -> V.ReservedMutBorrow bid + V.VSharedBorrow bid + | TwoPhaseMut -> VReservedMutBorrow bid | _ -> raise (Failure "Unreachable") in - let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in + let rv : V.typed_value = { value = VBorrow bc; ty = rv_ty } in (* Continue *) cf rv ctx in (* Compose and apply *) comp prepare eval cf ctx - | E.Mut -> + | Mut -> (* Access the value *) let access = Write in let expand_prim_copy = false in @@ -698,12 +698,12 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) fun ctx -> (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) let bid = C.fresh_borrow_id () in - let rv_ty = T.TRef (T.RErased, v.ty, Mut) in + let rv_ty = T.TRef (RErased, v.ty, Mut) in let rv : V.typed_value = - { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } + { V.value = VBorrow (VMutBorrow (bid, v)); ty = rv_ty } in (* Compute the value with which to replace the value at place p *) - let nv = { v with V.value = V.Loan (V.MutLoan bid) } in + let nv = { v with value = VLoan (VMutLoan bid) } in (* Update the value in the context *) let ctx = write_place access p nv ctx in (* Continue *) @@ -723,7 +723,7 @@ let eval_rvalue_aggregate (config : C.config) fun ctx -> (* Match on the aggregate kind *) match aggregate_kind with - | E.AggregatedAdt (type_id, opt_variant_id, generics) -> ( + | AggregatedAdt (type_id, opt_variant_id, generics) -> ( match type_id with | TTuple -> let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in @@ -755,7 +755,7 @@ let eval_rvalue_aggregate (config : C.config) (* Call the continuation *) cf aggregated ctx | TAssumed _ -> raise (Failure "Unreachable")) - | E.AggregatedArray (ety, cg) -> ( + | 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); (* Sanity check: the number of values is consistent with the length *) diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 2f7e8f3d..a35b2716 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -227,17 +227,17 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = object inherit [_] V.iter_typed_avalue as super - method! visit_SharedLoan env lids sv = + method! visit_VSharedLoan env lids sv = collect_shared_value lids sv; (* Continue the exploration *) - super#visit_SharedLoan env lids sv + super#visit_VSharedLoan env lids sv - method! visit_ASharedLoan env lids sv _ = + method! visit_ASharedLoan env lids sv av = collect_shared_value lids sv; (* Continue the exploration *) - super#visit_SharedLoan env lids sv + super#visit_ASharedLoan env lids sv av (** Check that there are no symbolic values with *borrows* inside the abstraction - shouldn't happen if the symbolic values are greedily @@ -743,8 +743,8 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) let open InterpreterBorrowsCore in let lookup_shared_loan lid ctx : V.typed_value = match snd (lookup_loan ek_all lid ctx) with - | Concrete (V.SharedLoan (_, v)) -> v - | Abstract (V.ASharedLoan (_, v, _)) -> v + | Concrete (VSharedLoan (_, v)) -> v + | Abstract (ASharedLoan (_, v, _)) -> v | _ -> raise (Failure "Unreachable") in let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in @@ -927,12 +927,12 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : inherit [_] C.iter_env (** We lookup the shared values *) - method! visit_SharedBorrow env bid = + method! visit_VSharedBorrow env bid = let open InterpreterBorrowsCore in let v = match snd (lookup_loan ek_all bid fp_ctx) with - | Concrete (V.SharedLoan (_, v)) -> v - | Abstract (V.ASharedLoan (_, v, _)) -> v + | Concrete (VSharedLoan (_, v)) -> v + | Abstract (ASharedLoan (_, v, _)) -> v | _ -> raise (Failure "Unreachable") in self#visit_typed_value env v diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 27020efb..7741abbc 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -212,66 +212,66 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct assert (not (value_has_borrows ctx v1.V.value)); (* Merge *) M.match_distinct_adts ty av0 av1) - | Bottom, Bottom -> v0 - | Borrow bc0, Borrow bc1 -> + | VBottom, VBottom -> v0 + | VBorrow bc0, VBorrow bc1 -> let bc = match (bc0, bc1) with - | SharedBorrow bid0, SharedBorrow bid1 -> + | VSharedBorrow bid0, VSharedBorrow bid1 -> let bid = M.match_shared_borrows match_rec ty bid0 bid1 in - V.SharedBorrow bid - | MutBorrow (bid0, bv0), MutBorrow (bid1, bv1) -> + V.VSharedBorrow bid + | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in assert (not (value_has_borrows ctx bv.V.value)); let bid, bv = M.match_mut_borrows ty bid0 bv0 bid1 bv1 bv in - V.MutBorrow (bid, bv) - | ReservedMutBorrow _, _ - | _, ReservedMutBorrow _ - | SharedBorrow _, MutBorrow _ - | MutBorrow _, SharedBorrow _ -> + VMutBorrow (bid, bv) + | VReservedMutBorrow _, _ + | _, VReservedMutBorrow _ + | VSharedBorrow _, VMutBorrow _ + | VMutBorrow _, VSharedBorrow _ -> (* If we get here, either there is a typing inconsistency, or we are trying to match a reserved borrow, which shouldn't happen because reserved borrow should be eliminated very quickly - they are introduced just before function calls which activate them *) raise (Failure "Unexpected") in - { V.value = V.Borrow bc; ty } - | Loan lc0, Loan lc1 -> + { V.value = VBorrow bc; ty } + | VLoan lc0, VLoan lc1 -> (* TODO: maybe we should enforce that the ids are always exactly the same - without matching *) let lc = match (lc0, lc1) with - | SharedLoan (ids0, sv0), SharedLoan (ids1, sv1) -> + | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in assert (not (value_has_borrows ctx sv.V.value)); let ids, sv = M.match_shared_loans ty ids0 ids1 sv in - V.SharedLoan (ids, sv) - | MutLoan id0, MutLoan id1 -> + V.VSharedLoan (ids, sv) + | VMutLoan id0, VMutLoan id1 -> let id = M.match_mut_loans ty id0 id1 in - V.MutLoan id - | SharedLoan _, MutLoan _ | MutLoan _, SharedLoan _ -> + VMutLoan id + | VSharedLoan _, VMutLoan _ | VMutLoan _, VSharedLoan _ -> raise (Failure "Unreachable") in - { V.value = Loan lc; ty = v1.V.ty } - | Symbolic sv0, Symbolic sv1 -> + { V.value = VLoan lc; ty = v1.V.ty } + | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) assert (not (value_has_borrows ctx v0.V.value)); assert (not (value_has_borrows ctx v1.V.value)); (* Match *) let sv = M.match_symbolic_values sv0 sv1 in - { v1 with V.value = V.Symbolic sv } - | Loan lc, _ -> ( + { v1 with V.value = VSymbolic sv } + | VLoan lc, _ -> ( match lc with - | SharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInLeft ids)) - | MutLoan id -> raise (ValueMatchFailure (LoanInLeft id))) - | _, Loan lc -> ( + | VSharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInLeft ids)) + | VMutLoan id -> raise (ValueMatchFailure (LoanInLeft id))) + | _, VLoan lc -> ( match lc with - | SharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInRight ids)) - | MutLoan id -> raise (ValueMatchFailure (LoanInRight id))) - | Symbolic sv, _ -> M.match_symbolic_with_other true sv v1 - | _, Symbolic sv -> M.match_symbolic_with_other false sv v0 - | Bottom, _ -> M.match_bottom_with_other true v1 - | _, Bottom -> M.match_bottom_with_other false v0 + | VSharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInRight ids)) + | VMutLoan id -> raise (ValueMatchFailure (LoanInRight id))) + | VSymbolic sv, _ -> M.match_symbolic_with_other true sv v1 + | _, VSymbolic sv -> M.match_symbolic_with_other false sv v0 + | VBottom, _ -> M.match_bottom_with_other true v1 + | _, VBottom -> M.match_bottom_with_other false v0 | _ -> log#ldebug (lazy @@ -414,10 +414,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Check if there are loans: we request to end them *) let check_loans (left : bool) (fields : V.typed_value list) : unit = match InterpreterBorrowsCore.get_first_loan_in_values fields with - | Some (V.SharedLoan (ids, _)) -> + | Some (VSharedLoan (ids, _)) -> if left then raise (ValueMatchFailure (LoansInLeft ids)) else raise (ValueMatchFailure (LoansInRight ids)) - | Some (V.MutLoan id) -> + | Some (VMutLoan id) -> if left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id)) | None -> () @@ -688,10 +688,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let value_is_left = not left in (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () - | Some (SharedLoan (ids, _)) -> + | Some (VSharedLoan (ids, _)) -> if value_is_left then raise (ValueMatchFailure (LoansInLeft ids)) else raise (ValueMatchFailure (LoansInRight ids)) - | Some (MutLoan id) -> + | Some (VMutLoan id) -> if value_is_left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id))); (* Return a fresh symbolic value *) @@ -711,10 +711,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct | Some (BorrowContent _) -> raise (Failure "Unreachable") | Some (LoanContent lc) -> ( match lc with - | V.SharedLoan (ids, _) -> + | VSharedLoan (ids, _) -> if value_is_left then raise (ValueMatchFailure (LoansInLeft ids)) else raise (ValueMatchFailure (LoansInRight ids)) - | V.MutLoan id -> + | VMutLoan id -> if value_is_left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id))) | None -> @@ -1366,8 +1366,8 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) let open InterpreterBorrowsCore in let lookup_shared_loan lid ctx : V.typed_value = match snd (lookup_loan ek_all lid ctx) with - | Concrete (V.SharedLoan (_, v)) -> v - | Abstract (V.ASharedLoan (_, v, _)) -> v + | Concrete (VSharedLoan (_, v)) -> v + | Abstract (ASharedLoan (_, v, _)) -> v | _ -> raise (Failure "Unreachable") in let lookup_in_src id = lookup_shared_loan id src_ctx in diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 36af1db4..9158f2c1 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -95,13 +95,13 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) Ok (ctx, { read = v; updated = nv }) | pe :: p' -> ( (* Match on the projection element and the value *) - match (pe, v.V.value, v.V.ty) with + match (pe, v.value, v.ty) with | ( Field ((ProjAdt (_, _) as proj_kind), field_id), - V.VAdt adt, - T.TAdt (type_id, _) ) -> ( + VAdt adt, + TAdt (type_id, _) ) -> ( (* Check consistency *) (match (proj_kind, type_id) with - | ProjAdt (def_id, opt_variant_id), T.TAdtId def_id' -> + | ProjAdt (def_id, opt_variant_id), TAdtId def_id' -> assert (def_id = def_id'); assert (opt_variant_id = adt.variant_id) | _ -> raise (Failure "Unreachable")); @@ -114,11 +114,11 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) let nvalues = T.FieldId.update_nth adt.field_values field_id res.updated in - let nadt = V.VAdt { adt with V.field_values = nvalues } in + let nadt = V.VAdt { adt with field_values = nvalues } in let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) - | Field (ProjTuple arity, field_id), V.VAdt adt, T.TAdt (T.TTuple, _) -> ( + | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( assert (arity = List.length adt.field_values); let fv = T.FieldId.nth adt.field_values field_id in (* Project *) @@ -134,16 +134,16 @@ 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 _), _), V.Bottom, _ -> + | Field ((ProjAdt (_, _) | ProjTuple _), _), VBottom, _ -> Error (FailBottom (1 + List.length p', pe, v.ty)) (* Symbolic value: needs to be expanded *) - | _, Symbolic sp, _ -> + | _, VSymbolic sp, _ -> (* Expand the symbolic value *) Error (FailSymbolic (1 + List.length p', sp)) (* Box dereferencement *) | ( DerefBox, VAdt { variant_id = None; field_values = [ bv ] }, - T.TAdt (T.TAssumed T.TBox, _) ) -> ( + TAdt (TAssumed TBox, _) ) -> ( (* We allow moving outside of boxes. In practice, this kind of * manipulations should happen only inside unsafe code, so * it shouldn't happen due to user code, and we leverage it @@ -156,20 +156,20 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) { v with value = - V.VAdt { variant_id = None; field_values = [ res.updated ] }; + VAdt { variant_id = None; field_values = [ res.updated ] }; } in Ok (ctx, { res with updated = nv })) (* Borrows *) - | Deref, V.Borrow bc, _ -> ( + | Deref, VBorrow bc, _ -> ( match bc with - | V.SharedBorrow bid -> + | VSharedBorrow bid -> (* Lookup the loan content, and explore from there *) if access.lookup_shared_borrows then match lookup_loan ek bid ctx with - | _, Concrete (V.MutLoan _) -> + | _, Concrete (VMutLoan _) -> raise (Failure "Expected a shared loan") - | _, Concrete (V.SharedLoan (bids, sv)) -> ( + | _, Concrete (VSharedLoan (bids, sv)) -> ( (* Explore the shared value *) match access_projection access ctx update p' sv with | Error err -> Error err @@ -178,23 +178,23 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) by {!access_projection} *) let ctx = update_loan ek bid - (V.SharedLoan (bids, res.updated)) + (VSharedLoan (bids, res.updated)) ctx in (* Return - note that we don't need to update the borrow itself *) Ok (ctx, { res with updated = v })) | ( _, Abstract - ( V.AMutLoan (_, _) - | V.AEndedMutLoan + ( AMutLoan (_, _) + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan + | AEndedSharedLoan (_, _) + | AIgnoredMutLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ ) ) -> + | AIgnoredSharedLoan _ ) ) -> raise (Failure "Expected a shared (abstraction) loan") - | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( + | _, Abstract (ASharedLoan (bids, sv, _av)) -> ( (* Explore the shared value *) match access_projection access ctx update p' sv with | Error err -> Error err @@ -202,37 +202,34 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) (* Relookup the child avalue *) let av = match lookup_loan ek bid ctx with - | _, Abstract (V.ASharedLoan (_, _, av)) -> av + | _, Abstract (ASharedLoan (_, _, av)) -> av | _ -> raise (Failure "Unexpected") in (* Update the shared loan with the new value returned by {!access_projection} *) let ctx = update_aloan ek bid - (V.ASharedLoan (bids, res.updated, av)) + (ASharedLoan (bids, res.updated, av)) ctx in (* Return - note that we don't need to update the borrow itself *) Ok (ctx, { res with updated = v })) else Error (FailBorrow bc) - | V.ReservedMutBorrow bid -> Error (FailReservedMutBorrow bid) - | V.MutBorrow (bid, bv) -> + | VReservedMutBorrow bid -> Error (FailReservedMutBorrow bid) + | VMutBorrow (bid, bv) -> if access.enter_mut_borrows then match access_projection access ctx update p' bv with | Error err -> Error err | Ok (ctx, res) -> let nv = - { - v with - value = V.Borrow (V.MutBorrow (bid, res.updated)); - } + { v with value = VBorrow (VMutBorrow (bid, res.updated)) } in Ok (ctx, { res with updated = nv }) else Error (FailBorrow bc)) - | _, V.Loan lc, _ -> ( + | _, VLoan lc, _ -> ( match lc with - | V.MutLoan bid -> Error (FailMutLoan bid) - | V.SharedLoan (bids, sv) -> + | VMutLoan bid -> Error (FailMutLoan bid) + | VSharedLoan (bids, sv) -> (* If we can enter shared loan, we ignore the loan. Pay attention to the fact that we need to reexplore the *whole* place (i.e, we mustn't ignore the current projection element *) @@ -241,14 +238,11 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) | Error err -> Error err | Ok (ctx, res) -> let nv = - { - v with - value = V.Loan (V.SharedLoan (bids, res.updated)); - } + { v with value = VLoan (VSharedLoan (bids, res.updated)) } in Ok (ctx, { res with updated = nv }) else Error (FailSharedLoan bids)) - | (_, (V.VLiteral _ | V.VAdt _ | V.Bottom | V.Borrow _), _) as r -> + | (_, (VLiteral _ | VAdt _ | VBottom | VBorrow _), _) as r -> let pe, v, ty = r in let pe = "- pe: " ^ E.show_projection_elem pe in let v = "- v:\n" ^ V.show_value v in @@ -531,24 +525,24 @@ let rec end_loans_at_place (config : C.config) (access : access_kind) method! visit_borrow_content env bc = match bc with - | V.SharedBorrow _ | V.MutBorrow (_, _) -> + | VSharedBorrow _ | VMutBorrow (_, _) -> (* Nothing special to do *) super#visit_borrow_content env bc - | V.ReservedMutBorrow bid -> + | VReservedMutBorrow bid -> (* We need to activate reserved borrows *) let cc = promote_reserved_mut_borrow config bid in raise (UpdateCtx cc) method! visit_loan_content env lc = match lc with - | V.SharedLoan (bids, v) -> ( + | VSharedLoan (bids, v) -> ( (* End the loans if we need a modification access, otherwise dive into the shared value *) match access with - | Read -> super#visit_SharedLoan env bids v + | Read -> super#visit_VSharedLoan env bids v | Write | Move -> let cc = end_borrows config bids in raise (UpdateCtx cc)) - | V.MutLoan bid -> + | VMutLoan bid -> (* We always need to end mutable borrows *) let cc = end_borrow config bid in raise (UpdateCtx cc) @@ -596,8 +590,8 @@ let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = (* There are: end them then retry *) let cc = match c with - | LoanContent (V.SharedLoan (bids, _)) -> end_borrows config bids - | LoanContent (V.MutLoan bid) -> end_borrow config bid + | LoanContent (VSharedLoan (bids, _)) -> end_borrows config bids + | LoanContent (VMutLoan bid) -> end_borrow config bid | BorrowContent _ -> raise (Failure "Unreachable") in (* Retry *) diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index e47886ec..8a4b0b4c 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -20,20 +20,20 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in - assert (ty_is_rty ty && ety = v.V.ty); + assert (ty_is_rty ty && ety = v.ty); (* Project - if there are no regions from the abstraction in the type, return [_] *) if not (ty_has_regions_in_set regions ty) then [] else - match (v.V.value, ty) with - | V.VLiteral _, T.TLiteral _ -> [] - | V.VAdt adt, T.TAdt (id, generics) -> + match (v.value, ty) with + | VLiteral _, TLiteral _ -> [] + | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics in (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in + let fields_types = List.combine adt.field_values field_types in let proj_fields = List.map (fun (fv, fty) -> @@ -42,33 +42,33 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) fields_types in List.concat proj_fields - | V.Bottom, _ -> raise (Failure "Unreachable") - | V.Borrow bc, TRef (r, ref_ty, kind) -> + | VBottom, _ -> raise (Failure "Unreachable") + | VBorrow bc, TRef (r, ref_ty, kind) -> (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) let bid, asb = (* Not in the set: dive *) match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), Mut -> (* Apply the projection on the borrowed value *) let asb = apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions bv ref_ty in (bid, asb) - | V.SharedBorrow bid, T.Shared -> + | VSharedBorrow bid, Shared -> (* Lookup the shared value *) let ek = ek_all in let sv = lookup_loan ek bid ctx in let asb = match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> + | _, Concrete (VSharedLoan (_, sv)) + | _, Abstract (ASharedLoan (_, sv, _)) -> apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions sv ref_ty | _ -> raise (Failure "Unexpected") in (bid, asb) - | V.ReservedMutBorrow _, _ -> + | VReservedMutBorrow _, _ -> raise (Failure "Can't apply a proj_borrow over a reserved mutable borrow") @@ -83,8 +83,8 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) else asb in asb - | V.Loan _, _ -> raise (Failure "Unreachable") - | V.Symbolic s, _ -> + | VLoan _, _ -> raise (Failure "Unreachable") + | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) assert ( not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); @@ -103,15 +103,15 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } else let value : V.avalue = - match (v.V.value, ty) with - | V.VLiteral _, T.TLiteral _ -> V.AIgnored - | V.VAdt adt, T.TAdt (id, generics) -> + match (v.value, ty) with + | VLiteral _, T.TLiteral _ -> V.AIgnored + | VAdt adt, T.TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics in (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in + let fields_types = List.combine adt.field_values field_types in let proj_fields = List.map (fun (fv, fty) -> @@ -119,9 +119,9 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) regions ancestors_regions fv fty) fields_types in - V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } - | V.Bottom, _ -> raise (Failure "Unreachable") - | V.Borrow bc, TRef (r, ref_ty, kind) -> + V.AAdt { variant_id = adt.variant_id; field_values = proj_fields } + | VBottom, _ -> raise (Failure "Unreachable") + | VBorrow bc, TRef (r, ref_ty, kind) -> if (* Check if the region is in the set of projected regions (note that * we never project over static regions) *) @@ -130,14 +130,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (* In the set *) let bc = match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), T.Mut -> (* Apply the projection on the borrowed value *) let bv = apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions bv ref_ty in V.AMutBorrow (bid, bv) - | V.SharedBorrow bid, T.Shared -> + | VSharedBorrow bid, T.Shared -> (* Rem.: we don't need to also apply the projection on the borrowed value, because for as long as the abstraction lives then the shared borrow lives, which means that the @@ -150,7 +150,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) other branch of the [if then else]). *) V.ASharedBorrow bid - | V.ReservedMutBorrow _, _ -> + | VReservedMutBorrow _, _ -> raise (Failure "Can't apply a proj_borrow over a reserved mutable \ @@ -164,7 +164,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) the region set) *) let bc = match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), T.Mut -> (* Apply the projection on the borrowed value *) let bv = apply_proj_borrows check_symbolic_no_ended ctx @@ -177,20 +177,20 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) in (* Return *) V.AIgnoredMutBorrow (opt_bid, bv) - | V.SharedBorrow bid, T.Shared -> + | VSharedBorrow bid, T.Shared -> (* Lookup the shared value *) let ek = ek_all in let sv = lookup_loan ek bid ctx in let asb = match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> + | _, Concrete (VSharedLoan (_, sv)) + | _, Abstract (ASharedLoan (_, sv, _)) -> apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions sv ref_ty | _ -> raise (Failure "Unexpected") in V.AProjSharedBorrow asb - | V.ReservedMutBorrow _, _ -> + | VReservedMutBorrow _, _ -> raise (Failure "Can't apply a proj_borrow over a reserved mutable \ @@ -198,12 +198,12 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) | _ -> raise (Failure "Unreachable") in V.ABorrow bc - | V.Loan _, _ -> raise (Failure "Unreachable") - | V.Symbolic s, _ -> + | VLoan _, _ -> raise (Failure "Unreachable") + | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, * if necessary *) if check_symbolic_no_ended then ( - let ty1 = s.V.sv_ty in + let ty1 = s.sv_ty in let rset1 = ctx.ended_regions in let ty2 = ty in let rset2 = regions in @@ -216,7 +216,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) ^ T.RegionId.Set.to_string None rset2 ^ "\n")); assert (not (projections_intersect ty1 rset1 ty2 rset2))); - V.ASymbolic (V.AProjBorrows (s, ty)) + V.ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror (lazy @@ -225,7 +225,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) ^ "\n- proj rty: " ^ PA.ty_to_string ctx ty)); raise (Failure "Unreachable") in - { V.value; V.ty } + { value; ty } let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) (see : V.symbolic_expansion) : V.typed_value = @@ -249,7 +249,7 @@ let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) | SeMutRef (bid, bv) -> let ty = Subst.erase_regions sv.V.sv_ty in let bv = mk_typed_value_from_symbolic_value bv in - let value = V.Borrow (V.MutBorrow (bid, bv)) in + let value = V.VBorrow (VMutBorrow (bid, bv)) in { V.value; ty } | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic shared reference expansion") @@ -346,11 +346,11 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* Check if a value is a mutable borrow, and return its identifier if it is the case *) let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = - match v.V.value with - | V.Borrow lc -> ( + match v.value with + | VBorrow lc -> ( match lc with - | V.SharedBorrow _ | V.ReservedMutBorrow _ -> None - | V.MutBorrow (id, _) -> Some id) + | VSharedBorrow _ | VReservedMutBorrow _ -> None + | VMutBorrow (id, _) -> Some id) | _ -> None in @@ -397,18 +397,18 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (** We may need to reborrow mutable borrows. Note that this doesn't happen for aborrows *) method! visit_typed_value env v = - match v.V.value with - | V.Borrow (V.MutBorrow (bid, bv)) -> + match v.value with + | VBorrow (VMutBorrow (bid, bv)) -> let insert = get_reborrows_for_bid bid in - let nbc = super#visit_MutBorrow env bid bv in - let nbc = { v with V.value = V.Borrow nbc } in + let nbc = super#visit_VMutBorrow env bid bv in + let nbc = { v with value = VBorrow nbc } in if insert = [] then (* No reborrows: do nothing special *) nbc else (* There are reborrows: insert a shared loan *) let insert = borrows_to_set insert in - let value = V.Loan (V.SharedLoan (insert, nbc)) in - let ty = v.V.ty in + let value = V.VLoan (VSharedLoan (insert, nbc)) in + let ty = v.ty in { V.value; ty } | _ -> super#visit_typed_value env v @@ -416,7 +416,7 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) functions) on purpose: exhaustive matches are good for maintenance *) method! visit_loan_content env lc = match lc with - | V.SharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> (* Insert the reborrows *) let bids = insert_reborrows bids in (* Check if the contained value is a mutable borrow, in which @@ -432,14 +432,14 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) | Some bid -> insert_reborrows_for_bid bids bid in (* Update and explore *) - super#visit_SharedLoan env bids sv - | V.MutLoan bid -> + super#visit_VSharedLoan env bids sv + | VMutLoan bid -> (* Nothing special to do *) - super#visit_MutLoan env bid + super#visit_VMutLoan env bid method! visit_aloan_content env lc = match lc with - | V.ASharedLoan (bids, sv, av) -> + | ASharedLoan (bids, sv, av) -> (* Insert the reborrows *) let bids = insert_reborrows bids in (* Similarly to the non-abstraction case: check if the shared @@ -452,12 +452,12 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) in (* Update and explore *) super#visit_ASharedLoan env bids sv av - | V.AIgnoredSharedLoan _ - | V.AMutLoan (_, _) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan + | AIgnoredSharedLoan _ + | AMutLoan (_, _) + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) + | AIgnoredMutLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } -> (* Nothing particular to do *) super#visit_aloan_content env lc diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index cf9b840b..cbc09c29 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -43,7 +43,7 @@ let drop_value (config : C.config) (p : E.place) : cm_fun = let dummy_id = C.fresh_dummy_var_id () in let ctx = C.ctx_push_dummy_var ctx dummy_id mv in (* Update the destination to ⊥ *) - let nv = { v with value = V.Bottom } in + let nv = { v with value = VBottom } in let ctx = write_place access p nv ctx in log#ldebug (lazy @@ -172,7 +172,7 @@ let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = (* Evaluate the assertion *) let eval_assert cf (v : V.typed_value) : m_fun = fun ctx -> - assert (v.ty = T.TLiteral PV.TBool); + assert (v.ty = TLiteral TBool); (* We make a choice here: we could completely decouple the concrete and * symbolic executions here but choose not to. In the case where we * know the concrete value of the boolean we test, we use this value @@ -182,16 +182,16 @@ let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = | VLiteral (VBool _) -> (* Delegate to the concrete evaluation function *) eval_assertion_concrete config assertion cf ctx - | Symbolic sv -> - assert (config.mode = C.SymbolicMode); - assert (sv.V.sv_ty = T.TLiteral PV.TBool); + | VSymbolic sv -> + assert (config.mode = SymbolicMode); + assert (sv.sv_ty = TLiteral TBool); (* We continue the execution as if the test had succeeded, and thus * perform the symbolic expansion: sv ~~> true. * We will of course synthesize an assertion in the generated code * (see below). *) let ctx = - apply_symbolic_expansion_non_borrow config sv - (V.SeLiteral (PV.VBool true)) ctx + apply_symbolic_expansion_non_borrow config sv (SeLiteral (VBool true)) + ctx in (* Continue *) let expr = cf Unit ctx in @@ -231,8 +231,8 @@ let set_discriminant (config : C.config) (p : E.place) (* Update the value *) let update_value cf (v : V.typed_value) : m_fun = fun ctx -> - match (v.V.ty, v.V.value) with - | T.TAdt ((T.TAdtId _ as type_id), generics), V.VAdt av -> ( + match (v.ty, v.value) with + | TAdt ((TAdtId _ as type_id), generics), VAdt av -> ( (* There are two situations: - either the discriminant is already the proper one (in which case we don't do anything) @@ -248,22 +248,22 @@ let set_discriminant (config : C.config) (p : E.place) (* Replace the value *) let bottom_v = match type_id with - | T.TAdtId def_id -> + | TAdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx) - | T.TAdt ((T.TAdtId _ as type_id), generics), V.Bottom -> + | TAdt ((TAdtId _ as type_id), generics), VBottom -> let bottom_v = match type_id with - | T.TAdtId def_id -> + | TAdtId def_id -> compute_expanded_bottom_adt_value ctx def_id (Some variant_id) generics | _ -> raise (Failure "Unreachable") in assign_to_place config bottom_v p (cf Unit) ctx - | _, V.Symbolic _ -> + | _, VSymbolic _ -> assert (config.mode = SymbolicMode); (* This is a bit annoying: in theory we should expand the symbolic value * then set the discriminant, because in the case the discriminant is @@ -273,8 +273,8 @@ let set_discriminant (config : C.config) (p : E.place) * setting a discriminant should only be used to initialize a value, * or reset an already initialized value, really. *) raise (Failure "Unexpected value") - | _, (V.VAdt _ | V.Bottom) -> raise (Failure "Inconsistent state") - | _, (V.VLiteral _ | V.Borrow _ | V.Loan _) -> + | _, (VAdt _ | VBottom) -> raise (Failure "Inconsistent state") + | _, (VLiteral _ | VBorrow _ | VLoan _) -> raise (Failure "Unexpected value") in (* Compose and apply *) @@ -817,7 +817,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = in (* Compose the continuations *) cf_branch cf ctx - | V.Symbolic sv -> + | VSymbolic sv -> (* Expand the symbolic boolean, and continue by evaluating * the branches *) let cf_true : st_cm_fun = eval_statement config st1 in @@ -848,7 +848,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = in (* Compose *) cf_eval_branch cf ctx - | V.Symbolic sv -> + | VSymbolic sv -> (* Expand the symbolic value and continue by evaluating the * proper branches *) let stgts = @@ -891,14 +891,14 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let p_v = value_strip_shared_loans p_v in (* Match *) match p_v.value with - | V.VAdt adt -> ( + | VAdt adt -> ( (* Evaluate the discriminant *) let dv = Option.get adt.variant_id in (* Find the branch, evaluate and continue *) match List.find_opt (fun (svl, _) -> List.mem dv svl) stgts with | None -> eval_statement config otherwise cf ctx | Some (_, tgt) -> eval_statement config tgt cf ctx) - | V.Symbolic sv -> + | VSymbolic sv -> (* Expand the symbolic value - may lead to branching *) let cf_expand = expand_symbolic_adt config sv (Some (S.mk_mplace p ctx)) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 6f62b577..60747b2a 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -90,7 +90,7 @@ let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.ty) : let ty = Subst.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value sv_kind rty in - let value = V.Symbolic value in + let value = V.VSymbolic value in { V.value; V.ty } let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : V.sv_kind) @@ -101,7 +101,7 @@ let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : V.sv_kind) (** Create a typed value from a symbolic value. *) let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : V.typed_value = - let av = V.Symbolic svalue in + let av = V.VSymbolic svalue in let av : V.typed_value = { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } in @@ -204,7 +204,7 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : object inherit [_] C.iter_eval_ctx as super - method! visit_Symbolic _ sv = + method! visit_VSymbolic _ sv = if sv.V.sv_id = sv_id then raise Found else () method! visit_aproj env aproj = @@ -251,7 +251,7 @@ let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : let obj = object inherit [_] V.iter_typed_value - method! visit_Bottom _ = raise Found + method! visit_VBottom _ = raise Found method! visit_symbolic_value _ s = if symbolic_value_has_ended_regions ended_regions s then raise Found diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 8895bd8e..7830099f 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -150,8 +150,8 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = (* Register the loan *) let _ = match lc with - | V.SharedLoan (bids, _) -> register_shared_loan inside_abs bids - | V.MutLoan bid -> register_mut_loan inside_abs bid + | VSharedLoan (bids, _) -> register_shared_loan inside_abs bids + | VMutLoan bid -> register_mut_loan inside_abs bid in (* Continue exploring *) super#visit_loan_content inside_abs lc @@ -159,14 +159,14 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = method! visit_aloan_content inside_abs lc = let _ = match lc with - | V.AMutLoan (bid, _) -> register_mut_loan inside_abs bid - | V.ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids - | V.AIgnoredMutLoan (Some bid, _) -> register_ignored_loan T.Mut bid - | V.AIgnoredMutLoan (None, _) - | V.AIgnoredSharedLoan _ - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AEndedIgnoredMutLoan + | AMutLoan (bid, _) -> register_mut_loan inside_abs bid + | ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids + | AIgnoredMutLoan (Some bid, _) -> register_ignored_loan T.Mut bid + | AIgnoredMutLoan (None, _) + | AIgnoredSharedLoan _ + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } -> (* Do nothing *) () @@ -244,9 +244,9 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = (* Register the loan *) let _ = match bc with - | V.SharedBorrow bid -> register_borrow Shared bid - | V.MutBorrow (bid, _) -> register_borrow Mut bid - | V.ReservedMutBorrow bid -> register_borrow Reserved bid + | VSharedBorrow bid -> register_borrow Shared bid + | VMutBorrow (bid, _) -> register_borrow Mut bid + | VReservedMutBorrow bid -> register_borrow Reserved bid in (* Continue exploring *) super#visit_borrow_content env bc @@ -254,12 +254,12 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = method! visit_aborrow_content env bc = let _ = match bc with - | V.AMutBorrow (bid, _) -> register_borrow Mut bid - | V.ASharedBorrow bid -> register_borrow Shared bid - | V.AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid - | V.AIgnoredMutBorrow (None, _) - | V.AEndedMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedSharedBorrow | V.AProjSharedBorrow _ -> + | AMutBorrow (bid, _) -> register_borrow Mut bid + | ASharedBorrow bid -> register_borrow Shared bid + | AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid + | AIgnoredMutBorrow (None, _) + | AEndedMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow + | AProjSharedBorrow _ -> (* Do nothing *) () in @@ -305,7 +305,7 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = object inherit [_] C.iter_eval_ctx as super - method! visit_Bottom info = + method! visit_VBottom info = (* No ⊥ inside borrowed values *) assert (Config.allow_bottom_below_borrow || not info.outer_borrow) @@ -317,8 +317,8 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = (* Update the info *) let info = match lc with - | V.SharedLoan (_, _) -> set_outer_shared info - | V.MutLoan _ -> + | VSharedLoan (_, _) -> set_outer_shared info + | VMutLoan _ -> (* No mutable loan inside a shared loan *) assert (not info.outer_shared); set_outer_mut info @@ -330,11 +330,11 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = (* Update the info *) let info = match bc with - | V.SharedBorrow _ -> set_outer_shared info - | V.ReservedMutBorrow _ -> + | VSharedBorrow _ -> set_outer_shared info + | VReservedMutBorrow _ -> assert (not info.outer_borrow); set_outer_shared info - | V.MutBorrow (_, _) -> set_outer_mut info + | VMutBorrow (_, _) -> set_outer_mut info in (* Continue exploring *) super#visit_borrow_content info bc @@ -343,17 +343,16 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = (* Update the info *) let info = match lc with - | V.AMutLoan (_, _) -> set_outer_mut info - | V.ASharedLoan (_, _, _) -> set_outer_shared info - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - -> + | AMutLoan (_, _) -> set_outer_mut info + | ASharedLoan (_, _, _) -> set_outer_shared info + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } -> set_outer_mut info - | V.AEndedSharedLoan (_, _) -> set_outer_shared info - | V.AIgnoredMutLoan (_, _) -> set_outer_mut info - | V.AEndedIgnoredMutLoan + | AEndedSharedLoan (_, _) -> set_outer_shared info + | AIgnoredMutLoan (_, _) -> set_outer_mut info + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } -> set_outer_mut info - | V.AIgnoredSharedLoan _ -> set_outer_shared info + | AIgnoredSharedLoan _ -> set_outer_shared info in (* Continue exploring *) super#visit_aloan_content info lc @@ -362,12 +361,12 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = (* Update the info *) let info = match bc with - | V.AMutBorrow (_, _) -> set_outer_mut info - | V.ASharedBorrow _ | V.AEndedSharedBorrow -> set_outer_shared info - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ - | V.AEndedIgnoredMutBorrow _ -> + | AMutBorrow (_, _) -> set_outer_mut info + | ASharedBorrow _ | AEndedSharedBorrow -> set_outer_shared info + | AIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedIgnoredMutBorrow _ + -> set_outer_mut info - | V.AProjSharedBorrow _ -> set_outer_shared info + | AProjSharedBorrow _ -> set_outer_shared info in (* Continue exploring *) super#visit_aborrow_content info bc @@ -416,10 +415,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check that the types have erased regions *) assert (ty_is_ety tv.ty); (* Check the current pair (value, type) *) - (match (tv.V.value, tv.V.ty) with - | V.VLiteral cv, T.TLiteral ty -> check_literal_type cv ty + (match (tv.value, tv.ty) with + | VLiteral cv, TLiteral ty -> check_literal_type cv ty (* ADT case *) - | V.VAdt av, T.TAdt (T.TAdtId def_id, generics) -> + | VAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in @@ -428,53 +427,51 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = 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 -> + (match (av.variant_id, def.kind) with + | Some variant_id, Enum variants -> assert (T.VariantId.to_int variant_id < List.length variants) - | None, T.Struct _ -> () + | None, Struct _ -> () | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Assoc.type_decl_get_inst_norm_field_etypes ctx def av.V.variant_id + Assoc.type_decl_get_inst_norm_field_etypes ctx def av.variant_id generics in - let fields_with_types = - List.combine av.V.field_values field_types - in + let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.ty = ty)) fields_with_types (* Tuple case *) - | V.VAdt av, T.TAdt (T.TTuple, generics) -> + | VAdt av, TAdt (TTuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); - assert (av.V.variant_id = None); + assert (av.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 generics.types + List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.ty = ty)) fields_with_types (* Assumed type case *) - | V.VAdt av, T.TAdt (T.TAssumed aty_id, generics) -> ( - assert (av.V.variant_id = None); + | VAdt av, TAdt (TAssumed aty_id, generics) -> ( + assert (av.variant_id = None); match ( aty_id, - av.V.field_values, + av.field_values, generics.regions, generics.types, generics.const_generics ) with (* Box *) - | T.TBox, [ inner_value ], [], [ inner_ty ], [] -> - assert (inner_value.V.ty = inner_ty) - | T.TArray, inner_values, _, [ inner_ty ], [ cg ] -> + | TBox, [ inner_value ], [], [ inner_ty ], [] -> + assert (inner_value.ty = inner_ty) + | TArray, inner_values, _, [ inner_ty ], [ cg ] -> (* *) assert ( List.for_all - (fun (v : V.typed_value) -> v.V.ty = inner_ty) + (fun (v : V.typed_value) -> v.ty = inner_ty) inner_values); (* The length is necessarily concrete *) let len = @@ -483,37 +480,37 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = .value in assert (Z.of_int (List.length inner_values) = len) - | (T.TSlice | T.TStr), _, _, _, _ -> raise (Failure "Unexpected") + | (TSlice | TStr), _, _, _, _ -> raise (Failure "Unexpected") | _ -> raise (Failure "Erroneous type")) - | V.Bottom, _ -> (* Nothing to check *) () - | V.Borrow bc, T.TRef (_, ref_ty, rkind) -> ( + | VBottom, _ -> (* Nothing to check *) () + | VBorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | V.SharedBorrow bid, T.Shared | V.ReservedMutBorrow bid, T.Mut -> ( + | VSharedBorrow bid, Shared | VReservedMutBorrow bid, Mut -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan ek_all bid ctx in match glc with - | Concrete (V.SharedLoan (_, sv)) - | Abstract (V.ASharedLoan (_, sv, _)) -> - assert (sv.V.ty = ref_ty) + | Concrete (VSharedLoan (_, sv)) + | Abstract (ASharedLoan (_, sv, _)) -> + assert (sv.ty = ref_ty) | _ -> raise (Failure "Inconsistent context")) - | V.MutBorrow (_, bv), T.Mut -> + | VMutBorrow (_, bv), Mut -> assert ( (* Check that the borrowed value has the proper type *) - bv.V.ty = ref_ty) + bv.ty = ref_ty) | _ -> raise (Failure "Erroneous typing")) - | V.Loan lc, ty -> ( + | VLoan lc, ty -> ( match lc with - | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) - | V.MutLoan bid -> ( + | VSharedLoan (_, sv) -> assert (sv.ty = ty) + | VMutLoan bid -> ( (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow ek_all bid ctx in match glc with - | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) - | Abstract (V.AMutBorrow (_, sv)) -> - assert (Subst.erase_regions sv.V.ty = ty) + | Concrete (VMutBorrow (_, bv)) -> assert (bv.ty = ty) + | Abstract (AMutBorrow (_, sv)) -> + assert (Subst.erase_regions sv.ty = ty) | _ -> raise (Failure "Inconsistent context"))) - | V.Symbolic sv, ty -> - let ty' = Subst.erase_regions sv.V.sv_ty in + | VSymbolic sv, ty -> + let ty' = Subst.erase_regions sv.sv_ty in assert (ty' = ty) | _ -> raise (Failure "Erroneous typing")); (* Continue exploring to inspect the subterms *) @@ -531,9 +528,9 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check that the types have regions *) assert (ty_is_rty atv.ty); (* Check the current pair (value, type) *) - (match (atv.V.value, atv.V.ty) with + (match (atv.value, atv.ty) with (* ADT case *) - | V.AAdt av, T.TAdt (T.TAdtId def_id, generics) -> + | AAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) let def = C.ctx_lookup_type_decl ctx def_id in @@ -545,132 +542,126 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = 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 -> + (match (av.variant_id, def.kind) with + | Some variant_id, Enum variants -> assert (T.VariantId.to_int variant_id < List.length variants) - | None, T.Struct _ -> () + | None, Struct _ -> () | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Assoc.type_decl_get_inst_norm_field_rtypes ctx def av.V.variant_id + Assoc.type_decl_get_inst_norm_field_rtypes ctx def av.variant_id generics in - let fields_with_types = - List.combine av.V.field_values field_types - in + let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.ty = ty)) fields_with_types (* Tuple case *) - | V.AAdt av, T.TAdt (T.TTuple, generics) -> + | AAdt av, TAdt (TTuple, generics) -> assert (generics.regions = []); assert (generics.const_generics = []); - assert (av.V.variant_id = None); + assert (av.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 generics.types + List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.V.ty = ty)) + (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.ty = ty)) fields_with_types (* Assumed type case *) - | V.AAdt av, T.TAdt (T.TAssumed aty_id, generics) -> ( - assert (av.V.variant_id = None); + | AAdt av, TAdt (TAssumed aty_id, generics) -> ( + assert (av.variant_id = None); match ( aty_id, - av.V.field_values, + av.field_values, generics.regions, generics.types, generics.const_generics ) with (* Box *) - | T.TBox, [ boxed_value ], [], [ boxed_ty ], [] -> - assert (boxed_value.V.ty = boxed_ty) + | TBox, [ boxed_value ], [], [ boxed_ty ], [] -> + assert (boxed_value.ty = boxed_ty) | _ -> raise (Failure "Erroneous type")) - | V.ABottom, _ -> (* Nothing to check *) () - | V.ABorrow bc, T.TRef (_, ref_ty, rkind) -> ( + | ABottom, _ -> (* Nothing to check *) () + | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | V.AMutBorrow (_, av), T.Mut -> + | AMutBorrow (_, av), Mut -> (* Check that the child value has the proper type *) - assert (av.V.ty = ref_ty) - | V.ASharedBorrow bid, T.Shared -> ( + assert (av.ty = ref_ty) + | ASharedBorrow bid, Shared -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan ek_all bid ctx in match glc with - | Concrete (V.SharedLoan (_, sv)) - | Abstract (V.ASharedLoan (_, sv, _)) -> - assert (sv.V.ty = Subst.erase_regions ref_ty) + | Concrete (VSharedLoan (_, sv)) + | Abstract (ASharedLoan (_, sv, _)) -> + assert (sv.ty = Subst.erase_regions ref_ty) | _ -> raise (Failure "Inconsistent context")) - | V.AIgnoredMutBorrow (_opt_bid, av), T.Mut -> - assert (av.V.ty = ref_ty) - | ( V.AEndedIgnoredMutBorrow - { given_back; child; given_back_meta = _ }, - T.Mut ) -> - assert (given_back.V.ty = ref_ty); - assert (child.V.ty = ref_ty) - | V.AProjSharedBorrow _, T.Shared -> () + | AIgnoredMutBorrow (_opt_bid, av), Mut -> assert (av.ty = ref_ty) + | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, + Mut ) -> + assert (given_back.ty = ref_ty); + assert (child.ty = ref_ty) + | AProjSharedBorrow _, Shared -> () | _ -> raise (Failure "Inconsistent context")) - | V.ALoan lc, aty -> ( + | ALoan lc, aty -> ( match lc with - | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (Some bid, child_av) + | AMutLoan (bid, child_av) | AIgnoredMutLoan (Some bid, child_av) -> ( let borrowed_aty = aloan_get_expected_child_type aty in - assert (child_av.V.ty = borrowed_aty); + assert (child_av.ty = borrowed_aty); (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow ek_all bid ctx in match glc with - | Concrete (V.MutBorrow (_, bv)) -> - assert (bv.V.ty = Subst.erase_regions borrowed_aty) - | Abstract (V.AMutBorrow (_, sv)) -> + | Concrete (VMutBorrow (_, bv)) -> + assert (bv.ty = Subst.erase_regions borrowed_aty) + | Abstract (AMutBorrow (_, sv)) -> assert ( - Subst.erase_regions sv.V.ty + Subst.erase_regions sv.ty = Subst.erase_regions borrowed_aty) | _ -> raise (Failure "Inconsistent context")) - | V.AIgnoredMutLoan (None, child_av) -> + | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (child_av.V.ty = borrowed_aty) - | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) - -> + assert (child_av.ty = borrowed_aty) + | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (sv.V.ty = Subst.erase_regions borrowed_aty); + assert (sv.ty = Subst.erase_regions borrowed_aty); (* TODO: the type of aloans doesn't make sense, see above *) - assert (child_av.V.ty = borrowed_aty) - | V.AEndedMutLoan { given_back; child; given_back_meta = _ } - | V.AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } - -> + assert (child_av.ty = borrowed_aty) + | AEndedMutLoan { given_back; child; given_back_meta = _ } + | AEndedIgnoredMutLoan { given_back; child; given_back_meta = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (given_back.V.ty = borrowed_aty); - assert (child.V.ty = borrowed_aty) - | V.AIgnoredSharedLoan child_av -> - assert (child_av.V.ty = aloan_get_expected_child_type aty)) - | V.ASymbolic aproj, ty -> ( + assert (given_back.ty = borrowed_aty); + assert (child.ty = borrowed_aty) + | AIgnoredSharedLoan child_av -> + assert (child_av.ty = aloan_get_expected_child_type aty)) + | ASymbolic aproj, ty -> ( let ty1 = Subst.erase_regions ty in match aproj with - | V.AProjLoans (sv, _) -> - let ty2 = Subst.erase_regions sv.V.sv_ty in + | AProjLoans (sv, _) -> + let ty2 = Subst.erase_regions sv.sv_ty in assert (ty1 = ty2); (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in - assert (ty_has_regions_in_set abs.regions sv.V.sv_ty) - | V.AProjBorrows (sv, proj_ty) -> - let ty2 = Subst.erase_regions sv.V.sv_ty in + assert (ty_has_regions_in_set abs.regions sv.sv_ty) + | AProjBorrows (sv, proj_ty) -> + let ty2 = Subst.erase_regions sv.sv_ty in assert (ty1 = ty2); (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in assert (ty_has_regions_in_set abs.regions proj_ty) - | V.AEndedProjLoans (_msv, given_back_ls) -> + | AEndedProjLoans (_msv, given_back_ls) -> List.iter (fun (_, proj) -> match proj with | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) - | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> () + | AEndedProjBorrows _ | AIgnoredProjBorrows -> () | _ -> raise (Failure "Unexpected")) given_back_ls - | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> ()) - | V.AIgnored, _ -> () + | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()) + | AIgnored, _ -> () | _ -> log#lerror (lazy @@ -757,7 +748,7 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = object inherit [_] C.iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs - method! visit_Symbolic _ sv = add_env_sv sv + method! visit_VSymbolic _ sv = add_env_sv sv method! visit_abstract_shared_borrow abs asb = let abs = Option.get abs in diff --git a/compiler/Print.ml b/compiler/Print.ml index 7494dc2a..28e940ba 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -73,10 +73,10 @@ module Values = struct List.map (typed_value_to_string fmt) av.field_values in match v.ty with - | T.TAdt (T.TTuple, _) -> + | TAdt (TTuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.TAdt (T.TAdtId def_id, _) -> + | TAdt (TAdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with @@ -98,7 +98,7 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.TAdt (T.TAssumed aty, _) -> ( + | TAdt (TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" @@ -108,28 +108,29 @@ module Values = struct | _ -> raise (Failure ("Inconsistent value: " ^ V.show_typed_value v))) | _ -> raise (Failure "Inconsistent typed value")) - | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | Borrow bc -> borrow_content_to_string fmt bc - | Loan lc -> loan_content_to_string fmt lc - | Symbolic s -> symbolic_value_to_string ty_fmt s + | VBottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty + | VBorrow bc -> borrow_content_to_string fmt bc + | VLoan lc -> loan_content_to_string fmt lc + | VSymbolic s -> symbolic_value_to_string ty_fmt s and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : string = match bc with - | SharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" - | MutBorrow (bid, tv) -> + | VSharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | VMutBorrow (bid, tv) -> "&mut@" ^ V.BorrowId.to_string bid ^ " (" ^ typed_value_to_string fmt tv ^ ")" - | ReservedMutBorrow bid -> "⌊reserved_mut@" ^ V.BorrowId.to_string bid ^ "⌋" + | VReservedMutBorrow bid -> + "⌊reserved_mut@" ^ V.BorrowId.to_string bid ^ "⌋" and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : string = match lc with - | SharedLoan (loans, v) -> + | VSharedLoan (loans, v) -> let loans = V.BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" - | MutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" + | VMutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" let abstract_shared_borrow_to_string (fmt : value_formatter) (abs : V.abstract_shared_borrow) : string = diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 60020d9a..258b1cf2 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -1149,7 +1149,7 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) (* Translate the value *) let value = match v.value with - | V.VLiteral cv -> { e = Const cv; ty } + | VLiteral cv -> { e = Const cv; ty } | VAdt av -> ( let variant_id = av.variant_id in let field_values = List.map translate av.field_values in @@ -1173,27 +1173,27 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) let cons = { e = cons_e; ty = cons_ty } in (* Apply the constructor *) mk_apps cons field_values) - | Bottom -> raise (Failure "Unreachable") - | Loan lc -> ( + | VBottom -> raise (Failure "Unreachable") + | VLoan lc -> ( match lc with - | SharedLoan (_, v) -> translate v - | MutLoan _ -> raise (Failure "Unreachable")) - | Borrow bc -> ( + | VSharedLoan (_, v) -> translate v + | VMutLoan _ -> raise (Failure "Unreachable")) + | VBorrow bc -> ( match bc with - | V.SharedBorrow bid -> + | VSharedBorrow bid -> (* Lookup the shared value in the context, and continue *) let sv = InterpreterBorrowsCore.lookup_shared_value ectx bid in translate sv - | V.ReservedMutBorrow bid -> + | VReservedMutBorrow bid -> (* Same as for shared borrows. However, note that we use reserved borrows * only in *meta-data*: a value *actually used* in the translation can't come * from an unpromoted reserved borrow *) let sv = InterpreterBorrowsCore.lookup_shared_value ectx bid in translate sv - | V.MutBorrow (_, v) -> + | VMutBorrow (_, v) -> (* Borrows are the identity in the extraction *) translate v) - | Symbolic sv -> symbolic_value_to_texpression ctx sv + | VSymbolic sv -> symbolic_value_to_texpression ctx sv in (* Debugging *) log#ldebug diff --git a/compiler/Values.ml b/compiler/Values.ml index 8526ea66..932530ff 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -115,10 +115,10 @@ type symbolic_value = { and value = | VLiteral of literal (** Non-symbolic primitive value *) | VAdt of adt_value (** Enumerations and structures *) - | Bottom (** No value (uninitialized or moved value) *) - | Borrow of borrow_content (** A borrowed value *) - | Loan of loan_content (** A loaned value *) - | Symbolic of symbolic_value + | VBottom (** No value (uninitialized or moved value) *) + | VBorrow of borrow_content (** A borrowed value *) + | VLoan of loan_content (** A loaned value *) + | VSymbolic of symbolic_value (** Borrow projector over a symbolic value. Note that contrary to the abstraction-values case, symbolic values @@ -132,9 +132,9 @@ and adt_value = { } and borrow_content = - | SharedBorrow of borrow_id (** A shared borrow. *) - | MutBorrow of borrow_id * typed_value (** A mutably borrowed value. *) - | ReservedMutBorrow of borrow_id + | VSharedBorrow of borrow_id (** A shared borrow. *) + | VMutBorrow of borrow_id * typed_value (** A mutably borrowed value. *) + | VReservedMutBorrow of borrow_id (** A reserved mut borrow. This is used to model {{: https://rustc-dev-guide.rust-lang.org/borrow_check/two_phase_borrows.html} two-phase borrows}. @@ -172,8 +172,8 @@ and borrow_content = *) and loan_content = - | SharedLoan of loan_id_set * typed_value - | MutLoan of loan_id + | VSharedLoan of loan_id_set * typed_value + | VMutLoan of loan_id (** "Regular" typed value (we map variables to typed values) *) and typed_value = { value : value; ty : ty } diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 24485002..7880fc3a 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -21,7 +21,7 @@ let mk_typed_avalue (ty : ty) (value : avalue) : typed_avalue = let mk_bottom (ty : ty) : typed_value = assert (ty_is_ety ty); - { value = Bottom; ty } + { value = VBottom; ty } let mk_abottom (ty : ty) : typed_avalue = assert (ty_is_rty ty); @@ -32,7 +32,7 @@ let mk_aignored (ty : ty) : typed_avalue = { value = AIgnored; ty } let value_as_symbolic (v : value) : symbolic_value = - match v with Symbolic v -> v | _ -> raise (Failure "Unexpected") + match v with VSymbolic v -> v | _ -> raise (Failure "Unexpected") (** Box a value *) let mk_box_value (v : typed_value) : typed_value = @@ -40,20 +40,20 @@ let mk_box_value (v : typed_value) : typed_value = let box_v = VAdt { variant_id = None; field_values = [ v ] } in mk_typed_value box_ty box_v -let is_bottom (v : value) : bool = match v with Bottom -> true | _ -> false +let is_bottom (v : value) : bool = match v with VBottom -> true | _ -> false let is_aignored (v : avalue) : bool = match v with AIgnored -> true | _ -> false let is_symbolic (v : value) : bool = - match v with Symbolic _ -> true | _ -> false + match v with VSymbolic _ -> true | _ -> false let as_symbolic (v : value) : symbolic_value = - match v with Symbolic s -> s | _ -> raise (Failure "Unexpected") + match v with VSymbolic s -> s | _ -> raise (Failure "Unexpected") let as_mut_borrow (v : typed_value) : BorrowId.id * typed_value = match v.value with - | Borrow (MutBorrow (bid, bv)) -> (bid, bv) + | VBorrow (VMutBorrow (bid, bv)) -> (bid, bv) | _ -> raise (Failure "Unexpected") let is_unit (v : typed_value) : bool = @@ -86,7 +86,7 @@ let reserved_in_value (v : typed_value) : bool = let obj = object inherit [_] iter_typed_value - method! visit_ReservedMutBorrow _env _ = raise Found + method! visit_VReservedMutBorrow _env _ = raise Found end in (* We use exceptions *) @@ -151,7 +151,7 @@ let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) object inherit [_] iter_typed_value - method! visit_Symbolic _ sv = + method! visit_VSymbolic _ sv = let ty = sv.sv_ty in if ty_is_primitively_copyable ty && ty_has_borrows type_infos ty then raise (FoundSymbolicValue sv) @@ -171,7 +171,7 @@ let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) *) let rec value_strip_shared_loans (v : typed_value) : typed_value = match v.value with - | Loan (SharedLoan (_, v')) -> value_strip_shared_loans v' + | VLoan (VSharedLoan (_, v')) -> value_strip_shared_loans v' | _ -> v (** Check if a symbolic value has borrows *) @@ -251,7 +251,7 @@ let value_remove_shared_loans (v : typed_value) : typed_value = method! visit_typed_value env v = match v.value with - | Loan (SharedLoan (_, sv)) -> self#visit_typed_value env sv + | VLoan (VSharedLoan (_, sv)) -> self#visit_typed_value env sv | _ -> super#visit_typed_value env v end in -- cgit v1.2.3 From 6c88d30031255c0ac612b67bb5b3c20c2f07e563 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 13 Nov 2023 13:27:02 +0100 Subject: Add RegionsHierarchy.ml --- compiler/AssociatedTypes.ml | 5 +- compiler/Assumed.ml | 18 +-- compiler/Contexts.ml | 2 + compiler/ExtractBase.ml | 8 +- compiler/Interpreter.ml | 28 +++-- compiler/InterpreterStatements.ml | 2 +- compiler/InterpreterUtils.ml | 9 +- compiler/LlbcAstUtils.ml | 13 ++ compiler/PureMicroPasses.ml | 9 +- compiler/RegionsHierarchy.ml | 243 ++++++++++++++++++++++++++++++++++++++ compiler/ReorderDecls.ml | 97 +-------------- compiler/SCC.ml | 121 +++++++++++++++++-- compiler/Substitute.ml | 12 +- compiler/SymbolicToPure.ml | 25 ++-- compiler/Translate.ml | 7 +- compiler/dune | 1 + 16 files changed, 453 insertions(+), 147 deletions(-) create mode 100644 compiler/RegionsHierarchy.ml diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index d5c9596e..27e08495 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -521,10 +521,11 @@ let ctx_subst_norm_signature (ctx : C.eval_ctx) (ty_subst : T.TypeVarId.id -> T.ty) (cg_subst : T.ConstGenericVarId.id -> T.const_generic) (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + (tr_self : T.trait_instance_id) (sg : A.fun_sig) + (regions_hierarchy : T.region_groups) : A.inst_fun_sig = let sg = Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self - sg + sg regions_hierarchy in let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in let inputs = List.map (ctx_normalize_ty ctx) inputs in diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index cf81502c..aa0cfccf 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -79,7 +79,7 @@ module Sig = struct let mk_slice_ty (ty : T.ty) : T.ty = TAdt (TAssumed TSlice, mk_generic_args [] [ ty ] []) - let mk_sig generics regions_hierarchy inputs output : A.fun_sig = + let mk_sig generics inputs output : A.fun_sig = let preds : T.predicates = { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } in @@ -88,7 +88,6 @@ module Sig = struct generics; preds; parent_params_info = None; - regions_hierarchy; inputs; output; } @@ -96,18 +95,16 @@ module Sig = struct (** [fn(T) -> Box] *) let box_new_sig : A.fun_sig = 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 + mk_sig generics inputs output (** [fn(Box) -> ()] *) let box_free_sig : A.fun_sig = 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 + mk_sig generics inputs output (** Array/slice functions *) @@ -129,7 +126,6 @@ module Sig = struct let generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) in - let regions_hierarchy = [ region_group_0 ] (* <'a> *) in let inputs = [ mk_ref_ty rvar_0 @@ -145,7 +141,7 @@ module Sig = struct (output_ty type_param_0.index) is_mut (* &'a (mut) output_ty *) in - mk_sig generics regions_hierarchy inputs output + mk_sig generics inputs output let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : A.fun_sig = (* Array *) @@ -176,13 +172,12 @@ module Sig = struct (* *) 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 + mk_sig generics inputs output (** Helper: [fn(&'a [T]) -> usize] @@ -191,12 +186,11 @@ module Sig = struct 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_slice_ty tvar_0) false (* &'a [T] *) ] in let output = mk_usize_ty (* usize *) in - mk_sig generics regions_hierarchy inputs output + mk_sig generics inputs output end type raw_assumed_fun_info = diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 9a20a6cc..12927aab 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -2,6 +2,7 @@ open Types open Expressions open Values open LlbcAst +open LlbcAstUtils module V = Values open ValuesUtils open Identifiers @@ -190,6 +191,7 @@ type type_context = { type fun_context = { fun_decls : fun_decl FunDeclId.Map.t; fun_infos : FunsAnalysis.fun_info FunDeclId.Map.t; + regions_hierarchies : T.region_groups FunIdMap.t; } [@@deriving show] diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index d5eac6f4..4ce1e9f1 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1188,14 +1188,18 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) let def_id = def.def_id 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 regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular def_id) + ctx.trans_ctx.fun_ctx.regions_hierarchies + in + let num_rgs = List.length regions_hierarchy in let { keep_fwd; fwd = _; backs } = trans_group in let num_backs = List.length backs in let rg_info = match def.back_id with | None -> None | Some rg_id -> - let rg = T.RegionGroupId.nth sg.regions_hierarchy rg_id in + let rg = T.RegionGroupId.nth regions_hierarchy rg_id in let region_names = List.map (fun rid -> (T.RegionId.nth sg.generics.regions rid).name) diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 395c0c80..69c9af62 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -29,7 +29,10 @@ let compute_contexts (m : A.crate) : C.decls_ctx = 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 regions_hierarchies = + RegionsHierarchy.compute_regions_hierarchies type_decls fun_decls + in + let fun_ctx = { C.fun_decls; fun_infos; regions_hierarchies } in let global_ctx = { C.global_decls } in let trait_decls_ctx = { C.trait_decls } in let trait_impls_ctx = { C.trait_impls } in @@ -124,8 +127,8 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) 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 { T.trait_id = trait_decl_id; clause_generics; _ } = c in + let generics = Subst.generic_args_substitute subst clause_generics in let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in (* Note that because we directly refer to the clause, we give it empty generics *) @@ -183,8 +186,11 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) * *) let sg = fdef.signature in (* Create the context *) + let regions_hierarchy = + FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies + in let region_groups = - List.map (fun (g : T.region_group) -> g.id) sg.regions_hierarchy + List.map (fun (g : T.region_group) -> g.id) regions_hierarchy in let ctx = initialize_eval_context ctx region_groups sg.generics.types @@ -269,7 +275,6 @@ let evaluate_function_symbolic_synthesize_backward_from_return * the return type. Note that it is important to re-generate * 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.signature fdef.kind in @@ -282,7 +287,10 @@ let evaluate_function_symbolic_synthesize_backward_from_return * will end - this will allow us to, first, mark the other return * regions as non-endable, and, second, end those parent regions in * proper order. *) - let parent_rgs = list_ancestor_region_groups sg back_id in + let regions_hierarchy = + FunIdMap.find (FRegular fdef.def_id) ctx.fun_context.regions_hierarchies + in + let parent_rgs = list_ancestor_region_groups regions_hierarchy back_id in let parent_input_abs_ids = T.RegionGroupId.mapi (fun rg_id rg -> @@ -455,6 +463,10 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) (* Create the evaluation context *) let ctx, input_svs, inst_sg = initialize_symbolic_context_for_fun ctx fdef in + let regions_hierarchy = + FunIdMap.find (FRegular fdef.def_id) ctx.fun_context.regions_hierarchies + in + (* Create the continuation to finish the evaluation *) let config = C.mk_config C.SymbolicMode in let cf_finish res ctx = @@ -511,7 +523,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) let back_el = T.RegionGroupId.mapi (fun gid _ -> (gid, finish_back_eval gid)) - fdef.signature.regions_hierarchy + regions_hierarchy in let back_el = T.RegionGroupId.Map.of_list back_el in (* Put everything together *) @@ -555,7 +567,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) let back_el = T.RegionGroupId.mapi (fun gid _ -> (gid, finish_back_eval gid)) - fdef.signature.regions_hierarchy + regions_hierarchy in let back_el = T.RegionGroupId.Map.of_list back_el in (* Put everything together *) diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index cbc09c29..3627490d 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1434,7 +1434,7 @@ and eval_assumed_function_call_symbolic (config : C.config) let inst_sig = match fid with | BoxFree -> - (* should have been treated above *) + (* Should have been treated above *) raise (Failure "Unreachable") | _ -> (* There shouldn't be any reference to Self *) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 60747b2a..5e2746c5 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -474,6 +474,11 @@ let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) (* Erase the regions in the generics we use for the instantiation *) let generics = Subst.generic_args_erase_regions generics in let tr_self = Subst.trait_instance_id_erase_regions tr_self in + (* Compute the regions hierarchy *) + let regions_hierarchy = + RegionsHierarchy.compute_regions_hierarchy_for_sig + ctx.type_context.type_decls sg + in (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = @@ -481,7 +486,7 @@ let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) (fun rg -> let abs_id = C.fresh_abstraction_id () in (rg.T.id, abs_id)) - sg.regions_hierarchy + regions_hierarchy in let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = List.fold_left @@ -512,7 +517,7 @@ let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) (* Substitute the signature *) let inst_sig = AssociatedTypes.ctx_subst_norm_signature ctx asubst rsubst tsubst cgsubst - tr_subst tr_self sg + tr_subst tr_self sg regions_hierarchy in (* Return *) inst_sig diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 46b36851..de46320b 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -1,5 +1,18 @@ open LlbcAst include Charon.LlbcAstUtils +open Collections + +module FunIdOrderedType : OrderedType with type t = fun_id = struct + type t = fun_id + + let compare = compare_fun_id + let to_string = show_fun_id + let pp_t = pp_fun_id + let show_t = show_fun_id +end + +module FunIdMap = Collections.MakeMap (FunIdOrderedType) +module FunIdSet = Collections.MakeSet (FunIdOrderedType) let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : fun_sig = diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 8872571f..d2747a4b 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -786,18 +786,19 @@ let expression_contains_child_call_in_all_paths (ctx : trans_ctx) if rg_id0 = rg_id1 then true else (* We need to use the regions hierarchy *) - (* First, lookup the signature of the LLBC function *) - let sg = + let regions_hierarchy = let id0 = match id0 with | FunId fun_id -> fun_id | TraitMethod (_, _, fun_decl_id) -> FRegular fun_decl_id in - LlbcAstUtils.lookup_fun_sig id0 ctx.fun_ctx.fun_decls + LlbcAstUtils.FunIdMap.find id0 + ctx.fun_ctx.regions_hierarchies in (* Compute the set of ancestors of the function in call1 *) let call1_ancestors = - LlbcAstUtils.list_ancestor_region_groups sg rg_id1 + LlbcAstUtils.list_ancestor_region_groups regions_hierarchy + rg_id1 in (* Check if the function used in call0 is inside *) T.RegionGroupId.Set.mem rg_id0 call1_ancestors diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml new file mode 100644 index 00000000..dd566426 --- /dev/null +++ b/compiler/RegionsHierarchy.ml @@ -0,0 +1,243 @@ +(** This module analyzes function signatures to compute the + hierarchy between regions. + + Note that we don't need to analyze the types: when there is a non-trivial + relation between lifetimes in a type definition, the Rust compiler will + automatically introduce the relevant where clauses. For instance, in the + definition below: + + {[ + struct Wrapper<'a, 'b, T> { + x : &'a mut &'b mut T, + } + ]} + + the Rust compiler will introduce the where clauses: + {[ + 'b : 'a + T : 'b + ]} + + However, it doesn't do so for the function signatures, which means we have + to compute the constraints between the lifetimes ourselves, then that we + have to compute the SCCs of the lifetimes (two lifetimes 'a and 'b may + satisfy 'a : 'b and 'b : 'a, meaning they are actually equal and should + be grouped together). + *) + +open Types +open TypesUtils +open Expressions +open LlbcAst +open LlbcAstUtils +open Assumed +open SCC +module Subst = Substitute + +let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) + (sg : fun_sig) : region_groups = + (* Create the dependency graph. + + An edge from 'short to 'long means that 'long outlives 'short (that is + we have 'long : 'short, using Rust notations). + *) + (* First initialize the regions map. + + We add: + - the region variables + - the static region + - edges from the region variables to the static region + *) + let g : RegionSet.t RegionMap.t ref = + let s_set = RegionSet.singleton RStatic in + let m = + List.map + (fun (r : region_var) -> (RVar r.index, s_set)) + sg.generics.regions + in + let s = (RStatic, RegionSet.empty) in + ref (RegionMap.of_list (s :: m)) + in + + let add_edge ~(short : region) ~(long : region) = + let m = !g in + let s = RegionMap.find short !g in + let s = RegionSet.add long s in + g := RegionMap.add short s m + in + + let add_edge_from_region_constraint ((long, short) : region_outlives) = + add_edge ~short ~long + in + + let add_edges ~(long : region) ~(shorts : region list) = + List.iter (fun short -> add_edge ~short ~long) shorts + in + + (* Explore the clauses - we only explore the "region outlives" clause, + not the "type outlives" clauses *) + List.iter add_edge_from_region_constraint sg.preds.regions_outlive; + + (* Explore the types in the signature to add the edges *) + let rec explore_ty (outer : region list) (ty : ty) = + match ty with + | TAdt (id, generics) -> + (* Add constraints coming from the type clauses *) + (match id with + | TAdtId id -> + (* Lookup the type declaration *) + let decl = TypeDeclId.Map.find id type_decls in + (* Instantiate the predicates *) + let tr_self = + UnknownTrait ("Unexpected, introduced by " ^ __FUNCTION__) + in + let subst = + Subst.make_subst_from_generics decl.generics generics tr_self + in + let predicates = Subst.predicates_substitute subst decl.preds in + (* Note that because we also explore the generics below, we may + explore several times the same type - this is ok *) + List.iter + (fun (long, short) -> add_edges ~long ~shorts:(short :: outer)) + predicates.regions_outlive; + List.iter + (fun (ty, short) -> explore_ty (short :: outer) ty) + predicates.types_outlive + | TTuple -> (* No clauses for tuples *) () + | TAssumed aid -> ( + match aid with + | TBox | TArray | TSlice | TStr -> (* No clauses for those *) ())); + (* Explore the generics *) + explore_generics outer generics + | TVar _ | TLiteral _ | TNever -> () + | TRef (r, ty, _) -> + (* Add the constraints for r *) + add_edges ~long:r ~shorts:outer; + (* Add r to the outer regions *) + let outer = r :: outer in + (* Continue *) + explore_ty outer ty + | TRawPtr (ty, _) -> explore_ty outer ty + | TTraitType (trait_ref, _generic_args, _) -> + (* The trait should reference a clause, and not an implementation + (otherwise it should have been normalized) *) + assert ( + AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id); + (* We have nothing to do *) + () + | TArrow (inputs, output) -> + (* TODO: this may be too constraining *) + List.iter (explore_ty outer) (output :: inputs) + and explore_generics (outer : region list) (generics : generic_args) = + let { regions; types; const_generics = _; trait_refs = _ } = generics in + List.iter (fun long -> add_edges ~long ~shorts:outer) regions; + List.iter (explore_ty outer) types + in + + List.iter (explore_ty []) (sg.output :: sg.inputs); + + (* Compute the ordered SCCs *) + let module Scc = SCC.Make (RegionOrderedType) in + let sccs = Scc.compute (RegionMap.bindings !g) in + + (* Remove the SCC containing the static region. + + For now, we don't handle cases where regions different from 'static + can live as long as 'static, so we check that if the group contains + 'static then it is the only region it contains, and then we filter + the group. + TODO: general support for 'static + *) + let sccs = + (* Find the SCC which contains the static region *) + let static_gr_id, static_scc = + List.find + (fun (_, scc) -> List.mem RStatic scc) + (SccId.Map.bindings sccs.sccs) + in + (* The SCC should only contain the 'static *) + assert (static_scc = [ RStatic ]); + (* Remove the group as well as references to this group from the + other SCCs *) + let { sccs; scc_deps } = sccs in + (* We have to change the indexing: + - if id < static_gr_id: we leave the id as it is + - if id = static_gr_id: we remove id + - if id > static_gr_id: we decrement it by one + *) + let static_i = SccId.to_int static_gr_id in + let convert_id (id : SccId.id) : SccId.id option = + let i = SccId.to_int id in + if i < static_i then Some id + else if i = static_i then None + else Some (SccId.of_int (i - 1)) + in + let sccs = + SccId.Map.of_list + (List.filter_map + (fun (id, rg_ids) -> + match convert_id id with + | None -> None + | Some id -> Some (id, rg_ids)) + (SccId.Map.bindings sccs)) + in + + let scc_deps = + List.filter_map + (fun (id, deps) -> + match convert_id id with + | None -> None + | Some id -> + let deps = List.filter_map convert_id (SccId.Set.elements deps) in + Some (id, SccId.Set.of_list deps)) + (SccId.Map.bindings scc_deps) + in + let scc_deps = SccId.Map.of_list scc_deps in + + { sccs; scc_deps } + in + + (* + * Compute the regions hierarchy + *) + List.filter_map + (fun (scc_id, scc) -> + (* The region id *) + let i = SccId.to_int scc_id in + let id = RegionGroupId.of_int i in + + (* Retrieve the set of regions in the group *) + let regions = + List.map + (fun r -> + match r with RVar r -> r | _ -> raise (Failure "Unreachable")) + scc + in + + (* Compute the set of parent region groups *) + let parents = + List.map + (fun id -> RegionGroupId.of_int (SccId.to_int id)) + (SccId.Set.elements (SccId.Map.find scc_id sccs.scc_deps)) + in + + (* Put together *) + Some { id; regions; parents }) + (SccId.Map.bindings sccs.sccs) + +let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) + (fun_decls : fun_decl FunDeclId.Map.t) : region_groups FunIdMap.t = + let regular = + List.map + (fun (fid, d) -> (FRegular fid, d.signature)) + (FunDeclId.Map.bindings fun_decls) + in + let assumed = + List.map + (fun (info : assumed_fun_info) -> (FAssumed info.fun_id, info.fun_sig)) + assumed_fun_infos + in + FunIdMap.of_list + (List.map + (fun (fid, sg) -> (fid, compute_regions_hierarchy_for_sig type_decls sg)) + (regular @ assumed)) diff --git a/compiler/ReorderDecls.ml b/compiler/ReorderDecls.ml index c82d625f..53c94ff4 100644 --- a/compiler/ReorderDecls.ml +++ b/compiler/ReorderDecls.ml @@ -1,4 +1,3 @@ -open Graph open Collections open SCC open Pure @@ -99,99 +98,9 @@ let group_reorder_fun_decls (decls : fun_decl list) : decls in - (* - * Create the dependency graph - *) - (* Convert the ids to vertices (i.e., injectively map ids to integers, and create - vertices labeled with those integers). - - Rem.: [Graph.create] is *imperative*: it generates a new vertex every time - it is called (!!). - *) - let module Graph = Pack.Digraph in - let id_to_vertex : Graph.V.t FunIdMap.t = - let cnt = ref 0 in - FunIdMap.of_list - (List.map - (fun id -> - let lbl = !cnt in - cnt := !cnt + 1; - (* We create a vertex *) - let v = Graph.V.create lbl in - (id, v)) - idl) - in - let vertex_to_id : fun_id IntMap.t = - IntMap.of_list - (List.map - (fun (fid, v) -> (Graph.V.label v, fid)) - (FunIdMap.bindings id_to_vertex)) - in - - let to_v id = FunIdMap.find id id_to_vertex in - let to_id v = IntMap.find (Graph.V.label v) vertex_to_id in - - let g = Graph.create () in - - (* Add the edges, first from the vertices to themselves, then between vertices *) - List.iter - (fun (fun_id, deps) -> - let v = to_v fun_id in - Graph.add_edge g v v; - FunIdSet.iter (fun dep_id -> Graph.add_edge g v (to_v dep_id)) deps) - deps; - - (* Compute the SCCs *) - let module Comp = Components.Make (Graph) in - let sccs = Comp.scc_list g in - - (* Convert the vertices to ids *) - let sccs = List.map (List.map to_id) sccs in - - log#ldebug - (lazy - ("group_reorder_fun_decls: SCCs:\n" - ^ Print.list_to_string (Print.list_to_string FunIdOrderedType.show_t) sccs - )); - - (* Sanity check *) - let _ = - (* Check that the SCCs are pairwise disjoint *) - assert (FunIdSet.pairwise_disjoint (List.map FunIdSet.of_list sccs)); - (* Check that all the ids are in the sccs *) - let scc_ids = FunIdSet.of_list (List.concat sccs) in - - log#ldebug - (lazy - ("group_reorder_fun_decls: sanity check:" ^ "\n- ids : " - ^ FunIdSet.show ids ^ "\n- scc_ids: " ^ FunIdSet.show scc_ids)); - - assert (FunIdSet.equal scc_ids ids) - in - - log#ldebug - (lazy - ("group_reorder_fun_decls: reordered SCCs:\n" - ^ Print.list_to_string (Print.list_to_string FunIdOrderedType.show_t) sccs - )); - - (* Reorder *) - let module Reorder = SCC.Make (FunIdOrderedType) in - let id_deps = - FunIdMap.of_list - (List.map (fun (fid, deps) -> (fid, FunIdSet.elements deps)) deps) - in - let sccs = Reorder.reorder_sccs id_deps idl sccs in - - (* Sanity check *) - let _ = - (* Check that the SCCs are pairwise disjoint *) - let sccs = List.map snd (SccId.Map.bindings sccs.sccs) in - assert (FunIdSet.pairwise_disjoint (List.map FunIdSet.of_list sccs)); - (* Check that all the ids are in the sccs *) - let scc_ids = FunIdSet.of_list (List.concat sccs) in - assert (FunIdSet.equal scc_ids ids) - in + (* Compute the ordered SCCs *) + let module Scc = SCC.Make (FunIdOrderedType) in + let sccs = Scc.compute deps in (* Group the declarations *) let deps = FunIdMap.of_list deps in diff --git a/compiler/SCC.ml b/compiler/SCC.ml index d9a4cd3e..150821ad 100644 --- a/compiler/SCC.ml +++ b/compiler/SCC.ml @@ -6,8 +6,15 @@ module SccId = Identifiers.IdGen () (** The local logger *) let log = Logging.scc_log +(** A structure containing information about SCCs (strongly connected components) *) +type 'id sccs = { + sccs : 'id list SccId.Map.t; + scc_deps : SccId.Set.t SccId.Map.t; (** The dependencies between sccs *) +} +[@@deriving show] + (** A functor which provides functions to work on strongly connected components *) -module Make (Id : OrderedType) = struct +module MakeReorder (Id : OrderedType) = struct module IdMap = MakeMap (Id) module IdSet = MakeSet (Id) @@ -15,13 +22,6 @@ module Make (Id : OrderedType) = struct let pp_id = Id.pp_t - (** A structure containing information about SCCs (strongly connected components) *) - type sccs = { - sccs : id list SccId.Map.t; - scc_deps : SccId.Set.t SccId.Map.t; (** The dependencies between sccs *) - } - [@@deriving show] - (** The order in which Tarjan's algorithm generates the SCCs is arbitrary, while we want to keep as much as possible the original order (the order in which the user generated the ids). For this, we iterate through @@ -93,7 +93,7 @@ module Make (Id : OrderedType) = struct Charon project. *) let reorder_sccs (id_deps : Id.t list IdMap.t) (ids : Id.t list) - (sccs : Id.t list list) : sccs = + (sccs : Id.t list list) : id sccs = (* Map the identifiers to the SCC indices *) let id_to_scc = IdMap.of_list @@ -168,13 +168,114 @@ module Make (Id : OrderedType) = struct { sccs = tgt_sccs; scc_deps = tgt_deps } end +module Make (Id : OrderedType) = struct + module M = MakeMap (Id) + module S = MakeSet (Id) + + (** Compute the ordered SCC components for a graph, which is a map + from identifier to set of identifiers (which represent the set + of edges starting from an identifier). + *) + let compute (m : (Id.t * S.t) list) : Id.t sccs = + (* + * Create the dependency graph + *) + (* Compute the list/set of identifiers *) + let idl = List.map fst m in + let ids = S.of_list idl in + + (* Convert the ids to vertices (i.e., injectively map ids to integers, + and create vertices labeled with those integers). + + Rem.: [Graph.create] is *imperative*: it generates a new vertex every + time it is called (!!). For this reason, we first add all the vertices + we need, then add the edges. + *) + let open Graph in + let module IntMap = MakeMap (OrderedInt) in + let module Graph = Pack.Digraph in + let id_to_vertex : Graph.V.t M.t = + let cnt = ref 0 in + M.of_list + (List.map + (fun id -> + let lbl = !cnt in + cnt := !cnt + 1; + (* We create a vertex *) + let v = Graph.V.create lbl in + (id, v)) + idl) + in + let vertex_to_id : Id.t IntMap.t = + IntMap.of_list + (List.map + (fun (fid, v) -> (Graph.V.label v, fid)) + (M.bindings id_to_vertex)) + in + + let to_v id = M.find id id_to_vertex in + let to_id v = IntMap.find (Graph.V.label v) vertex_to_id in + + let g = Graph.create () in + + (* Add the edges, first from the vertices to themselves, then between + vertices. *) + List.iter + (fun (id, deps) -> + let v = to_v id in + Graph.add_edge g v v; + S.iter (fun dep_id -> Graph.add_edge g v (to_v dep_id)) deps) + m; + + (* Compute the SCCs *) + let module Comp = Components.Make (Graph) in + let sccs = Comp.scc_list g in + + (* Convert the vertices to ids *) + let sccs = List.map (List.map to_id) sccs in + + (* Sanity check *) + let _ = + (* Check that the SCCs are pairwise disjoint *) + assert (S.pairwise_disjoint (List.map S.of_list sccs)); + (* Check that all the ids are in the sccs *) + let scc_ids = S.of_list (List.concat sccs) in + + log#ldebug + (lazy + ("group_reorder_fun_decls: sanity check:" ^ "\n- ids : " + ^ S.show ids ^ "\n- scc_ids: " ^ S.show scc_ids)); + + assert (S.equal scc_ids ids) + in + + (* Reorder *) + let module Reorder = MakeReorder (Id) in + let id_deps = + M.of_list (List.map (fun (fid, deps) -> (fid, S.elements deps)) m) + in + let sccs = Reorder.reorder_sccs id_deps idl sccs in + + (* Sanity check *) + let _ = + (* Check that the SCCs are pairwise disjoint *) + let sccs = List.map snd (SccId.Map.bindings sccs.sccs) in + assert (S.pairwise_disjoint (List.map S.of_list sccs)); + (* Check that all the ids are in the sccs *) + let scc_ids = S.of_list (List.concat sccs) in + assert (S.equal scc_ids ids) + in + + sccs +end + (** Test - TODO: make "real" unit tests *) let _ = (* Check that some SCCs are correctly reordered *) let check_sccs (id_deps : (int * int list) list) (ids : int list) (sccs : int list list) (tgt_sccs : int list list) : unit = let module Ord = OrderedInt in - let module Reorder = Make (Ord) in + let module Reorder = MakeReorder (Ord) in let module Map = MakeMap (Ord) in let id_deps = Map.of_list id_deps in diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 166c237a..45edc602 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -64,6 +64,10 @@ let generic_args_substitute (subst : subst) (g : T.generic_args) : let visitor = st_substitute_visitor subst in visitor#visit_generic_args () g +let predicates_substitute (subst : subst) (p : T.predicates) : T.predicates = + let visitor = st_substitute_visitor subst in + visitor#visit_predicates () p + let erase_regions_subst : subst = { r_subst = (fun _ -> T.RErased); @@ -351,7 +355,8 @@ let trait_type_constraint_substitute (subst : subst) let ty = visitor#visit_ty () ty in { T.trait_ref; generics; type_name; ty } -(** Substitute a function signature. +(** Substitute a function signature, together with the regions hierarchy + associated to that signature. **IMPORTANT:** this function doesn't normalize the types. *) @@ -360,7 +365,8 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) (ty_subst : T.TypeVarId.id -> T.ty) (cg_subst : T.ConstGenericVarId.id -> T.const_generic) (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + (tr_self : T.trait_instance_id) (sg : A.fun_sig) + (regions_hierarchy : T.region_groups) : A.inst_fun_sig = let r_subst' (r : T.region) : T.region = match r with | T.RStatic | T.RErased -> r @@ -375,7 +381,7 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) let parents = List.map asubst rg.parents in ({ id; regions; parents } : A.abs_region_group) in - let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in + let regions_hierarchy = List.map subst_region_group regions_hierarchy in let trait_type_constraints = List.map (trait_type_constraint_substitute subst) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 258b1cf2..922aa307 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -47,6 +47,7 @@ type fun_context = { llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; fun_sigs : fun_sig_named_outputs RegularFunIdNotLoopMap.t; (** *) fun_infos : FA.fun_info A.FunDeclId.Map.t; + regions_hierarchies : T.region_groups FunIdMap.t; } [@@deriving show] @@ -441,8 +442,8 @@ and translate_strait_instance_id (id : T.trait_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 + let { T.clause_id; meta = _; trait_id; clause_generics } = clause in + let generics = translate_sgeneric_args clause_generics in { clause_id; trait_id; generics } let translate_strait_type_constraint (ttc : T.trait_type_constraint) : @@ -848,11 +849,14 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) 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 regions_hierarchy = + FunIdMap.find fun_id decls_ctx.fun_ctx.regions_hierarchies + in let gid, parents = match bid with | None -> (None, T.RegionGroupId.Set.empty) | Some bid -> - let parents = list_ancestor_region_groups sg bid in + let parents = list_ancestor_region_groups regions_hierarchy bid in (Some bid, parents) in (* Is the function stateful, and can it fail? *) @@ -865,7 +869,7 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) (* Create the context *) let ctx = let region_groups = - List.map (fun (g : T.region_group) -> g.id) sg.regions_hierarchy + List.map (fun (g : T.region_group) -> g.id) regions_hierarchy in let ctx = InterpreterUtils.initialize_eval_context decls_ctx region_groups @@ -898,7 +902,7 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) assert (T.RegionGroupId.Set.is_empty parents); (* Small helper to translate types for backward functions *) let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.ty -> ty option = - let rg = T.RegionGroupId.nth sg.regions_hierarchy gid in + let rg = T.RegionGroupId.nth regions_hierarchy gid in let regions = T.RegionId.Set.of_list rg.regions in let keep_region r = match r with @@ -2924,6 +2928,9 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let basename = def.name in (* Retrieve the signature *) let signature = ctx.sg in + let regions_hierarchy = + FunIdMap.find (FRegular def_id) ctx.fun_context.regions_hierarchies + in (* Translate the body, if there is *) let body = match body with @@ -2965,7 +2972,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = | None -> [] | Some back_id -> let parents_ids = - list_ordered_ancestor_region_groups def.signature back_id + list_ordered_ancestor_region_groups regions_hierarchy back_id in let backward_ids = List.append parents_ids [ back_id ] in List.concat @@ -3069,6 +3076,10 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) let translate_one (fun_id : A.fun_id) (input_names : string option list) (sg : A.fun_sig) : (regular_fun_id_not_loop * fun_sig_named_outputs) list = + (* Retrieve the regions hierarchy *) + let regions_hierarchy = + FunIdMap.find fun_id decls_ctx.fun_ctx.regions_hierarchies + in (* The forward function *) let fwd_sg = translate_fun_sig decls_ctx fun_id sg input_names None in let fwd_id = (fun_id, None) in @@ -3081,7 +3092,7 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) in let id = (fun_id, Some rg.id) in (id, tsg)) - sg.regions_hierarchy + regions_hierarchy in (* Return *) (fwd_id, fwd_sg) :: back_sgs diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 9a6addee..2aedb544 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -91,6 +91,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) SymbolicToPure.llbc_fun_decls = trans_ctx.fun_ctx.fun_decls; fun_sigs; fun_infos = trans_ctx.fun_ctx.fun_infos; + regions_hierarchies = trans_ctx.fun_ctx.regions_hierarchies; } in let global_context = @@ -263,9 +264,11 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Translate *) SymbolicToPure.translate_fun_decl ctx (Some symbolic) in - let pure_backwards = - List.map translate_backward fdef.signature.regions_hierarchy + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular fdef.def_id) + fun_context.regions_hierarchies in + let pure_backwards = List.map translate_backward regions_hierarchy in (* Return *) (pure_forward, pure_backwards) diff --git a/compiler/dune b/compiler/dune index 648c7325..bc3cc718 100644 --- a/compiler/dune +++ b/compiler/dune @@ -57,6 +57,7 @@ Pure PureTypeCheck PureUtils + RegionsHierarchy ReorderDecls SCC Scalars -- cgit v1.2.3 From cb179ba97d2eafac07ac1208ab1e6ab4446f89df Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 13 Nov 2023 14:17:55 +0100 Subject: Make minor modifications --- compiler/Driver.ml | 1 + compiler/Interpreter.ml | 15 ++++++++------- compiler/InterpreterStatements.ml | 30 +++++++++++++++++++++++++++--- compiler/InterpreterUtils.ml | 8 ++------ compiler/Logging.ml | 3 +++ compiler/RegionsHierarchy.ml | 16 ++++++++++++---- 6 files changed, 53 insertions(+), 20 deletions(-) diff --git a/compiler/Driver.ml b/compiler/Driver.ml index 128ae890..aa293469 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -23,6 +23,7 @@ let _ = Easy_logging.Handlers.set_level main_logger_handler EL.Debug; main_log#set_level EL.Info; llbc_of_json_logger#set_level EL.Info; + regions_hierarchy_log#set_level EL.Info; pre_passes_log#set_level EL.Info; associated_types_log#set_level EL.Info; contexts_log#set_level EL.Info; diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 69c9af62..b94825cc 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -65,7 +65,8 @@ let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : normalize because a trait clause was instantiated with a specific trait ref). *) let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) - (kind : A.fun_kind) : C.eval_ctx * A.inst_fun_sig = + (regions_hierarchy : T.region_groups) (kind : A.fun_kind) : + C.eval_ctx * A.inst_fun_sig = let tr_self = match kind with | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ @@ -147,7 +148,7 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) in { T.regions; types; const_generics; trait_refs } in - let inst_sg = instantiate_fun_sig ctx generics tr_self sg in + let inst_sg = instantiate_fun_sig ctx generics tr_self sg regions_hierarchy in (* Compute the normalization maps *) let ctx = AssociatedTypes.ctx_add_norm_trait_types_from_preds ctx @@ -200,7 +201,7 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) at the same time the normalization map for the associated types. *) let ctx, inst_sg = - symbolic_instantiate_fun_sig ctx fdef.signature fdef.kind + symbolic_instantiate_fun_sig ctx fdef.signature regions_hierarchy fdef.kind in (* Create fresh symbolic values for the inputs *) let input_svs = @@ -275,8 +276,11 @@ let evaluate_function_symbolic_synthesize_backward_from_return * the return type. Note that it is important to re-generate * an instantiation of the signature, so that we use fresh * region ids for the return abstractions. *) + let regions_hierarchy = + FunIdMap.find (FRegular fdef.def_id) ctx.fun_context.regions_hierarchies + in let _, ret_inst_sg = - symbolic_instantiate_fun_sig ctx fdef.signature fdef.kind + symbolic_instantiate_fun_sig ctx fdef.signature regions_hierarchy fdef.kind in let ret_rty = ret_inst_sg.output in (* Move the return value out of the return variable *) @@ -287,9 +291,6 @@ let evaluate_function_symbolic_synthesize_backward_from_return * will end - this will allow us to, first, mark the other return * regions as non-endable, and, second, end those parent regions in * proper order. *) - let regions_hierarchy = - FunIdMap.find (FRegular fdef.def_id) ctx.fun_context.regions_hierarchies - in let parent_rgs = list_ancestor_region_groups regions_hierarchy back_id in let parent_input_abs_ids = T.RegionGroupId.mapi diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 3627490d..b78c2691 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1114,8 +1114,13 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) ^ "\n- def.signature:\n" ^ fun_sig_to_string ctx def.A.signature)); let tr_self = T.UnknownTrait __FUNCTION__ in + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular fid) + ctx.fun_context.regions_hierarchies + in let inst_sg = instantiate_fun_sig ctx call.func.generics tr_self def.A.signature + regions_hierarchy in (call.func.func, call.func.generics, def, inst_sg) | FunId (FAssumed _) -> @@ -1154,9 +1159,14 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let method_def = C.ctx_lookup_fun_decl ctx id in (* Instantiate *) let tr_self = T.TraitRef trait_ref in + let fid : A.fun_id = FRegular id in + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find fid + ctx.fun_context.regions_hierarchies + in let inst_sg = instantiate_fun_sig ctx generics tr_self - method_def.A.signature + method_def.A.signature regions_hierarchy in (* Also update the function identifier: we want to forget the fact that we called a trait method, and treat it as @@ -1164,7 +1174,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) which implements the method. In order to do this properly, we also need to update the generics. *) - let func = E.FunId (FRegular id) in + let func = E.FunId fid in (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* @@ -1210,10 +1220,14 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) ^ "\n- parent params info: " ^ Print.option_to_string A.show_params_info method_def.signature.parent_params_info)); + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular method_id) + ctx.fun_context.regions_hierarchies + in let tr_self = T.TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx all_generics tr_self - method_def.A.signature + method_def.A.signature regions_hierarchy in (call.func.func, call.func.generics, method_def, inst_sg)) | _ -> @@ -1236,9 +1250,14 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) 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 regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular method_id) + ctx.fun_context.regions_hierarchies + in let tr_self = T.TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx generics tr_self method_def.A.signature + regions_hierarchy in (call.func.func, call.func.generics, method_def, inst_sg)) in @@ -1437,10 +1456,15 @@ and eval_assumed_function_call_symbolic (config : C.config) (* Should have been treated above *) raise (Failure "Unreachable") | _ -> + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FAssumed fid) + ctx.fun_context.regions_hierarchies + in (* 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_fun_sig fid) + regions_hierarchy in (* Evaluate the function call *) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 5e2746c5..e5a5b2ea 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -463,7 +463,8 @@ let initialize_eval_context (ctx : C.decls_ctx) evaluating in symbolic mode). *) let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) : A.inst_fun_sig = + (tr_self : T.trait_instance_id) (sg : A.fun_sig) + (regions_hierarchy : T.region_groups) : A.inst_fun_sig = log#ldebug (lazy ("instantiate_fun_sig:" ^ "\n- generics: " @@ -474,11 +475,6 @@ let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) (* Erase the regions in the generics we use for the instantiation *) let generics = Subst.generic_args_erase_regions generics in let tr_self = Subst.trait_instance_id_erase_regions tr_self in - (* Compute the regions hierarchy *) - let regions_hierarchy = - RegionsHierarchy.compute_regions_hierarchy_for_sig - ctx.type_context.type_decls sg - in (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = diff --git a/compiler/Logging.ml b/compiler/Logging.ml index 721655b8..f4ad87a9 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -6,6 +6,9 @@ include Charon.Logging (** Logger for PrePasses *) let pre_passes_log = L.get_logger "MainLogger.PrePasses" +(** Logger for RegionsHierarchy *) +let regions_hierarchy_log = L.get_logger "MainLogger.RegionsHierarchy" + (** Logger for Translate *) let translate_log = L.get_logger "MainLogger.Translate" diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index dd566426..ce5880bf 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -25,6 +25,7 @@ be grouped together). *) +open Names open Types open TypesUtils open Expressions @@ -34,8 +35,12 @@ open Assumed open SCC module Subst = Substitute +(** The local logger *) +let log = Logging.regions_hierarchy_log + let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) - (sg : fun_sig) : region_groups = + (fun_name : name) (sg : fun_sig) : region_groups = + log#ldebug (lazy (__FUNCTION__ ^ ": " ^ name_to_string fun_name)); (* Create the dependency graph. An edge from 'short to 'long means that 'long outlives 'short (that is @@ -229,15 +234,18 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) : region_groups FunIdMap.t = let regular = List.map - (fun (fid, d) -> (FRegular fid, d.signature)) + (fun ((fid, d) : FunDeclId.id * fun_decl) -> + (FRegular fid, (d.name, d.signature))) (FunDeclId.Map.bindings fun_decls) in let assumed = List.map - (fun (info : assumed_fun_info) -> (FAssumed info.fun_id, info.fun_sig)) + (fun (info : assumed_fun_info) -> + (FAssumed info.fun_id, (info.name, info.fun_sig))) assumed_fun_infos in FunIdMap.of_list (List.map - (fun (fid, sg) -> (fid, compute_regions_hierarchy_for_sig type_decls sg)) + (fun (fid, (name, sg)) -> + (fid, compute_regions_hierarchy_for_sig type_decls name sg)) (regular @ assumed)) -- cgit v1.2.3 From 4192258b7e5e3ed034ac16a326c455fe75fe6df4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 13 Nov 2023 14:49:00 +0100 Subject: Normalize the types when computing the regions hierarchies --- compiler/AssociatedTypes.ml | 212 +++++++++++++++++++++++++++++-------------- compiler/Contexts.ml | 8 +- compiler/Interpreter.ml | 1 + compiler/RegionsHierarchy.ml | 42 ++++++++- 4 files changed, 186 insertions(+), 77 deletions(-) diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 27e08495..2f14f0f2 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -104,32 +104,91 @@ let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = (** About the conversion functions: for now we need them (TODO: merge ety, rty, etc.), but they should be applied to types without regions. *) -type norm_ctx = { ctx : C.eval_ctx } - -let ctx_get_ty_repr (ctx : norm_ctx) (x : C.trait_type_ref) : T.ty option = - C.TraitTypeRefMap.find_opt x ctx.ctx.norm_trait_types +type norm_ctx = { + norm_trait_types : T.ty C.TraitTypeRefMap.t; + type_decls : T.type_decl T.TypeDeclId.Map.t; + fun_decls : A.fun_decl A.FunDeclId.Map.t; + global_decls : A.global_decl A.GlobalDeclId.Map.t; + trait_decls : A.trait_decl A.TraitDeclId.Map.t; + trait_impls : A.trait_impl A.TraitImplId.Map.t; + type_vars : T.type_var list; + const_generic_vars : T.const_generic_var list; +} + +let norm_ctx_to_type_formatter (ctx : norm_ctx) : Print.Types.type_formatter = + let open Print in + let region_id_to_string r = PT.region_id_to_string r in + + let type_var_id_to_string vid = + (* The context may be invalid *) + match T.TypeVarId.nth_opt ctx.type_vars vid with + | None -> T.TypeVarId.to_string vid + | Some v -> v.name + in + let const_generic_var_id_to_string vid = + match T.ConstGenericVarId.nth_opt ctx.const_generic_vars vid with + | None -> T.ConstGenericVarId.to_string vid + | Some v -> v.name + in + let type_decl_id_to_string def_id = + let def = T.TypeDeclId.Map.find def_id ctx.type_decls in + name_to_string def.name + in + let global_decl_id_to_string def_id = + let def = A.GlobalDeclId.Map.find def_id ctx.global_decls in + name_to_string def.name + in + let trait_decl_id_to_string def_id = + let def = A.TraitDeclId.Map.find def_id ctx.trait_decls in + name_to_string def.name + in + let trait_impl_id_to_string def_id = + let def = A.TraitImplId.Map.find def_id ctx.trait_impls in + name_to_string def.name + in + let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in + { + region_id_to_string; + type_var_id_to_string; + type_decl_id_to_string; + const_generic_var_id_to_string; + global_decl_id_to_string; + trait_decl_id_to_string; + trait_impl_id_to_string; + trait_clause_id_to_string; + } + +let norm_ctx_get_ty_repr (ctx : norm_ctx) (x : C.trait_type_ref) : T.ty option = + C.TraitTypeRefMap.find_opt x ctx.norm_trait_types let ty_to_string (ctx : norm_ctx) (ty : T.ty) : string = - PA.ty_to_string ctx.ctx ty + let ctx = norm_ctx_to_type_formatter ctx in + Print.Types.ty_to_string ctx ty let trait_ref_to_string (ctx : norm_ctx) (x : T.trait_ref) : string = - PA.trait_ref_to_string ctx.ctx x + let ctx = norm_ctx_to_type_formatter ctx in + Print.Types.trait_ref_to_string ctx x let trait_instance_id_to_string (ctx : norm_ctx) (x : T.trait_instance_id) : string = - PA.trait_instance_id_to_string ctx.ctx x + let ctx = norm_ctx_to_type_formatter ctx in + Print.Types.trait_instance_id_to_string ctx x let generic_args_to_string (ctx : norm_ctx) (x : T.generic_args) : string = - PA.generic_args_to_string ctx.ctx x + let ctx = norm_ctx_to_type_formatter ctx in + Print.Types.generic_args_to_string ctx x let generic_params_to_string (ctx : norm_ctx) (x : T.generic_params) : string = - "<" ^ String.concat ", " (fst (PA.generic_params_to_strings ctx.ctx x)) ^ ">" + let ctx = norm_ctx_to_type_formatter ctx in + "<" + ^ String.concat ", " (fst (Print.Types.generic_params_to_strings ctx x)) + ^ ">" (** Small utility to lookup trait impls, together with a substitution. *) -let ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) +let norm_ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) (generics : T.generic_args) : A.trait_impl * Subst.subst = (* Lookup the implementation *) - let trait_impl = C.ctx_lookup_trait_impl ctx.ctx impl_id in + let trait_impl = A.TraitImplId.Map.find impl_id ctx.trait_impls in (* The substitution *) let tr_self = T.UnknownTrait __FUNCTION__ in let subst = @@ -138,20 +197,20 @@ let ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) (* Return *) (trait_impl, subst) -let ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) +let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) (generics : T.generic_args) (type_name : string) : T.ty = (* Lookup the implementation *) - let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the type *) let ty = snd (List.assoc type_name trait_impl.types) in (* Substitute *) Subst.ty_substitute subst ty -let ctx_lookup_trait_impl_parent_clause (ctx : norm_ctx) +let norm_ctx_lookup_trait_impl_parent_clause (ctx : norm_ctx) (impl_id : T.TraitImplId.id) (generics : T.generic_args) (clause_id : T.TraitClauseId.id) : T.trait_ref = (* Lookup the implementation *) - let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the clause *) let clause = T.TraitClauseId.nth trait_impl.parent_trait_refs clause_id in (* Sanity check: the clause necessarily refers to an impl *) @@ -159,11 +218,11 @@ let ctx_lookup_trait_impl_parent_clause (ctx : norm_ctx) (* Substitute *) Subst.trait_ref_substitute subst clause -let ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) +let norm_ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) (impl_id : T.TraitImplId.id) (generics : T.generic_args) (item_name : string) (clause_id : T.TraitClauseId.id) : T.trait_ref = (* Lookup the implementation *) - let trait_impl, subst = ctx_lookup_trait_impl ctx impl_id generics in + let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the item then its clause *) let item = List.assoc item_name trait_impl.types in let clause = T.TraitClauseId.nth (fst item) clause_id in @@ -176,35 +235,36 @@ let ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) and choosing a representative when there are equalities between types enforced by local clauses (i.e., `where Trait1::T = Trait2::U`. - See the comments for {!ctx_normalize_trait_instance_id}. + See the comments for {!norm_ctx_normalize_trait_instance_id}. *) -let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = - log#ldebug (lazy ("ctx_normalize_ty: " ^ ty_to_string ctx ty)); +let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = + log#ldebug (lazy ("norm_ctx_normalize_ty: " ^ ty_to_string ctx ty)); match ty with - | T.TAdt (id, generics) -> TAdt (id, ctx_normalize_generic_args ctx generics) + | T.TAdt (id, generics) -> + TAdt (id, norm_ctx_normalize_generic_args ctx generics) | TVar _ | TLiteral _ | TNever -> ty | TRef (r, ty, rkind) -> - let ty = ctx_normalize_ty ctx ty in + let ty = norm_ctx_normalize_ty ctx ty in T.TRef (r, ty, rkind) | TRawPtr (ty, rkind) -> - let ty = ctx_normalize_ty ctx ty in + let ty = norm_ctx_normalize_ty ctx ty in TRawPtr (ty, rkind) | TArrow (inputs, output) -> - let inputs = List.map (ctx_normalize_ty ctx) inputs in - let output = ctx_normalize_ty ctx output in + let inputs = List.map (norm_ctx_normalize_ty ctx) inputs in + let output = norm_ctx_normalize_ty ctx output in TArrow (inputs, output) | TTraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy - ("ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty + ("norm_ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref ^ "\n- generics:\n" ^ generic_args_to_string ctx generics)); (* Normalize and attempt to project the type from the trait ref *) - let trait_ref = ctx_normalize_trait_ref ctx trait_ref in - let generics = ctx_normalize_generic_args ctx generics in + let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in + let generics = norm_ctx_normalize_generic_args ctx generics in (* For now, we don't support higher order types *) assert (generics = TypesUtils.mk_empty_generic_args); let ty : T.ty = @@ -214,18 +274,19 @@ let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = assert (ref_generics = TypesUtils.mk_empty_generic_args); log#ldebug (lazy - ("ctx_normalize_ty: trait type: trait ref: " + ("norm_ctx_normalize_ty: trait type: trait ref: " ^ ty_to_string ctx ty)); (* Lookup the type *) let ty = - ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name + norm_ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics + type_name in (* Normalize *) - ctx_normalize_ty ctx ty + norm_ctx_normalize_ty ctx ty | T.TraitImpl impl_id -> log#ldebug (lazy - ("ctx_normalize_ty (trait impl):\n- trait type: " + ("norm_ctx_normalize_ty (trait impl):\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); @@ -237,14 +298,15 @@ let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = *) (* Lookup the type *) let ty = - ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics type_name + norm_ctx_lookup_trait_impl_ty ctx impl_id trait_ref.generics + type_name in (* Normalize *) - ctx_normalize_ty ctx ty + norm_ctx_normalize_ty ctx ty | _ -> log#ldebug (lazy - ("ctx_normalize_ty: trait type: not a trait ref: " + ("norm_ctx_normalize_ty: trait type: not a trait ref: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); @@ -254,7 +316,7 @@ let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = in let tr : C.trait_type_ref = { C.trait_ref; type_name } in (* Lookup the representative, if there is *) - match ctx_get_ty_repr ctx tr with None -> ty | Some ty -> ty) + match norm_ctx_get_ty_repr ctx tr with None -> ty | Some ty -> ty) (** This returns the normalized trait instance id together with an optional reference to a trait **implementation** (the `trait_ref` we return has @@ -300,8 +362,8 @@ let rec ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = In this case we can lookup the trait implementation and recursively project over it. *) -and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) - : T.trait_instance_id * T.trait_ref option = +and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) + (id : T.trait_instance_id) : T.trait_instance_id * T.trait_ref option = match id with | Self -> (id, None) | TraitImpl _ -> @@ -312,7 +374,7 @@ and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) | Clause _ -> (id, None) | BuiltinOrAuto _ -> (id, None) | ParentClause (inst_id, decl_id, clause_id) -> ( - let inst_id, impl = ctx_normalize_trait_instance_id ctx inst_id in + let inst_id, impl = norm_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 -> @@ -336,14 +398,14 @@ and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) TypesUtils.trait_instance_id_as_trait_impl impl.trait_id in let clause = - ctx_lookup_trait_impl_parent_clause ctx impl_id impl.generics + norm_ctx_lookup_trait_impl_parent_clause ctx impl_id impl.generics clause_id in (* Normalize the clause *) - let clause = ctx_normalize_trait_ref ctx clause in + let clause = norm_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 + let inst_id, impl = norm_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 -> @@ -367,18 +429,20 @@ and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) TypesUtils.trait_instance_id_as_trait_impl impl.trait_id in let clause = - ctx_lookup_trait_impl_item_clause ctx impl_id impl.generics + norm_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 + let clause = norm_ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) | TraitRef { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } -> (* 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 generics = norm_ctx_normalize_generic_args ctx generics in + let trait_decl_ref = + norm_ctx_normalize_trait_decl_ref ctx trait_decl_ref + in let trait_ref : T.trait_ref = { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } in @@ -390,7 +454,7 @@ and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_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 + let ty = norm_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) @@ -398,59 +462,73 @@ and ctx_normalize_trait_instance_id (ctx : norm_ctx) (id : T.trait_instance_id) (* This is actually an error case *) (id, None) -and ctx_normalize_generic_args (ctx : norm_ctx) (generics : T.generic_args) : - T.generic_args = +and norm_ctx_normalize_generic_args (ctx : norm_ctx) (generics : T.generic_args) + : T.generic_args = let { T.regions; types; const_generics; trait_refs } = generics in - let types = List.map (ctx_normalize_ty ctx) types in - let trait_refs = List.map (ctx_normalize_trait_ref ctx) trait_refs in + let types = List.map (norm_ctx_normalize_ty ctx) types in + let trait_refs = List.map (norm_ctx_normalize_trait_ref ctx) trait_refs in { T.regions; types; const_generics; trait_refs } -and ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : +and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : T.trait_ref = log#ldebug (lazy - ("ctx_normalize_trait_ref: " + ("norm_ctx_normalize_trait_ref: " ^ trait_ref_to_string ctx trait_ref ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); let { T.trait_id; generics; trait_decl_ref } = trait_ref in (* 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 + let trait_id, norm_trait_ref = + norm_ctx_normalize_trait_instance_id ctx trait_id + in match norm_trait_ref with | None -> log#ldebug (lazy - ("ctx_normalize_trait_ref: no norm: " + ("norm_ctx_normalize_trait_ref: no norm: " ^ trait_instance_id_to_string ctx trait_id)); - let generics = ctx_normalize_generic_args ctx generics in - let trait_decl_ref = ctx_normalize_trait_decl_ref ctx trait_decl_ref in + let generics = norm_ctx_normalize_generic_args ctx generics in + let trait_decl_ref = + norm_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: " + ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); assert (generics = TypesUtils.mk_empty_generic_args); trait_ref (* Not sure this one is really necessary *) -and ctx_normalize_trait_decl_ref (ctx : norm_ctx) +and norm_ctx_normalize_trait_decl_ref (ctx : norm_ctx) (trait_decl_ref : T.trait_decl_ref) : T.trait_decl_ref = let { T.trait_decl_id; decl_generics } = trait_decl_ref in - let decl_generics = ctx_normalize_generic_args ctx decl_generics in + let decl_generics = norm_ctx_normalize_generic_args ctx decl_generics in { T.trait_decl_id; decl_generics } -let ctx_normalize_trait_type_constraint (ctx : norm_ctx) +let norm_ctx_normalize_trait_type_constraint (ctx : norm_ctx) (ttc : T.trait_type_constraint) : T.trait_type_constraint = let { T.trait_ref; generics; type_name; ty } = ttc in - 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 + let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in + let generics = norm_ctx_normalize_generic_args ctx generics in + let ty = norm_ctx_normalize_ty ctx ty in { T.trait_ref; generics; type_name; ty } -let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = { ctx } +let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = + { + norm_trait_types = ctx.norm_trait_types; + type_decls = ctx.type_context.type_decls; + fun_decls = ctx.fun_context.fun_decls; + global_decls = ctx.global_context.global_decls; + trait_decls = ctx.trait_decls_context.trait_decls; + trait_impls = ctx.trait_impls_context.trait_impls; + type_vars = ctx.type_vars; + const_generic_vars = ctx.const_generic_vars; + } let ctx_normalize_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = - ctx_normalize_ty (mk_norm_ctx ctx) ty + norm_ctx_normalize_ty (mk_norm_ctx ctx) ty (** Normalize a type and erase the regions at the same time *) let ctx_normalize_erase_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = @@ -459,7 +537,7 @@ let ctx_normalize_erase_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = let ctx_normalize_trait_type_constraint (ctx : C.eval_ctx) (ttc : T.trait_type_constraint) : T.trait_type_constraint = - ctx_normalize_trait_type_constraint (mk_norm_ctx ctx) ttc + norm_ctx_normalize_trait_type_constraint (mk_norm_ctx ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 12927aab..17ebd315 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -254,18 +254,14 @@ type eval_ctx = { 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 + TypeVarId.nth_opt ctx.type_vars vid 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 + ConstGenericVarId.nth_opt ctx.const_generic_vars vid let lookup_const_generic_var (ctx : eval_ctx) (vid : ConstGenericVarId.id) : const_generic_var = diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index b94825cc..e9c0f17f 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -31,6 +31,7 @@ let compute_contexts (m : A.crate) : C.decls_ctx = in let regions_hierarchies = RegionsHierarchy.compute_regions_hierarchies type_decls fun_decls + global_decls trait_decls trait_impls in let fun_ctx = { C.fun_decls; fun_infos; regions_hierarchies } in let global_ctx = { C.global_decls } in diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index ce5880bf..8227e1fa 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -39,8 +39,31 @@ module Subst = Substitute let log = Logging.regions_hierarchy_log let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) - (fun_name : name) (sg : fun_sig) : region_groups = + (fun_decls : fun_decl FunDeclId.Map.t) + (global_decls : global_decl GlobalDeclId.Map.t) + (trait_decls : trait_decl TraitDeclId.Map.t) + (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : name) + (sg : fun_sig) : region_groups = log#ldebug (lazy (__FUNCTION__ ^ ": " ^ name_to_string fun_name)); + (* Initialize a normalization context (we may need to normalize some + associated types) *) + let norm_ctx : AssociatedTypes.norm_ctx = + let norm_trait_types = + AssociatedTypes.compute_norm_trait_types_from_preds + sg.preds.trait_type_constraints + in + { + norm_trait_types; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + type_vars = sg.generics.types; + const_generic_vars = sg.generics.const_generics; + } + in + (* Create the dependency graph. An edge from 'short to 'long means that 'long outlives 'short (that is @@ -139,7 +162,13 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) List.iter (explore_ty outer) types in - List.iter (explore_ty []) (sg.output :: sg.inputs); + (* Normalize the types then explore *) + let tys = + List.map + (AssociatedTypes.norm_ctx_normalize_ty norm_ctx) + (sg.output :: sg.inputs) + in + List.iter (explore_ty []) tys; (* Compute the ordered SCCs *) let module Scc = SCC.Make (RegionOrderedType) in @@ -231,7 +260,10 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) (SccId.Map.bindings sccs.sccs) let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) - (fun_decls : fun_decl FunDeclId.Map.t) : region_groups FunIdMap.t = + (fun_decls : fun_decl FunDeclId.Map.t) + (global_decls : global_decl GlobalDeclId.Map.t) + (trait_decls : trait_decl TraitDeclId.Map.t) + (trait_impls : trait_impl TraitImplId.Map.t) : region_groups FunIdMap.t = let regular = List.map (fun ((fid, d) : FunDeclId.id * fun_decl) -> @@ -247,5 +279,7 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) FunIdMap.of_list (List.map (fun (fid, (name, sg)) -> - (fid, compute_regions_hierarchy_for_sig type_decls name sg)) + ( fid, + compute_regions_hierarchy_for_sig type_decls fun_decls global_decls + trait_decls trait_impls name sg )) (regular @ assumed)) -- cgit v1.2.3 From 21e3b719f2338f4d4a65c91edc0eb83d0b22393e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 15 Nov 2023 22:03:21 +0100 Subject: Start updating the name type, cleanup the names and the module abbrevs --- compiler/AssociatedTypes.ml | 317 ++++++-------- compiler/Assumed.ml | 123 +++--- compiler/Contexts.ml | 52 ++- compiler/Cps.ml | 32 +- compiler/ExtractBase.ml | 192 +++----- compiler/ExtractBuiltin.ml | 13 +- compiler/FunsAnalysis.ml | 8 +- compiler/Interpreter.ml | 250 +++++------ compiler/InterpreterBorrows.ml | 747 +++++++++++++++----------------- compiler/InterpreterBorrows.mli | 79 ++-- compiler/InterpreterBorrowsCore.ml | 325 +++++++------- compiler/InterpreterExpansion.ml | 247 +++++------ compiler/InterpreterExpansion.mli | 46 +- compiler/InterpreterExpressions.ml | 387 ++++++++--------- compiler/InterpreterExpressions.mli | 30 +- compiler/InterpreterLoops.ml | 3 +- compiler/InterpreterLoopsCore.ml | 266 ++++++------ compiler/InterpreterLoopsFixedPoint.ml | 301 +++++++------ compiler/InterpreterLoopsFixedPoint.mli | 26 +- compiler/InterpreterLoopsJoinCtxs.ml | 255 ++++++----- compiler/InterpreterLoopsJoinCtxs.mli | 37 +- compiler/InterpreterLoopsMatchCtxs.ml | 524 +++++++++++----------- compiler/InterpreterLoopsMatchCtxs.mli | 31 +- compiler/InterpreterPaths.ml | 173 ++++---- compiler/InterpreterPaths.mli | 40 +- compiler/InterpreterProjectors.ml | 182 ++++---- compiler/InterpreterProjectors.mli | 54 +-- compiler/InterpreterStatements.ml | 438 +++++++++---------- compiler/InterpreterStatements.mli | 35 +- compiler/InterpreterUtils.ml | 367 ++++++++-------- compiler/Invariants.ml | 270 ++++++------ compiler/LlbcAstUtils.ml | 17 +- compiler/Names.ml | 1 - compiler/PrePasses.ml | 62 ++- compiler/Print.ml | 686 +++++++++++++---------------- compiler/PrintPure.ml | 571 ++++++++++-------------- compiler/Pure.ml | 27 +- compiler/PureTypeCheck.ml | 2 +- compiler/PureUtils.ml | 8 +- compiler/RegionsHierarchy.ml | 20 +- compiler/Substitute.ml | 374 ++++++++-------- compiler/SymbolicAst.ml | 91 ++-- compiler/SymbolicToPure.ml | 214 ++++----- compiler/SynthesizeSymbolic.ml | 122 +++--- compiler/TranslateCore.ml | 64 +-- compiler/TypesAnalysis.ml | 2 +- compiler/TypesUtils.ml | 20 +- compiler/Values.ml | 1 - compiler/ValuesUtils.ml | 15 +- compiler/dune | 1 - 50 files changed, 3751 insertions(+), 4397 deletions(-) delete mode 100644 compiler/Names.ml diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 2f14f0f2..06c7827a 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -6,96 +6,93 @@ enforced by local clauses (i.e., clauses of the shape [where Trait1::T = Trait2::U]). *) -module T = Types -module TU = TypesUtils -module V = Values -module E = Expressions -module A = LlbcAst -module C = Contexts +open Types +open TypesUtils +open Values +open LlbcAst +open Contexts module Subst = Substitute module L = Logging -module UF = UnionFind -module PA = Print.EvalCtxLlbcAst (** The local logger *) let log = L.associated_types_log -let trait_type_ref_substitute (subst : Subst.subst) (r : C.trait_type_ref) : - C.trait_type_ref = - let { C.trait_ref; type_name } = r in +let trait_type_ref_substitute (subst : Subst.subst) (r : trait_type_ref) : + trait_type_ref = + let { trait_ref; type_name } = r in let trait_ref = Subst.trait_ref_substitute subst trait_ref in - { C.trait_ref; type_name } + { trait_ref; type_name } module TyOrd = struct - type t = T.ty + type t = ty - let compare = T.compare_ty - let to_string = T.show_ty - let pp_t = T.pp_ty - let show_t = T.show_ty + let compare = compare_ty + let to_string = show_ty + let pp_t = pp_ty + let show_t = show_ty end module TyMap = Collections.MakeMap (TyOrd) let compute_norm_trait_types_from_preds - (trait_type_constraints : T.trait_type_constraint list) : - T.ty C.TraitTypeRefMap.t = + (trait_type_constraints : trait_type_constraint list) : ty TraitTypeRefMap.t + = (* Compute a union-find structure by recursively exploring the predicates and clauses *) - let norm : T.ty UF.elem TyMap.t ref = ref TyMap.empty in - let get_ref (ty : T.ty) : T.ty UF.elem = + let norm : ty UnionFind.elem TyMap.t ref = ref TyMap.empty in + let get_ref (ty : ty) : ty UnionFind.elem = match TyMap.find_opt ty !norm with | Some r -> r | None -> - let r = UF.make ty in + let r = UnionFind.make ty in norm := TyMap.add ty r !norm; r in - let add_trait_type_constraint (c : T.trait_type_constraint) = + let add_trait_type_constraint (c : trait_type_constraint) = (* Sanity check: the type constraint can't make use of regions - Remark that it would be enough to only visit the field [ty] of the trait type constraint, but for safety we visit all the fields *) - assert (TU.trait_type_constraint_no_regions c); - let trait_ty = T.TTraitType (c.trait_ref, c.generics, c.type_name) in + assert (trait_type_constraint_no_regions c); + let trait_ty = TTraitType (c.trait_ref, c.generics, c.type_name) in let trait_ty_ref = get_ref trait_ty in let ty_ref = get_ref c.ty in - let new_repr = UF.get ty_ref in - let merged = UF.union trait_ty_ref ty_ref in + let new_repr = UnionFind.get ty_ref in + let merged = UnionFind.union trait_ty_ref ty_ref in (* Not sure the set operation is necessary, but I want to control which representative is chosen *) - UF.set merged new_repr + UnionFind.set merged new_repr in (* Explore the local predicates *) List.iter add_trait_type_constraint trait_type_constraints; (* TODO: explore the local clauses *) (* Compute the norm maps *) let rbindings = - List.map (fun (k, v) -> (k, UF.get v)) (TyMap.bindings !norm) + List.map (fun (k, v) -> (k, UnionFind.get v)) (TyMap.bindings !norm) in (* Filter the keys to keep only the trait type aliases *) let rbindings = List.filter_map (fun (k, v) -> match k with - | T.TTraitType (trait_ref, generics, type_name) -> - assert (generics = TypesUtils.mk_empty_generic_args); - Some ({ C.trait_ref; type_name }, v) + | TTraitType (trait_ref, generics, type_name) -> + assert (generics = empty_generic_args); + Some ({ trait_ref; type_name }, v) | _ -> None) rbindings in - C.TraitTypeRefMap.of_list rbindings + TraitTypeRefMap.of_list rbindings -let ctx_add_norm_trait_types_from_preds (ctx : C.eval_ctx) - (trait_type_constraints : T.trait_type_constraint list) : C.eval_ctx = +let ctx_add_norm_trait_types_from_preds (ctx : eval_ctx) + (trait_type_constraints : trait_type_constraint list) : eval_ctx = let norm_trait_types = compute_norm_trait_types_from_preds trait_type_constraints in - { ctx with C.norm_trait_types } + { ctx with norm_trait_types } (** A trait instance id refers to a local clause if it only uses the variants: [Self], [Clause], [ParentClause], [ItemClause] *) -let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = +let rec trait_instance_id_is_local_clause (id : trait_instance_id) : bool = match id with - | T.Self | Clause _ -> true + | Self | Clause _ -> true | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> false | ParentClause (id, _, _) | ItemClause (id, _, _, _) -> @@ -105,100 +102,75 @@ let rec trait_instance_id_is_local_clause (id : T.trait_instance_id) : bool = but they should be applied to types without regions. *) type norm_ctx = { - norm_trait_types : T.ty C.TraitTypeRefMap.t; - type_decls : T.type_decl T.TypeDeclId.Map.t; - fun_decls : A.fun_decl A.FunDeclId.Map.t; - global_decls : A.global_decl A.GlobalDeclId.Map.t; - trait_decls : A.trait_decl A.TraitDeclId.Map.t; - trait_impls : A.trait_impl A.TraitImplId.Map.t; - type_vars : T.type_var list; - const_generic_vars : T.const_generic_var list; + norm_trait_types : ty TraitTypeRefMap.t; + type_decls : type_decl TypeDeclId.Map.t; + fun_decls : fun_decl FunDeclId.Map.t; + global_decls : global_decl GlobalDeclId.Map.t; + trait_decls : trait_decl TraitDeclId.Map.t; + trait_impls : trait_impl TraitImplId.Map.t; + type_vars : type_var list; + const_generic_vars : const_generic_var list; } -let norm_ctx_to_type_formatter (ctx : norm_ctx) : Print.Types.type_formatter = - let open Print in - let region_id_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - (* The context may be invalid *) - match T.TypeVarId.nth_opt ctx.type_vars vid with - | None -> T.TypeVarId.to_string vid - | Some v -> v.name - in - let const_generic_var_id_to_string vid = - match T.ConstGenericVarId.nth_opt ctx.const_generic_vars vid with - | None -> T.ConstGenericVarId.to_string vid - | Some v -> v.name - in - let type_decl_id_to_string def_id = - let def = T.TypeDeclId.Map.find def_id ctx.type_decls in - name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = A.GlobalDeclId.Map.find def_id ctx.global_decls in - name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = A.TraitDeclId.Map.find def_id ctx.trait_decls in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = A.TraitImplId.Map.find def_id ctx.trait_impls in - name_to_string def.name - in - let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in +let norm_ctx_to_fmt_env (ctx : norm_ctx) : Print.fmt_env = { - region_id_to_string; - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; + type_decls = ctx.type_decls; + fun_decls = ctx.fun_decls; + global_decls = ctx.global_decls; + trait_decls = ctx.trait_decls; + trait_impls = ctx.trait_impls; + generics = + { + types = ctx.type_vars; + const_generics = ctx.const_generic_vars; + regions = []; + trait_clauses = []; + }; + preds = empty_predicates; + locals = []; } -let norm_ctx_get_ty_repr (ctx : norm_ctx) (x : C.trait_type_ref) : T.ty option = - C.TraitTypeRefMap.find_opt x ctx.norm_trait_types +let norm_ctx_get_ty_repr (ctx : norm_ctx) (x : trait_type_ref) : ty option = + TraitTypeRefMap.find_opt x ctx.norm_trait_types -let ty_to_string (ctx : norm_ctx) (ty : T.ty) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let ty_to_string (ctx : norm_ctx) (ty : ty) : string = + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.ty_to_string ctx ty -let trait_ref_to_string (ctx : norm_ctx) (x : T.trait_ref) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let trait_ref_to_string (ctx : norm_ctx) (x : trait_ref) : string = + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.trait_ref_to_string ctx x -let trait_instance_id_to_string (ctx : norm_ctx) (x : T.trait_instance_id) : +let trait_instance_id_to_string (ctx : norm_ctx) (x : trait_instance_id) : string = - let ctx = norm_ctx_to_type_formatter ctx in + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.trait_instance_id_to_string ctx x -let generic_args_to_string (ctx : norm_ctx) (x : T.generic_args) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let generic_args_to_string (ctx : norm_ctx) (x : generic_args) : string = + let ctx = norm_ctx_to_fmt_env ctx in Print.Types.generic_args_to_string ctx x -let generic_params_to_string (ctx : norm_ctx) (x : T.generic_params) : string = - let ctx = norm_ctx_to_type_formatter ctx in +let generic_params_to_string (ctx : norm_ctx) (x : generic_params) : string = + let ctx = norm_ctx_to_fmt_env ctx in "<" ^ String.concat ", " (fst (Print.Types.generic_params_to_strings ctx x)) ^ ">" (** Small utility to lookup trait impls, together with a substitution. *) -let norm_ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : T.TraitImplId.id) - (generics : T.generic_args) : A.trait_impl * Subst.subst = +let norm_ctx_lookup_trait_impl (ctx : norm_ctx) (impl_id : TraitImplId.id) + (generics : generic_args) : trait_impl * Subst.subst = (* Lookup the implementation *) - let trait_impl = A.TraitImplId.Map.find impl_id ctx.trait_impls in + let trait_impl = TraitImplId.Map.find impl_id ctx.trait_impls in (* The substitution *) - let tr_self = T.UnknownTrait __FUNCTION__ in + let tr_self = UnknownTrait __FUNCTION__ in let subst = Subst.make_subst_from_generics trait_impl.generics generics tr_self in (* Return *) (trait_impl, subst) -let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) - (generics : T.generic_args) (type_name : string) : T.ty = +let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : TraitImplId.id) + (generics : generic_args) (type_name : string) : ty = (* Lookup the implementation *) let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the type *) @@ -207,25 +179,25 @@ let norm_ctx_lookup_trait_impl_ty (ctx : norm_ctx) (impl_id : T.TraitImplId.id) Subst.ty_substitute subst ty let norm_ctx_lookup_trait_impl_parent_clause (ctx : norm_ctx) - (impl_id : T.TraitImplId.id) (generics : T.generic_args) - (clause_id : T.TraitClauseId.id) : T.trait_ref = + (impl_id : TraitImplId.id) (generics : generic_args) + (clause_id : TraitClauseId.id) : trait_ref = (* Lookup the implementation *) let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the clause *) - let clause = T.TraitClauseId.nth trait_impl.parent_trait_refs clause_id in + let clause = TraitClauseId.nth trait_impl.parent_trait_refs clause_id in (* Sanity check: the clause necessarily refers to an impl *) let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in (* Substitute *) Subst.trait_ref_substitute subst clause let norm_ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) - (impl_id : T.TraitImplId.id) (generics : T.generic_args) - (item_name : string) (clause_id : T.TraitClauseId.id) : T.trait_ref = + (impl_id : TraitImplId.id) (generics : generic_args) (item_name : string) + (clause_id : TraitClauseId.id) : trait_ref = (* Lookup the implementation *) let trait_impl, subst = norm_ctx_lookup_trait_impl ctx impl_id generics in (* Lookup the item then its clause *) let item = List.assoc item_name trait_impl.types in - let clause = T.TraitClauseId.nth (fst item) clause_id in + let clause = TraitClauseId.nth (fst item) clause_id in (* Sanity check: the clause necessarily refers to an impl *) let _ = TypesUtils.trait_instance_id_as_trait_impl clause.trait_id in (* Substitute *) @@ -237,15 +209,15 @@ let norm_ctx_lookup_trait_impl_item_clause (ctx : norm_ctx) See the comments for {!norm_ctx_normalize_trait_instance_id}. *) -let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = +let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = log#ldebug (lazy ("norm_ctx_normalize_ty: " ^ ty_to_string ctx ty)); match ty with - | T.TAdt (id, generics) -> + | TAdt (id, generics) -> TAdt (id, norm_ctx_normalize_generic_args ctx generics) | TVar _ | TLiteral _ | TNever -> ty | TRef (r, ty, rkind) -> let ty = norm_ctx_normalize_ty ctx ty in - T.TRef (r, ty, rkind) + TRef (r, ty, rkind) | TRawPtr (ty, rkind) -> let ty = norm_ctx_normalize_ty ctx ty in TRawPtr (ty, rkind) @@ -259,19 +231,19 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = ("norm_ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref ^ "\n- generics:\n" ^ generic_args_to_string ctx generics)); (* Normalize and attempt to project the type from the trait ref *) let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in let generics = norm_ctx_normalize_generic_args ctx generics in (* For now, we don't support higher order types *) - assert (generics = TypesUtils.mk_empty_generic_args); - let ty : T.ty = + assert (generics = empty_generic_args); + let ty : ty = match trait_ref.trait_id with - | T.TraitRef - { T.trait_id = T.TraitImpl impl_id; generics = ref_generics; _ } -> - assert (ref_generics = TypesUtils.mk_empty_generic_args); + | TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ } + -> + assert (ref_generics = empty_generic_args); log#ldebug (lazy ("norm_ctx_normalize_ty: trait type: trait ref: " @@ -283,17 +255,17 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = in (* Normalize *) norm_ctx_normalize_ty ctx ty - | T.TraitImpl impl_id -> + | TraitImpl impl_id -> log#ldebug (lazy ("norm_ctx_normalize_ty (trait impl):\n- trait type: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* This happens. This doesn't come from the substitutions performed by Aeneas (the [TraitImpl] would be wrapped in a [TraitRef] but from non-normalized traits translated from - the Rustc AST. + the Rustc AS TODO: factor out with the branch above. *) (* Lookup the type *) @@ -309,12 +281,12 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = ("norm_ctx_normalize_ty: trait type: not a trait ref: " ^ ty_to_string ctx ty ^ "\n- trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); (* We can't project *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); - T.TTraitType (trait_ref, generics, type_name) + TTraitType (trait_ref, generics, type_name) in - let tr : C.trait_type_ref = { C.trait_ref; type_name } in + let tr : trait_type_ref = { trait_ref; type_name } in (* Lookup the representative, if there is *) match norm_ctx_get_ty_repr ctx tr with None -> ty | Some ty -> ty) @@ -363,7 +335,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : T.ty) : T.ty = over it. *) and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) - (id : T.trait_instance_id) : T.trait_instance_id * T.trait_ref option = + (id : trait_instance_id) : trait_instance_id * trait_ref option = match id with | Self -> (id, None) | TraitImpl _ -> @@ -435,7 +407,7 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) (* Normalize the clause *) let clause = norm_ctx_normalize_trait_ref ctx clause in (TraitRef clause, Some clause)) - | TraitRef { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } -> + | TraitRef { trait_id = TraitImpl trait_id; generics; trait_decl_ref } -> (* We can't simplify the id *yet* : we will simplify it when projecting. However, we have an implementation to return *) (* Normalize the generics *) @@ -443,15 +415,15 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) let trait_decl_ref = norm_ctx_normalize_trait_decl_ref ctx trait_decl_ref in - let trait_ref : T.trait_ref = - { T.trait_id = T.TraitImpl trait_id; generics; trait_decl_ref } + let trait_ref : trait_ref = + { trait_id = TraitImpl trait_id; generics; trait_decl_ref } in (TraitRef trait_ref, Some trait_ref) | TraitRef trait_ref -> (* The trait instance id necessarily refers to a local sub-clause. We can't project over it and can only peel off the [TraitRef] wrapper *) assert (trait_instance_id_is_local_clause trait_ref.trait_id); - assert (trait_ref.generics = TypesUtils.mk_empty_generic_args); + assert (trait_ref.generics = empty_generic_args); (trait_ref.trait_id, None) | FnPointer ty -> let ty = norm_ctx_normalize_ty ctx ty in @@ -462,21 +434,21 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) (* This is actually an error case *) (id, None) -and norm_ctx_normalize_generic_args (ctx : norm_ctx) (generics : T.generic_args) - : T.generic_args = - let { T.regions; types; const_generics; trait_refs } = generics in +and norm_ctx_normalize_generic_args (ctx : norm_ctx) (generics : generic_args) : + generic_args = + let { regions; types; const_generics; trait_refs } = generics in let types = List.map (norm_ctx_normalize_ty ctx) types in let trait_refs = List.map (norm_ctx_normalize_trait_ref ctx) trait_refs in - { T.regions; types; const_generics; trait_refs } + { regions; types; const_generics; trait_refs } -and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : - T.trait_ref = +and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : trait_ref) : + trait_ref = log#ldebug (lazy ("norm_ctx_normalize_trait_ref: " ^ trait_ref_to_string ctx trait_ref - ^ "\n- raw trait ref:\n" ^ T.show_trait_ref trait_ref)); - let { T.trait_id; generics; trait_decl_ref } = trait_ref in + ^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref)); + let { trait_id; generics; trait_decl_ref } = trait_ref in (* Check if the id is an impl, otherwise normalize it *) let trait_id, norm_trait_ref = norm_ctx_normalize_trait_instance_id ctx trait_id @@ -491,31 +463,31 @@ and norm_ctx_normalize_trait_ref (ctx : norm_ctx) (trait_ref : T.trait_ref) : let trait_decl_ref = norm_ctx_normalize_trait_decl_ref ctx trait_decl_ref in - { T.trait_id; generics; trait_decl_ref } + { trait_id; generics; trait_decl_ref } | Some trait_ref -> log#ldebug (lazy ("norm_ctx_normalize_trait_ref: normalized to: " ^ trait_ref_to_string ctx trait_ref)); - assert (generics = TypesUtils.mk_empty_generic_args); + assert (generics = empty_generic_args); trait_ref (* Not sure this one is really necessary *) and norm_ctx_normalize_trait_decl_ref (ctx : norm_ctx) - (trait_decl_ref : T.trait_decl_ref) : T.trait_decl_ref = - let { T.trait_decl_id; decl_generics } = trait_decl_ref in + (trait_decl_ref : trait_decl_ref) : trait_decl_ref = + let { trait_decl_id; decl_generics } = trait_decl_ref in let decl_generics = norm_ctx_normalize_generic_args ctx decl_generics in - { T.trait_decl_id; decl_generics } + { trait_decl_id; decl_generics } let norm_ctx_normalize_trait_type_constraint (ctx : norm_ctx) - (ttc : T.trait_type_constraint) : T.trait_type_constraint = - let { T.trait_ref; generics; type_name; ty } = ttc in + (ttc : trait_type_constraint) : trait_type_constraint = + let { trait_ref; generics; type_name; ty } = ttc in let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in let generics = norm_ctx_normalize_generic_args ctx generics in let ty = norm_ctx_normalize_ty ctx ty in - { T.trait_ref; generics; type_name; ty } + { trait_ref; generics; type_name; ty } -let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = +let mk_norm_ctx (ctx : eval_ctx) : norm_ctx = { norm_trait_types = ctx.norm_trait_types; type_decls = ctx.type_context.type_decls; @@ -527,22 +499,22 @@ let mk_norm_ctx (ctx : C.eval_ctx) : norm_ctx = const_generic_vars = ctx.const_generic_vars; } -let ctx_normalize_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = +let ctx_normalize_ty (ctx : eval_ctx) (ty : ty) : ty = norm_ctx_normalize_ty (mk_norm_ctx ctx) ty (** Normalize a type and erase the regions at the same time *) -let ctx_normalize_erase_ty (ctx : C.eval_ctx) (ty : T.ty) : T.ty = +let ctx_normalize_erase_ty (ctx : eval_ctx) (ty : ty) : ty = let ty = ctx_normalize_ty ctx ty in Subst.erase_regions ty -let ctx_normalize_trait_type_constraint (ctx : C.eval_ctx) - (ttc : T.trait_type_constraint) : T.trait_type_constraint = +let ctx_normalize_trait_type_constraint (ctx : eval_ctx) + (ttc : trait_type_constraint) : trait_type_constraint = norm_ctx_normalize_trait_type_constraint (mk_norm_ctx ctx) ttc (** Same as [type_decl_get_instantiated_variants_fields_types] but normalizes the types *) -let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) - (def : T.type_decl) (generics : T.generic_args) : - (T.VariantId.id option * T.ty list) list = +let type_decl_get_inst_norm_variants_fields_rtypes (ctx : eval_ctx) + (def : type_decl) (generics : generic_args) : + (VariantId.id option * ty list) list = let res = Subst.type_decl_get_instantiated_variants_fields_types def generics in @@ -552,18 +524,16 @@ let type_decl_get_inst_norm_variants_fields_rtypes (ctx : C.eval_ctx) res (** Same as [type_decl_get_instantiated_field_types] but normalizes the types *) -let type_decl_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : - T.ty list = +let type_decl_get_inst_norm_field_rtypes (ctx : eval_ctx) (def : type_decl) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in List.map (ctx_normalize_ty ctx) types (** Same as [ctx_adt_value_get_instantiated_field_rtypes] but normalizes the types *) -let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list - = +let ctx_adt_value_get_inst_norm_field_rtypes (ctx : eval_ctx) (adt : adt_value) + (id : type_id) (generics : generic_args) : ty list = let types = Subst.ctx_adt_value_get_instantiated_field_types ctx adt id generics in @@ -571,9 +541,8 @@ let ctx_adt_value_get_inst_norm_field_rtypes (ctx : C.eval_ctx) (** Same as [ctx_adt_value_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : - T.ty list = +let type_decl_get_inst_norm_field_etypes (ctx : eval_ctx) (def : type_decl) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.type_decl_get_instantiated_field_types def opt_variant_id generics in @@ -582,9 +551,8 @@ let type_decl_get_inst_norm_field_etypes (ctx : C.eval_ctx) (def : T.type_decl) (** Same as [ctx_adt_get_instantiated_field_types] but normalizes the types and erases the regions. *) -let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.generic_args) : T.ty list = +let ctx_adt_get_inst_norm_field_etypes (ctx : eval_ctx) (def_id : TypeDeclId.id) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = let types = Subst.ctx_adt_get_instantiated_field_types ctx def_id opt_variant_id generics @@ -593,19 +561,18 @@ let ctx_adt_get_inst_norm_field_etypes (ctx : C.eval_ctx) List.map Subst.erase_regions types (** Same as [substitute_signature] but normalizes the types *) -let ctx_subst_norm_signature (ctx : C.eval_ctx) - (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.ty) - (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) : A.inst_fun_sig = +let ctx_subst_norm_signature (ctx : eval_ctx) + (asubst : RegionGroupId.id -> AbstractionId.id) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) + (cg_subst : ConstGenericVarId.id -> const_generic) + (tr_subst : TraitClauseId.id -> trait_instance_id) + (tr_self : trait_instance_id) (sg : fun_sig) + (regions_hierarchy : region_groups) : inst_fun_sig = let sg = Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self sg regions_hierarchy in - let { A.regions_hierarchy; inputs; output; trait_type_constraints } = sg in + let { regions_hierarchy; inputs; output; trait_type_constraints } = sg in let inputs = List.map (ctx_normalize_ty ctx) inputs in let output = ctx_normalize_ty ctx output in let trait_type_constraints = diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index aa0cfccf..6aec626a 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -29,58 +29,57 @@ ]} *) -open Names +open Types open TypesUtils -module T = Types -module A = LlbcAst +open LlbcAst module Sig = struct (** A few utilities *) - let rvar_id_0 = T.RegionId.of_int 0 - let rvar_0 : T.region = T.RVar rvar_id_0 - let rg_id_0 = T.RegionGroupId.of_int 0 - let tvar_id_0 = T.TypeVarId.of_int 0 - let tvar_0 : T.ty = T.TVar tvar_id_0 - let cgvar_id_0 = T.ConstGenericVarId.of_int 0 - let cgvar_0 : T.const_generic = T.CGVar cgvar_id_0 + let rvar_id_0 = RegionId.of_int 0 + let rvar_0 : region = RVar rvar_id_0 + let rg_id_0 = RegionGroupId.of_int 0 + let tvar_id_0 = TypeVarId.of_int 0 + let tvar_0 : ty = TVar tvar_id_0 + let cgvar_id_0 = ConstGenericVarId.of_int 0 + let cgvar_0 : const_generic = CGVar cgvar_id_0 (** Region 'a of id 0 *) - let region_param_0 : T.region_var = { T.index = rvar_id_0; name = Some "'a" } + let region_param_0 : region_var = { index = rvar_id_0; name = Some "'a" } (** Region group: [{ parent={}; regions:{'a of id 0} }] *) - let region_group_0 : T.region_group = - { T.id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } + let region_group_0 : region_group = + { id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } (** Type parameter [T] of id 0 *) - let type_param_0 : T.type_var = { T.index = tvar_id_0; name = "T" } + let type_param_0 : type_var = { index = tvar_id_0; name = "T" } - let usize_ty : T.ty = T.TLiteral (TInteger Usize) + let usize_ty : ty = TLiteral (TInteger Usize) (** Const generic parameter [const N : usize] of id 0 *) - let cg_param_0 : T.const_generic_var = - { T.index = cgvar_id_0; name = "N"; ty = TInteger Usize } + let cg_param_0 : const_generic_var = + { index = cgvar_id_0; name = "N"; ty = TInteger Usize } - let empty_const_generic_params : T.const_generic_var list = [] + let empty_const_generic_params : const_generic_var list = [] - let mk_generic_args regions types const_generics : T.generic_args = + let mk_generic_args regions types const_generics : generic_args = { regions; types; const_generics; trait_refs = [] } - let mk_generic_params regions types const_generics : T.generic_params = + let mk_generic_params regions types const_generics : generic_params = { regions; types; const_generics; trait_clauses = [] } - let mk_ref_ty (r : T.region) (ty : T.ty) (is_mut : bool) : T.ty = - let ref_kind = if is_mut then T.Mut else T.Shared in + let mk_ref_ty (r : region) (ty : ty) (is_mut : bool) : ty = + let ref_kind = if is_mut then RMut else RShared in mk_ref_ty r ty ref_kind - let mk_array_ty (ty : T.ty) (cg : T.const_generic) : T.ty = + let mk_array_ty (ty : ty) (cg : const_generic) : ty = TAdt (TAssumed TArray, mk_generic_args [] [ ty ] [ cg ]) - let mk_slice_ty (ty : T.ty) : T.ty = + let mk_slice_ty (ty : ty) : ty = TAdt (TAssumed TSlice, mk_generic_args [] [ ty ] []) - let mk_sig generics inputs output : A.fun_sig = - let preds : T.predicates = + let mk_sig generics inputs output : fun_sig = + let preds : predicates = { regions_outlive = []; types_outlive = []; trait_type_constraints = [] } in { @@ -93,14 +92,14 @@ module Sig = struct } (** [fn(T) -> Box] *) - let box_new_sig : A.fun_sig = + let box_new_sig : fun_sig = let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in let inputs = [ tvar_0 (* T *) ] in let output = mk_box_ty tvar_0 (* Box *) in mk_sig generics inputs output (** [fn(Box) -> ()] *) - let box_free_sig : A.fun_sig = + let box_free_sig : fun_sig = let generics = mk_generic_params [] [ type_param_0 ] [] (* *) in let inputs = [ mk_box_ty tvar_0 (* Box *) ] in let output = mk_unit_ty (* () *) in @@ -120,9 +119,9 @@ module Sig = struct The [mut_borrow] boolean controls whether we use a shared or a mutable borrow. *) - let mk_array_slice_borrow_sig (cgs : T.const_generic_var list) - (input_ty : T.TypeVarId.id -> T.ty) (index_ty : T.ty option) - (output_ty : T.TypeVarId.id -> T.ty) (is_mut : bool) : A.fun_sig = + let mk_array_slice_borrow_sig (cgs : const_generic_var list) + (input_ty : TypeVarId.id -> ty) (index_ty : ty option) + (output_ty : TypeVarId.id -> ty) (is_mut : bool) : fun_sig = let generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] cgs (* <'a, T> *) in @@ -143,27 +142,26 @@ module Sig = struct in mk_sig generics inputs output - let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : A.fun_sig = + let mk_array_slice_index_sig (is_array : bool) (is_mut : bool) : fun_sig = (* Array *) let input_ty id = - if is_array then mk_array_ty (T.TVar id) cgvar_0 - else mk_slice_ty (T.TVar id) + if is_array then mk_array_ty (TVar id) cgvar_0 else mk_slice_ty (TVar id) in (* usize *) let index_ty = usize_ty in (* T *) - let output_ty id = T.TVar id in + let output_ty id = TVar id in let cgs = if is_array then [ cg_param_0 ] else [] in mk_array_slice_borrow_sig cgs input_ty (Some index_ty) output_ty is_mut let array_index_sig (is_mut : bool) = mk_array_slice_index_sig true is_mut let slice_index_sig (is_mut : bool) = mk_array_slice_index_sig false is_mut - let array_to_slice_sig (is_mut : bool) : A.fun_sig = + let array_to_slice_sig (is_mut : bool) : fun_sig = (* Array *) - let input_ty id = mk_array_ty (T.TVar id) cgvar_0 in + let input_ty id = mk_array_ty (TVar id) cgvar_0 in (* Slice *) - let output_ty id = mk_slice_ty (T.TVar id) in + let output_ty id = mk_slice_ty (TVar id) in let cgs = [ cg_param_0 ] in mk_array_slice_borrow_sig cgs input_ty None output_ty is_mut @@ -182,7 +180,7 @@ module Sig = struct (** Helper: [fn(&'a [T]) -> usize] *) - let slice_len_sig : A.fun_sig = + let slice_len_sig : fun_sig = let generics = mk_generic_params [ region_param_0 ] [ type_param_0 ] [] (* <'a, T> *) in @@ -194,13 +192,13 @@ module Sig = struct end type raw_assumed_fun_info = - A.assumed_fun_id * A.fun_sig * bool * name * bool list option + assumed_fun_id * fun_sig * bool * string * bool list option type assumed_fun_info = { - fun_id : A.assumed_fun_id; - fun_sig : A.fun_sig; + fun_id : assumed_fun_id; + fun_sig : fun_sig; can_fail : bool; - name : name; + name : string; keep_types : bool list option; (** We may want to filter some type arguments. @@ -226,70 +224,63 @@ let mk_assumed_fun_info (raw : raw_assumed_fun_info) : assumed_fun_info = *) let raw_assumed_fun_infos : raw_assumed_fun_info list = [ + (* TODO: the names are not correct ("Box" should be an impl elem for instance) + but it's not important) *) ( BoxNew, Sig.box_new_sig, false, - to_name [ "alloc"; "boxed"; "Box"; "new" ], + "alloc::boxed::Box::new", Some [ true; false ] ); (* BoxFree shouldn't be used *) ( BoxFree, Sig.box_free_sig, false, - to_name [ "alloc"; "boxed"; "Box"; "free" ], + "alloc::boxed::Box::free", Some [ true; false ] ); (* Array Index *) ( ArrayIndexShared, Sig.array_index_sig false, true, - to_name [ "@ArrayIndexShared" ], - None ); - ( ArrayIndexMut, - Sig.array_index_sig true, - true, - to_name [ "@ArrayIndexMut" ], + "@ArrayIndexShared", None ); + (ArrayIndexMut, Sig.array_index_sig true, true, "@ArrayIndexMut", None); (* Array to slice*) ( ArrayToSliceShared, Sig.array_to_slice_sig false, true, - to_name [ "@ArrayToSliceShared" ], + "@ArrayToSliceShared", None ); ( ArrayToSliceMut, Sig.array_to_slice_sig true, true, - to_name [ "@ArrayToSliceMut" ], + "@ArrayToSliceMut", None ); (* Array Repeat *) - (ArrayRepeat, Sig.array_repeat_sig, false, to_name [ "@ArrayRepeat" ], None); + (ArrayRepeat, Sig.array_repeat_sig, false, "@ArrayRepeat", None); (* Slice Index *) ( SliceIndexShared, Sig.slice_index_sig false, true, - to_name [ "@SliceIndexShared" ], - None ); - ( SliceIndexMut, - Sig.slice_index_sig true, - true, - to_name [ "@SliceIndexMut" ], + "@SliceIndexShared", None ); - (SliceLen, Sig.slice_len_sig, false, to_name [ "@SliceLen" ], None); + (SliceIndexMut, Sig.slice_index_sig true, true, "@SliceIndexMut", None); ] let assumed_fun_infos : assumed_fun_info list = List.map mk_assumed_fun_info raw_assumed_fun_infos -let get_assumed_fun_info (id : A.assumed_fun_id) : assumed_fun_info = +let get_assumed_fun_info (id : assumed_fun_id) : assumed_fun_info = match List.find_opt (fun x -> id = x.fun_id) assumed_fun_infos with | Some info -> info | None -> raise - (Failure ("get_assumed_fun_info: not found: " ^ A.show_assumed_fun_id id)) + (Failure ("get_assumed_fun_info: not found: " ^ show_assumed_fun_id id)) -let get_assumed_fun_sig (id : A.assumed_fun_id) : A.fun_sig = +let get_assumed_fun_sig (id : assumed_fun_id) : fun_sig = (get_assumed_fun_info id).fun_sig -let get_assumed_fun_name (id : A.assumed_fun_id) : fun_name = +let get_assumed_fun_name (id : assumed_fun_id) : string = (get_assumed_fun_info id).name -let assumed_fun_can_fail (id : A.assumed_fun_id) : bool = +let assumed_fun_can_fail (id : assumed_fun_id) : bool = (get_assumed_fun_info id).can_fail diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 17ebd315..41c84141 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -3,7 +3,6 @@ open Expressions open Values open LlbcAst open LlbcAstUtils -module V = Values open ValuesUtils open Identifiers module L = Logging @@ -191,7 +190,7 @@ type type_context = { type fun_context = { fun_decls : fun_decl FunDeclId.Map.t; fun_infos : FunsAnalysis.fun_info FunDeclId.Map.t; - regions_hierarchies : T.region_groups FunIdMap.t; + regions_hierarchies : region_groups FunIdMap.t; } [@@deriving show] @@ -371,7 +370,7 @@ let ctx_push_vars (ctx : eval_ctx) (vars : (var * typed_value) list) : eval_ctx (List.map (fun (var, value) -> (* We can unfortunately not use Print because it depends on Contexts... *) - show_var var ^ " -> " ^ V.show_typed_value value) + show_var var ^ " -> " ^ show_typed_value value) vars))); assert ( List.for_all @@ -433,7 +432,7 @@ let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = let vars = List.map (fun v -> (v, mk_bottom (erase_regions v.var_ty))) vars in ctx_push_vars ctx vars -let env_find_abs (env : env) (pred : V.abs -> bool) : V.abs option = +let env_find_abs (env : env) (pred : abs -> bool) : abs option = let rec lookup env = match env with | [] -> None @@ -443,16 +442,15 @@ let env_find_abs (env : env) (pred : V.abs -> bool) : V.abs option = in lookup env -let env_lookup_abs (env : env) (abs_id : V.AbstractionId.id) : V.abs = +let env_lookup_abs (env : env) (abs_id : AbstractionId.id) : abs = Option.get (env_find_abs env (fun abs -> abs.abs_id = abs_id)) (** Remove an abstraction from the context, as well as all the references to this abstraction (for instance, remove the abs id from all the parent sets of all the other abstractions). *) -let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : - env * V.abs option = - let rec remove (env : env) : env * V.abs option = +let env_remove_abs (env : env) (abs_id : AbstractionId.id) : env * abs option = + let rec remove (env : env) : env * abs option = match env with | [] -> raise (Failure "Unreachable") | EFrame :: _ -> (env, None) @@ -464,8 +462,8 @@ let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : else let env, abs_opt = remove env in (* Update the parents set *) - let parents = V.AbstractionId.Set.remove abs_id abs.parents in - (EAbs { abs with V.parents } :: env, abs_opt) + let parents = AbstractionId.Set.remove abs_id abs.parents in + (EAbs { abs with parents } :: env, abs_opt) in remove env @@ -476,9 +474,9 @@ let env_remove_abs (env : env) (abs_id : V.AbstractionId.id) : we also substitute the abstraction id wherever it is used (i.e., in the parent sets of the other abstractions). *) -let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : - env * V.abs option = - let rec update (env : env) : env * V.abs option = +let env_subst_abs (env : env) (abs_id : AbstractionId.id) (nabs : abs) : + env * abs option = + let rec update (env : env) : env * abs option = match env with | [] -> raise (Failure "Unreachable") | EFrame :: _ -> (* We're done *) (env, None) @@ -492,34 +490,34 @@ let env_subst_abs (env : env) (abs_id : V.AbstractionId.id) (nabs : V.abs) : (* Update the parents set *) let parents = abs.parents in let parents = - if V.AbstractionId.Set.mem abs_id parents then - let parents = V.AbstractionId.Set.remove abs_id parents in - V.AbstractionId.Set.add nabs.abs_id parents + if AbstractionId.Set.mem abs_id parents then + let parents = AbstractionId.Set.remove abs_id parents in + AbstractionId.Set.add nabs.abs_id parents else parents in - (EAbs { abs with V.parents } :: env, opt_abs) + (EAbs { abs with parents } :: env, opt_abs) in update env -let ctx_lookup_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : V.abs = +let ctx_lookup_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) : abs = env_lookup_abs ctx.env abs_id -let ctx_find_abs (ctx : eval_ctx) (p : V.abs -> bool) : V.abs option = +let ctx_find_abs (ctx : eval_ctx) (p : abs -> bool) : abs option = env_find_abs ctx.env p (** See the comments for {!env_remove_abs} *) -let ctx_remove_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) : - eval_ctx * V.abs option = +let ctx_remove_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) : + eval_ctx * abs option = let env, abs = env_remove_abs ctx.env abs_id in ({ ctx with env }, abs) (** See the comments for {!env_subst_abs} *) -let ctx_subst_abs (ctx : eval_ctx) (abs_id : V.AbstractionId.id) (nabs : V.abs) - : eval_ctx * V.abs option = +let ctx_subst_abs (ctx : eval_ctx) (abs_id : AbstractionId.id) (nabs : abs) : + eval_ctx * abs option = let env, abs_opt = env_subst_abs ctx.env abs_id nabs in ({ ctx with env }, abs_opt) -let ctx_set_abs_can_end (ctx : eval_ctx) (abs_id : V.AbstractionId.id) +let ctx_set_abs_can_end (ctx : eval_ctx) (abs_id : AbstractionId.id) (can_end : bool) : eval_ctx = let abs = ctx_lookup_abs ctx abs_id in let abs = { abs with can_end } in @@ -580,19 +578,19 @@ class ['self] map_eval_ctx = { ctx with env } end -let env_iter_abs (f : V.abs -> unit) (env : env) : unit = +let env_iter_abs (f : abs -> unit) (env : env) : unit = List.iter (fun (ee : env_elem) -> match ee with EBinding _ | EFrame -> () | EAbs abs -> f abs) env -let env_map_abs (f : V.abs -> V.abs) (env : env) : env = +let env_map_abs (f : abs -> abs) (env : env) : env = List.map (fun (ee : env_elem) -> match ee with EBinding _ | EFrame -> ee | EAbs abs -> EAbs (f abs)) env -let env_filter_abs (f : V.abs -> bool) (env : env) : env = +let env_filter_abs (f : abs -> bool) (env : env) : env = List.filter (fun (ee : env_elem) -> match ee with EBinding _ | EFrame -> true | EAbs abs -> f abs) diff --git a/compiler/Cps.ml b/compiler/Cps.ml index c0dd0ae2..a3c8f1e1 100644 --- a/compiler/Cps.ml +++ b/compiler/Cps.ml @@ -1,10 +1,8 @@ (** This module defines various utilities to write the interpretation functions in continuation passing style. *) -module T = Types -module V = Values -module C = Contexts -module SA = SymbolicAst +open Values +open Contexts (** TODO: change the name *) type eval_error = EPanic @@ -16,9 +14,9 @@ type statement_eval_res = | Continue of int | Return | Panic - | LoopReturn of V.loop_id + | LoopReturn of loop_id (** We reached a return statement *while inside a loop* *) - | EndEnterLoop of V.loop_id * V.typed_value V.SymbolicValueId.Map.t + | EndEnterLoop of loop_id * typed_value SymbolicValueId.Map.t (** When we enter a loop, we delegate the end of the function is synthesized with a call to the loop translation. We use this evaluation result to transmit the fact that we end evaluation @@ -27,7 +25,7 @@ type statement_eval_res = We provide the list of values for the translated loop function call (or to be more precise the input values instantiation). *) - | EndContinue of V.loop_id * V.typed_value V.SymbolicValueId.Map.t + | EndContinue of loop_id * typed_value SymbolicValueId.Map.t (** For loop translations: we end with a continue (i.e., a recursive call to the translation for the loop body). @@ -36,21 +34,21 @@ type statement_eval_res = *) [@@deriving show] -type eval_result = SA.expression option +type eval_result = SymbolicAst.expression option (** Continuation function *) -type m_fun = C.eval_ctx -> eval_result +type m_fun = eval_ctx -> eval_result (** Continuation taking another continuation as parameter *) type cm_fun = m_fun -> m_fun (** Continuation taking a typed value as parameter - TODO: use more *) -type typed_value_m_fun = V.typed_value -> m_fun +type typed_value_m_fun = typed_value -> m_fun (** Continuation taking another continuation as parameter and a typed value as parameter. *) -type typed_value_cm_fun = V.typed_value -> cm_fun +type typed_value_cm_fun = typed_value -> cm_fun (** Type of a continuation used when evaluating a statement *) type st_m_fun = statement_eval_res -> m_fun @@ -59,13 +57,13 @@ type st_m_fun = statement_eval_res -> m_fun type st_cm_fun = st_m_fun -> m_fun (** Convert a unit function to a cm function *) -let unit_to_cm_fun (f : C.eval_ctx -> unit) : cm_fun = +let unit_to_cm_fun (f : eval_ctx -> unit) : cm_fun = fun cf ctx -> f ctx; cf ctx (** *) -let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = +let update_to_cm_fun (f : eval_ctx -> eval_ctx) : cm_fun = fun cf ctx -> let ctx = f ctx in cf ctx @@ -75,10 +73,10 @@ let update_to_cm_fun (f : C.eval_ctx -> C.eval_ctx) : cm_fun = let comp (f : 'c -> 'd -> 'e) (g : ('a -> 'b) -> 'c) : ('a -> 'b) -> 'd -> 'e = fun cf ctx -> f (g cf) ctx -let comp_unit (f : cm_fun) (g : C.eval_ctx -> unit) : cm_fun = +let comp_unit (f : cm_fun) (g : eval_ctx -> unit) : cm_fun = comp f (unit_to_cm_fun g) -let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = +let comp_update (f : cm_fun) (g : eval_ctx -> eval_ctx) : cm_fun = comp f (update_to_cm_fun g) (** This is just a test, to check that {!comp} is general enough to handle a case @@ -88,8 +86,8 @@ let comp_update (f : cm_fun) (g : C.eval_ctx -> C.eval_ctx) : cm_fun = Keeping this here also makes it a good reference, when one wants to figure out the signatures he should use for such a composition. *) -let comp_ret_val (f : (V.typed_value -> m_fun) -> m_fun) - (g : m_fun -> V.typed_value -> m_fun) : cm_fun = +let comp_ret_val (f : (typed_value -> m_fun) -> m_fun) + (g : m_fun -> typed_value -> m_fun) : cm_fun = comp f g let apply (f : cm_fun) (g : m_fun) : m_fun = fun ctx -> f g ctx diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 4ce1e9f1..ae5a9a22 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1,14 +1,13 @@ (** Define base utilities for the extraction *) +open Contexts open Pure open TranslateCore -module C = Contexts -module RegionId = T.RegionId module F = Format open ExtractBuiltin (** The local logger *) -let log = L.extract_log +let log = Logging.extract_log type region_group_info = { id : RegionGroupId.id; @@ -25,11 +24,6 @@ type region_group_info = { module StringSet = Collections.StringSet module StringMap = Collections.StringMap -type name = Names.name -type type_name = Names.type_name -type global_name = Names.global_name -type fun_name = Names.fun_name - (** Characterizes a declaration. Is in particular useful to derive the proper keywords to introduce the @@ -151,7 +145,7 @@ type formatter = { Remark: can return [None] for some backends like HOL4. *) - field_name : name -> FieldId.id -> string option -> string; + field_name : llbc_name -> FieldId.id -> string option -> string; (** Inputs: - type name - field id @@ -163,12 +157,12 @@ type formatter = { access then causes trouble because not all provers accept syntax like [x.3] where [x] is a tuple. *) - variant_name : name -> string -> string; + variant_name : llbc_name -> string -> string; (** Inputs: - type name - variant name *) - struct_constructor : name -> string; + struct_constructor : llbc_name -> string; (** Structure constructors are used when constructing structure values. For instance, in F*: @@ -179,13 +173,13 @@ type formatter = { Inputs: - type name - *) - type_name : type_name -> string; + *) + type_name : llbc_name -> string; (** Provided a basename, compute a type name. *) - global_name : global_name -> string; + global_name : llbc_name -> string; (** Provided a basename, compute a global name. *) fun_name : - fun_name -> + llbc_name -> int -> LoopId.id option -> int -> @@ -213,7 +207,7 @@ type formatter = { TODO: use the fun id for the assumed functions. *) termination_measure_name : - A.FunDeclId.id -> fun_name -> int -> LoopId.id option -> string; + A.FunDeclId.id -> llbc_name -> int -> LoopId.id option -> string; (** Generates the name of the termination measure used to prove/reason about termination. The generated code uses this clause where needed, but its body must be defined by the user. @@ -225,11 +219,11 @@ type formatter = { function is an assumed function or a local function - function basename - the number of loops in the parent function. This is used for - the same purpose as in {!field:fun_name}. + the same purpose as in {!field:llbc_name}. - loop identifier, if this is for a loop *) decreases_proof_name : - A.FunDeclId.id -> fun_name -> int -> LoopId.id option -> string; + A.FunDeclId.id -> llbc_name -> int -> LoopId.id option -> string; (** Generates the name of the proof used to prove/reason about termination. The generated code uses this clause where needed, but its body must be defined by the user. @@ -241,7 +235,7 @@ type formatter = { function is an assumed function or a local function - function basename - the number of loops in the parent function. This is used for - the same purpose as in {!field:fun_name}. + the same purpose as in {!field:llbc_name}. - loop identifier, if this is for a loop *) trait_decl_name : trait_decl -> string; @@ -654,72 +648,47 @@ type extraction_ctx = { (** Same as {!types_filter_type_args_map}, but for trait implementations *) } +let extraction_ctx_to_fmt_env (ctx : extraction_ctx) : PrintPure.fmt_env = + TranslateCore.trans_ctx_to_pure_fmt_env ctx.trans_ctx + +let name_to_string (ctx : extraction_ctx) = + PrintPure.name_to_string (extraction_ctx_to_fmt_env ctx) + +let trait_decl_id_to_string (ctx : extraction_ctx) = + PrintPure.trait_decl_id_to_string (extraction_ctx_to_fmt_env ctx) + +let type_id_to_string (ctx : extraction_ctx) = + PrintPure.type_id_to_string (extraction_ctx_to_fmt_env ctx) + +let global_decl_id_to_string (ctx : extraction_ctx) = + PrintPure.global_decl_id_to_string (extraction_ctx_to_fmt_env ctx) + +let llbc_fun_id_to_string (ctx : extraction_ctx) = + PrintPure.llbc_fun_id_to_string (extraction_ctx_to_fmt_env ctx) + +let fun_id_to_string (ctx : extraction_ctx) = + PrintPure.regular_fun_id_to_string (extraction_ctx_to_fmt_env ctx) + +let adt_variant_to_string (ctx : extraction_ctx) = + PrintPure.adt_variant_to_string (extraction_ctx_to_fmt_env ctx) + +let adt_field_to_string (ctx : extraction_ctx) = + PrintPure.adt_field_to_string (extraction_ctx_to_fmt_env ctx) + (** Debugging function, used when communicating name collisions to the user, and also to print ids for internal debugging (in case of lookup miss for instance). *) let id_to_string (id : id) (ctx : extraction_ctx) : string = - let global_decls = ctx.trans_ctx.global_ctx.global_decls in - let fun_decls = ctx.trans_ctx.fun_ctx.fun_decls in - let type_decls = ctx.trans_ctx.type_ctx.type_decls in - let trait_decls = ctx.trans_ctx.trait_decls_ctx.trait_decls in let trait_decl_id_to_string (id : A.TraitDeclId.id) : string = - let trait_name = - Print.fun_name_to_string (A.TraitDeclId.Map.find id trait_decls).name - in + let trait_name = trait_decl_id_to_string ctx id in "trait_decl: " ^ trait_name ^ " (id: " ^ A.TraitDeclId.to_string id ^ ")" in - (* TODO: factorize the pretty-printing with what is in PrintPure *) - let get_type_name (id : type_id) : string = - match id with - | TAdtId id -> - let def = TypeDeclId.Map.find id type_decls in - Print.name_to_string def.name - | TAssumed aty -> show_assumed_ty aty - | TTuple -> raise (Failure "Unreachable") - in match id with - | GlobalId gid -> - let name = (A.GlobalDeclId.Map.find gid global_decls).name in - "global name: " ^ Print.global_name_to_string name - | FunId fid -> ( - match fid with - | FromLlbc (fid, lp_id, rg_id) -> - let fun_name = - match fid with - | FunId (FRegular fid) -> - Print.fun_name_to_string - (A.FunDeclId.Map.find fid fun_decls).name - | FunId (FAssumed aid) -> A.show_assumed_fun_id aid - | TraitMethod (trait_ref, method_name, _) -> - (* Shouldn't happen *) - if !Config.fail_hard then raise (Failure "Unexpected") - else - "Trait method: decl: " - ^ TraitDeclId.to_string trait_ref.trait_decl_ref.trait_decl_id - ^ ", method_name: " ^ method_name - in - - let lp_kind = - match lp_id with - | None -> "" - | Some lp_id -> "loop " ^ LoopId.to_string lp_id ^ ", " - in - - let fwd_back_kind = - match rg_id with - | None -> "forward" - | Some rg_id -> "backward " ^ RegionGroupId.to_string rg_id - in - "fun name (" ^ lp_kind ^ fwd_back_kind ^ "): " ^ fun_name - | Pure fid -> PrintPure.pure_assumed_fun_id_to_string fid) + | GlobalId gid -> global_decl_id_to_string ctx gid + | FunId fid -> fun_id_to_string ctx fid | DecreasesProofId (fid, lid) -> - let fun_name = - match fid with - | FRegular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | FAssumed aid -> A.show_assumed_fun_id aid - in + let fun_name = llbc_fun_id_to_string ctx fid in let loop = match lid with | None -> "" @@ -727,73 +696,20 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = in "decreases proof for function: " ^ fun_name ^ loop | TerminationMeasureId (fid, lid) -> - let fun_name = - match fid with - | FRegular fid -> - Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name - | FAssumed aid -> A.show_assumed_fun_id aid - in + let fun_name = llbc_fun_id_to_string ctx fid in let loop = match lid with | None -> "" | Some lid -> ", loop: " ^ LoopId.to_string lid in "termination measure for function: " ^ fun_name ^ loop - | TypeId id -> "type name: " ^ get_type_name id - | StructId id -> "struct constructor of: " ^ get_type_name id + | TypeId id -> "type name: " ^ type_id_to_string ctx id + | StructId id -> "struct constructor of: " ^ type_id_to_string ctx id | VariantId (id, variant_id) -> - let variant_name = - match id with - | TTuple -> raise (Failure "Unreachable") - | TAssumed TResult -> - if variant_id = result_return_id then "@result::Return" - else if variant_id = result_fail_id then "@result::Fail" - else raise (Failure "Unreachable") - | TAssumed TError -> - if variant_id = error_failure_id then "@error::Failure" - else if variant_id = error_out_of_fuel_id then "@error::OutOfFuel" - else raise (Failure "Unreachable") - | TAssumed TFuel -> - if variant_id = fuel_zero_id then "@fuel::0" - else if variant_id = fuel_succ_id then "@fuel::Succ" - else raise (Failure "Unreachable") - | TAssumed (TState | TArray | TSlice | TStr | TRawPtr _) -> - raise - (Failure - ("Unreachable: variant id (" - ^ VariantId.to_string variant_id - ^ ") for " ^ show_type_id id)) - | TAdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Struct _ | Opaque -> raise (Failure "Unreachable") - | Enum variants -> - let variant = VariantId.nth variants variant_id in - Print.name_to_string def.name ^ "::" ^ variant.variant_name) - in + let variant_name = adt_variant_to_string ctx id (Some variant_id) in "variant name: " ^ variant_name | FieldId (id, field_id) -> - let field_name = - match id with - | TTuple -> raise (Failure "Unreachable") - | TAssumed - ( TState | TResult | TError | TFuel | TArray | TSlice | TStr - | TRawPtr _ ) -> - (* We can't directly have access to the fields of those types *) - raise (Failure "Unreachable") - | TAdtId id -> ( - let def = TypeDeclId.Map.find id type_decls in - match def.kind with - | Enum _ | Opaque -> raise (Failure "Unreachable") - | Struct fields -> - let field = FieldId.nth fields field_id in - let field_name = - match field.field_name with - | None -> FieldId.to_string field_id - | Some name -> name - in - Print.name_to_string def.name ^ "." ^ field_name) - in + let field_name = adt_field_to_string ctx id field_id in "field name: " ^ field_name | UnknownId -> "keyword" | TypeVarId id -> "type_var_id: " ^ TypeVarId.to_string id @@ -1148,7 +1064,7 @@ let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx.fmt.decreases_proof_name def.def_id def.basename def.num_loops + ctx.fmt.decreases_proof_name def.def_id def.llbc_name def.num_loops def.loop_id in ctx_add (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx @@ -1156,7 +1072,7 @@ let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx.fmt.termination_measure_name def.def_id def.basename def.num_loops + ctx.fmt.termination_measure_name def.def_id def.llbc_name def.num_loops def.loop_id in ctx_add (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx @@ -1177,7 +1093,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : | None -> (* Not the case: "standard" registration *) let name = ctx.fmt.global_name def.name in - let body = FunId (FromLlbc (FunId (FRegular def.body_id), None, None)) in + let body = FunId (FromLlbc (FunId (FRegular def.body), None, None)) in let ctx = ctx_add decl (name ^ "_c") ctx in let ctx = ctx_add body (name ^ "_body") ctx in ctx @@ -1208,7 +1124,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) Some { id = rg_id; region_names } in (* Add the function name *) - ctx.fmt.fun_name def.basename def.num_loops def.loop_id num_rgs rg_info + ctx.fmt.fun_name def.llbc_name def.num_loops def.loop_id num_rgs rg_info (keep_fwd, num_backs) (* TODO: move to Extract *) @@ -1318,7 +1234,7 @@ let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps nm let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = - fmt.type_name def.name + fmt.type_name def.llbc_name (** Helper function: generate a suffix for a function name, i.e., generates a suffix like "_loop", "loop1", etc. to append to a function name. diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index a54ab604..db942ff0 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -4,14 +4,21 @@ TODO: there misses trait **implementations** *) -open Names open Config +open Types type simple_name = string list [@@deriving show, ord] +(* TODO: update *) let name_to_simple_name (s : name) : simple_name = - (* We simply ignore the disambiguators *) - List.filter_map (function Ident id -> Some id | Disambiguator _ -> None) s + (* We simply ignore the disambiguators - TODO: update *) + List.map + (function + | PeIdent (id, _) -> id + | PeImpl i -> + (* TODO *) + show_impl_elem i) + s (** Small helper which cuts a string at the occurrences of "::" *) let string_to_simple_name (s : string) : simple_name = diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 1f17c1aa..d6898e96 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -175,15 +175,15 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let rec analyze_decl_groups (decls : declaration_group list) : unit = match decls with | [] -> () - | (Type _ | TraitDecl _ | TraitImpl _) :: decls' -> + | (TypeGroup _ | TraitDeclGroup _ | TraitImplGroup _) :: decls' -> analyze_decl_groups decls' - | Fun decl :: decls' -> + | FunGroup decl :: decls' -> analyze_fun_decl_group decl; analyze_decl_groups decls' - | Global id :: decls' -> + | GlobalGroup id :: decls' -> (* Analyze a global by analyzing its body function *) let global = GlobalDeclId.Map.find id globals_map in - analyze_fun_decl_group (NonRec global.body_id); + analyze_fun_decl_group (NonRec global.body); analyze_decl_groups decls' in diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index e9c0f17f..5b2db90d 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -4,19 +4,22 @@ open InterpreterProjectors open InterpreterBorrows open InterpreterStatements open LlbcAstUtils -module L = Logging -module T = Types -module A = LlbcAst +open Types +open TypesUtils +open Values +open LlbcAst +open Contexts +open SynthesizeSymbolic module SA = SymbolicAst (** The local logger *) -let log = L.interpreter_log +let log = Logging.interpreter_log -let compute_contexts (m : A.crate) : C.decls_ctx = +let compute_contexts (m : crate) : decls_ctx = let type_decls_list, _, _, _, _ = split_declarations m.declarations in - let type_decls = m.types in - let fun_decls = m.functions in - let global_decls = m.globals in + let type_decls = m.type_decls in + let fun_decls = m.fun_decls in + let global_decls = m.global_decls in let trait_decls = m.trait_decls in let trait_impls = m.trait_impls in let type_decls_groups, _, _, _, _ = @@ -25,7 +28,7 @@ let compute_contexts (m : A.crate) : C.decls_ctx = let type_infos = TypesAnalysis.analyze_type_declarations type_decls type_decls_list in - let type_ctx = { C.type_decls_groups; type_decls; type_infos } in + let type_ctx = { type_decls_groups; type_decls; type_infos } in let fun_infos = FunsAnalysis.analyze_module m fun_decls global_decls !Config.use_state in @@ -33,11 +36,11 @@ let compute_contexts (m : A.crate) : C.decls_ctx = RegionsHierarchy.compute_regions_hierarchies type_decls fun_decls global_decls trait_decls trait_impls in - let fun_ctx = { C.fun_decls; fun_infos; regions_hierarchies } in - let global_ctx = { C.global_decls } in - let trait_decls_ctx = { C.trait_decls } in - let trait_impls_ctx = { C.trait_impls } in - { C.type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } + let fun_ctx = { fun_decls; fun_infos; regions_hierarchies } in + let global_ctx = { global_decls } in + let trait_decls_ctx = { trait_decls } in + let trait_impls_ctx = { trait_impls } in + { type_ctx; fun_ctx; global_ctx; trait_decls_ctx; trait_impls_ctx } (** Small helper. @@ -45,15 +48,14 @@ let compute_contexts (m : A.crate) : C.decls_ctx = to compute a normalization map (for the associated types) and that we added it in the context. *) -let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : - A.inst_fun_sig = - let { A.regions_hierarchy = _; trait_type_constraints = _; inputs; output } = +let normalize_inst_fun_sig (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = + let { regions_hierarchy = _; trait_type_constraints = _; inputs; output } = sg in let norm = AssociatedTypes.ctx_normalize_ty ctx in let inputs = List.map norm inputs in let output = norm output in - { sg with A.inputs; output } + { sg with inputs; output } (** Instantiate a function signature for a symbolic execution. @@ -65,28 +67,28 @@ let normalize_inst_fun_sig (ctx : C.eval_ctx) (sg : A.inst_fun_sig) : clauses (we are not considering a function call, so we don't need to normalize because a trait clause was instantiated with a specific trait ref). *) -let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) (kind : A.fun_kind) : - C.eval_ctx * A.inst_fun_sig = +let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) + (regions_hierarchy : region_groups) (kind : fun_kind) : + eval_ctx * inst_fun_sig = let tr_self = match kind with - | RegularKind | TraitMethodImpl _ -> T.UnknownTrait __FUNCTION__ - | TraitMethodDecl _ | TraitMethodProvided _ -> T.Self + | RegularKind | TraitMethodImpl _ -> UnknownTrait __FUNCTION__ + | TraitMethodDecl _ | TraitMethodProvided _ -> Self in let generics = - let { T.regions; types; const_generics; trait_clauses } = sg.generics in - let regions = List.map (fun _ -> T.RErased) regions in - let types = List.map (fun (v : T.type_var) -> T.TVar v.T.index) types in + let { regions; types; const_generics; trait_clauses } = sg.generics in + let regions = List.map (fun _ -> RErased) regions in + let types = List.map (fun (v : type_var) -> TVar v.index) types in let const_generics = - List.map - (fun (v : T.const_generic_var) -> T.CGVar v.T.index) - const_generics + List.map (fun (v : const_generic_var) -> CGVar v.index) const_generics in (* Annoying that we have to generate this substitution here *) let r_subst _ = raise (Failure "Unexpected region") in - let ty_subst = Subst.make_type_subst_from_vars sg.generics.types types in + let ty_subst = + Substitute.make_type_subst_from_vars sg.generics.types types + in let cg_subst = - Subst.make_const_generic_subst_from_vars sg.generics.const_generics + Substitute.make_const_generic_subst_from_vars sg.generics.const_generics const_generics in (* TODO: some clauses may use the types of other clauses, so we may have to @@ -115,39 +117,37 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) ]} *) (* We will need to update the trait refs map while we perform the instantiations *) - let mk_tr_subst (tr_map : T.trait_instance_id T.TraitClauseId.Map.t) - clause_id : T.trait_instance_id = - match T.TraitClauseId.Map.find_opt clause_id tr_map with + let mk_tr_subst (tr_map : trait_instance_id TraitClauseId.Map.t) clause_id : + trait_instance_id = + match TraitClauseId.Map.find_opt clause_id tr_map with | Some tr -> tr | None -> raise (Failure "Local trait clause not found") in let mk_subst tr_map = let tr_subst = mk_tr_subst tr_map in - { Subst.r_subst; ty_subst; cg_subst; tr_subst; tr_self } + { Substitute.r_subst; ty_subst; cg_subst; tr_subst; tr_self } in let _, trait_refs = List.fold_left_map - (fun tr_map (c : T.trait_clause) -> + (fun tr_map (c : trait_clause) -> let subst = mk_subst tr_map in - let { T.trait_id = trait_decl_id; clause_generics; _ } = c in - let generics = Subst.generic_args_substitute subst clause_generics in - let trait_decl_ref = { T.trait_decl_id; decl_generics = generics } in + let { trait_id = trait_decl_id; clause_generics; _ } = c in + let generics = + Substitute.generic_args_substitute subst clause_generics + in + let trait_decl_ref = { trait_decl_id; decl_generics = generics } in (* Note that because we directly refer to the clause, we give it empty generics *) - let trait_id = T.Clause c.clause_id in + let trait_id = Clause c.clause_id in let trait_ref = - { - T.trait_id; - generics = TypesUtils.mk_empty_generic_args; - trait_decl_ref; - } + { trait_id; generics = empty_generic_args; trait_decl_ref } in (* Update the traits map *) - let tr_map = T.TraitClauseId.Map.add c.T.clause_id trait_id tr_map in + let tr_map = TraitClauseId.Map.add c.clause_id trait_id tr_map in (tr_map, trait_ref)) - T.TraitClauseId.Map.empty trait_clauses + TraitClauseId.Map.empty trait_clauses in - { T.regions; types; const_generics; trait_refs } + { regions; types; const_generics; trait_refs } in let inst_sg = instantiate_fun_sig ctx generics tr_self sg regions_hierarchy in (* Compute the normalization maps *) @@ -173,8 +173,8 @@ let symbolic_instantiate_fun_sig (ctx : C.eval_ctx) (sg : A.fun_sig) - the list of symbolic values introduced for the input values - the instantiated function signature *) -let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) - : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = +let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : + eval_ctx * symbolic_value list * inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us * with the input values (which behave as if they had been returned @@ -192,7 +192,7 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies in let region_groups = - List.map (fun (g : T.region_group) -> g.id) regions_hierarchy + List.map (fun (g : region_group) -> g.id) regions_hierarchy in let ctx = initialize_eval_context ctx region_groups sg.generics.types @@ -206,13 +206,13 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) in (* Create fresh symbolic values for the inputs *) let input_svs = - List.map (fun ty -> mk_fresh_symbolic_value V.SynthInput ty) inst_sg.inputs + List.map (fun ty -> mk_fresh_symbolic_value SynthInput ty) inst_sg.inputs in (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) - let call_id = C.fresh_fun_call_id () in - assert (call_id = V.FunCallId.zero); - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = + let call_id = fresh_fun_call_id () in + assert (call_id = FunCallId.zero); + let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : + eval_ctx * typed_avalue list = (* Project over the values - we use *loan* projectors, as explained above *) let avalues = List.map (mk_aproj_loans_value_from_symbolic_value abs.regions) input_svs @@ -222,8 +222,8 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) let region_can_end _ = false in let ctx = create_push_abstractions_from_abs_region_groups - (fun rg_id -> V.SynthInput rg_id) - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + (fun rg_id -> SynthInput rg_id) + inst_sg.regions_hierarchy region_can_end compute_abs_avalues ctx in (* Split the variables between return var, inputs and remaining locals *) let body = Option.get fdef.body in @@ -232,12 +232,12 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) Collections.List.split_at (List.tl body.locals) body.arg_count in (* Push the return variable (initialized with ⊥) *) - let ctx = C.ctx_push_uninitialized_var ctx ret_var in + let ctx = ctx_push_uninitialized_var ctx ret_var in (* Push the input variables (initialized with symbolic values) *) let input_values = List.map mk_typed_value_from_symbolic_value input_svs in - let ctx = C.ctx_push_vars ctx (List.combine input_vars input_values) in + let ctx = ctx_push_vars ctx (List.combine input_vars input_values) in (* Push the remaining local variables (initialized with ⊥) *) - let ctx = C.ctx_push_uninitialized_vars ctx local_vars in + let ctx = ctx_push_uninitialized_vars ctx local_vars in (* Return *) (ctx, input_svs, inst_sg) @@ -253,20 +253,19 @@ let initialize_symbolic_context_for_fun (ctx : C.decls_ctx) (fdef : A.fun_decl) [inside_loop]: [true] if we are *inside* a loop (result [EndContinue]). *) -let evaluate_function_symbolic_synthesize_backward_from_return - (config : C.config) (fdef : A.fun_decl) (inst_sg : A.inst_fun_sig) - (back_id : T.RegionGroupId.id) (loop_id : V.LoopId.id option) - (is_regular_return : bool) (inside_loop : bool) (ctx : C.eval_ctx) : - SA.expression option = +let evaluate_function_symbolic_synthesize_backward_from_return (config : config) + (fdef : fun_decl) (inst_sg : inst_fun_sig) (back_id : RegionGroupId.id) + (loop_id : LoopId.id option) (is_regular_return : bool) (inside_loop : bool) + (ctx : eval_ctx) : SA.expression option = log#ldebug (lazy ("evaluate_function_symbolic_synthesize_backward_from_return:" ^ "\n- fname: " - ^ Print.fun_name_to_string fdef.name + ^ Print.EvalCtx.name_to_string ctx fdef.name ^ "\n- back_id: " - ^ T.RegionGroupId.to_string back_id + ^ RegionGroupId.to_string back_id ^ "\n- loop_id: " - ^ Print.option_to_string V.LoopId.to_string loop_id + ^ Print.option_to_string LoopId.to_string loop_id ^ "\n- is_regular_return: " ^ Print.bool_to_string is_regular_return ^ "\n- inside_loop: " @@ -294,9 +293,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return * proper order. *) let parent_rgs = list_ancestor_region_groups regions_hierarchy back_id in let parent_input_abs_ids = - T.RegionGroupId.mapi + RegionGroupId.mapi (fun rg_id rg -> - if T.RegionGroupId.Set.mem rg_id parent_rgs then Some rg.T.id else None) + if RegionGroupId.Set.mem rg_id parent_rgs then Some rg.id else None) inst_sg.regions_hierarchy in let parent_input_abs_ids = @@ -305,12 +304,12 @@ let evaluate_function_symbolic_synthesize_backward_from_return (* Insert the return value in the return abstractions (by applying * borrow projections) *) - let cf_consume_ret (ret_value : V.typed_value option) ctx = + let cf_consume_ret (ret_value : typed_value option) ctx = let ctx = if is_regular_return then ( let ret_value = Option.get ret_value in - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = + let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : + eval_ctx * typed_avalue list = let ctx, avalue = apply_proj_borrows_on_input_value config ctx abs.regions abs.ancestors_regions ret_value ret_rty @@ -324,18 +323,15 @@ let evaluate_function_symbolic_synthesize_backward_from_return * that this is important for soundness: this is part of the borrow checking). * Also see the documentation of the [can_end] field of [abs] for more * information. *) - let parent_and_current_rgs = - T.RegionGroupId.Set.add back_id parent_rgs - in + let parent_and_current_rgs = RegionGroupId.Set.add back_id parent_rgs in let region_can_end rid = - T.RegionGroupId.Set.mem rid parent_and_current_rgs + RegionGroupId.Set.mem rid parent_and_current_rgs in assert (region_can_end back_id); let ctx = create_push_abstractions_from_abs_region_groups - (fun rg_id -> V.SynthRet rg_id) - ret_inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues - ctx + (fun rg_id -> SynthRet rg_id) + ret_inst_sg.regions_hierarchy region_can_end compute_abs_avalues ctx in ctx) else ctx @@ -356,16 +352,16 @@ let evaluate_function_symbolic_synthesize_backward_from_return *) let current_abs_id, end_fun_synth_input = let fun_abs_id = - (T.RegionGroupId.nth inst_sg.regions_hierarchy back_id).id + (RegionGroupId.nth inst_sg.regions_hierarchy back_id).id in if not inside_loop then (fun_abs_id, true) else - let pred (abs : V.abs) = + let pred (abs : abs) = match abs.kind with - | V.Loop (_, rg_id', kind) -> + | Loop (_, rg_id', kind) -> let rg_id' = Option.get rg_id' in let is_ret = - match kind with V.LoopSynthInput -> true | V.LoopCall -> false + match kind with LoopSynthInput -> true | LoopCall -> false in rg_id' = back_id && is_ret | _ -> false @@ -387,24 +383,24 @@ let evaluate_function_symbolic_synthesize_backward_from_return } ]} *) - let abs = Option.get (C.ctx_find_abs ctx pred) in + let abs = Option.get (ctx_find_abs ctx pred) in (abs.abs_id, false) in log#ldebug (lazy ("evaluate_function_symbolic_synthesize_backward_from_return: ending \ input abstraction: " - ^ V.AbstractionId.to_string current_abs_id)); + ^ AbstractionId.to_string current_abs_id)); (* Set the proper abstractions as endable *) let ctx = let visit_loop_abs = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_abs _ abs = match abs.kind with - | V.Loop (loop_id', rg_id', V.LoopSynthInput) -> + | Loop (loop_id', rg_id', LoopSynthInput) -> (* We only allow to end the loop synth input abs for the region group [rg_id] *) assert ( @@ -415,11 +411,11 @@ let evaluate_function_symbolic_synthesize_backward_from_return if rg_id' = back_id && inside_loop then { abs with can_end = true } else abs - | V.Loop (loop_id', _, V.LoopCall) -> + | Loop (loop_id', _, LoopCall) -> (* We can end all the loop call abstractions *) assert (loop_id = Some loop_id'); { abs with can_end = true } - | V.SynthInput rg_id' -> + | SynthInput rg_id' -> if rg_id' = back_id && end_fun_synth_input then { abs with can_end = true } else abs @@ -456,10 +452,14 @@ let evaluate_function_symbolic_synthesize_backward_from_return for the synthesis) - the symbolic AST generated by the symbolic execution *) -let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) - (fdef : A.fun_decl) : V.symbolic_value list * SA.expression option = +let evaluate_function_symbolic (synthesize : bool) (ctx : decls_ctx) + (fdef : fun_decl) : symbolic_value list * SA.expression option = (* Debug *) - let name_to_string () = Print.fun_name_to_string fdef.A.name in + let name_to_string () = + Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env ctx) + fdef.name + in log#ldebug (lazy ("evaluate_function_symbolic: " ^ name_to_string ())); (* Create the evaluation context *) @@ -470,8 +470,8 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) in (* Create the continuation to finish the evaluation *) - let config = C.mk_config C.SymbolicMode in - let cf_finish res ctx = + let config = mk_config SymbolicMode in + let cf_finish (res : statement_eval_res) (ctx : eval_ctx) = let ctx0 = ctx in log#ldebug (lazy @@ -523,13 +523,13 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) fdef inst_sg back_id loop_id is_regular_return inside_loop ctx) in let back_el = - T.RegionGroupId.mapi + RegionGroupId.mapi (fun gid _ -> (gid, finish_back_eval gid)) regions_hierarchy in - let back_el = T.RegionGroupId.Map.of_list back_el in + let back_el = RegionGroupId.Map.of_list back_el in (* Put everything together *) - S.synthesize_forward_end ctx0 None fwd_e back_el + synthesize_forward_end ctx0 None fwd_e back_el else None | EndEnterLoop (loop_id, loop_input_values) | EndContinue (loop_id, loop_input_values) -> @@ -567,13 +567,13 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) inside_loop ctx) in let back_el = - T.RegionGroupId.mapi + RegionGroupId.mapi (fun gid _ -> (gid, finish_back_eval gid)) regions_hierarchy in - let back_el = T.RegionGroupId.Map.of_list back_el in + let back_el = RegionGroupId.Map.of_list back_el in (* Put everything together *) - S.synthesize_forward_end ctx0 (Some loop_input_values) fwd_e back_el + synthesize_forward_end ctx0 (Some loop_input_values) fwd_e back_el else None | Panic -> (* Note that as we explore all the execution branches, one of @@ -586,7 +586,7 @@ let evaluate_function_symbolic (synthesize : bool) (ctx : C.decls_ctx) (* Evaluate the function *) let symbolic = - eval_function_body config (Option.get fdef.A.body).body cf_finish ctx + eval_function_body config (Option.get fdef.body).body cf_finish ctx in (* Return *) @@ -596,29 +596,33 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment. *) - let test_unit_function (crate : A.crate) (decls_ctx : C.decls_ctx) - (fid : A.FunDeclId.id) : unit = + let test_unit_function (crate : crate) (decls_ctx : decls_ctx) + (fid : FunDeclId.id) : unit = (* Retrieve the function declaration *) - let fdef = A.FunDeclId.Map.find fid crate.functions in + let fdef = FunDeclId.Map.find fid crate.fun_decls in let body = Option.get fdef.body in (* Debug *) log#ldebug - (lazy ("test_unit_function: " ^ Print.fun_name_to_string fdef.A.name)); + (lazy + ("test_unit_function: " + ^ Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fdef.name)); (* Sanity check - *) - assert (fdef.A.signature.generics = TypesUtils.mk_empty_generic_params); - assert (body.A.arg_count = 0); + assert (fdef.signature.generics = empty_generic_params); + assert (body.arg_count = 0); (* Create the evaluation context *) let ctx = initialize_eval_context decls_ctx [] [] [] in (* Insert the (uninitialized) local variables *) - let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in + let ctx = ctx_push_uninitialized_vars ctx body.locals in (* Create the continuation to check the function's result *) - let config = C.mk_config C.ConcreteMode in - let cf_check res ctx = + let config = mk_config ConcreteMode in + let cf_check (res : statement_eval_res) (ctx : eval_ctx) = match res with | Return -> (* Ok: drop the local variables and finish *) @@ -628,7 +632,9 @@ module Test = struct raise (Failure ("Unit test failed (concrete execution) on: " - ^ Print.fun_name_to_string fdef.A.name)) + ^ Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fdef.name)) in (* Evaluate the function *) @@ -637,21 +643,21 @@ module Test = struct (** Small helper: return true if the function is a *transparent* unit function (no parameters, no arguments) - TODO: move *) - let fun_decl_is_transparent_unit (def : A.fun_decl) : bool = + let fun_decl_is_transparent_unit (def : fun_decl) : bool = Option.is_some def.body - && def.A.signature.generics = TypesUtils.mk_empty_generic_params - && def.A.signature.inputs = [] + && def.signature.generics = empty_generic_params + && def.signature.inputs = [] (** Test all the unit functions in a list of function definitions *) - let test_unit_functions (crate : A.crate) : unit = + let test_unit_functions (crate : crate) : unit = let unit_funs = - A.FunDeclId.Map.filter + FunDeclId.Map.filter (fun _ -> fun_decl_is_transparent_unit) - crate.functions + crate.fun_decls in let decls_ctx = compute_contexts crate in - let test_unit_fun _ (def : A.fun_decl) : unit = - test_unit_function crate decls_ctx def.A.def_id + let test_unit_fun _ (def : fun_decl) : unit = + test_unit_function crate decls_ctx def.def_id in - A.FunDeclId.Map.iter test_unit_fun unit_funs + FunDeclId.Map.iter test_unit_fun unit_funs end diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 566061c2..8c9c0e72 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1,9 +1,6 @@ -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -module S = SynthesizeSymbolic +open Types +open Values +open Contexts open Cps open ValuesUtils open TypesUtils @@ -12,11 +9,11 @@ open InterpreterBorrowsCore open InterpreterProjectors (** The local logger *) -let log = L.borrows_log +let log = Logging.borrows_log (** Auxiliary function to end borrows: lookup a borrow in the environment, update it (by returning an updated environment where the borrow has been - replaced by {!V.Bottom})) if we can end the borrow (for instance, it is not + replaced by {!Bottom})) if we can end the borrow (for instance, it is not an outer borrow...) or return the reason why we couldn't update the borrow. [end_borrow_aux] then simply performs a loop: as long as we need to end (outer) @@ -32,18 +29,18 @@ let log = L.borrows_log loans. This is used to merge borrows with abstractions, to compute loop fixed points for instance. *) -let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) - (allow_inner_loans : bool) (l : V.BorrowId.id) (ctx : C.eval_ctx) : - ( C.eval_ctx * (V.AbstractionId.id option * g_borrow_content) option, +let end_borrow_get_borrow (allowed_abs : AbstractionId.id option) + (allow_inner_loans : bool) (l : BorrowId.id) (ctx : eval_ctx) : + ( eval_ctx * (AbstractionId.id option * g_borrow_content) option, priority_borrows_or_abs ) result = (* We use a reference to communicate the kind of borrow we found, if we * find one *) - let replaced_bc : (V.AbstractionId.id option * g_borrow_content) option ref = + let replaced_bc : (AbstractionId.id option * g_borrow_content) option ref = ref None in - let set_replaced_bc (abs_id : V.AbstractionId.id option) - (bc : g_borrow_content) = + let set_replaced_bc (abs_id : AbstractionId.id option) (bc : g_borrow_content) + = assert (Option.is_none !replaced_bc); replaced_bc := Some (abs_id, bc) in @@ -52,8 +49,8 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) * - if we are inside an abstraction * - there are inner loans * this exception is caught in a wrapper function *) - let raise_if_priority (outer : V.AbstractionId.id option * borrow_ids option) - (borrowed_value : V.typed_value option) = + let raise_if_priority (outer : AbstractionId.id option * borrow_ids option) + (borrowed_value : typed_value option) = (* First, look for outer borrows or abstraction *) let outer_abs, outer_borrows = outer in (match outer_abs with @@ -88,12 +85,12 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) (* The environment is used to keep track of the outer loans *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** We reimplement {!visit_Loan} because we may have to update the outer borrows *) - method! visit_VLoan - (outer : V.AbstractionId.id option * borrow_ids option) lc = + method! visit_VLoan (outer : AbstractionId.id option * borrow_ids option) + lc = match lc with | VMutLoan bid -> VLoan (super#visit_VMutLoan outer bid) | VSharedLoan (bids, v) -> @@ -228,7 +225,7 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) let outer_abs, outer_borrows = outer in assert (Option.is_none outer_abs); assert (Option.is_none outer_borrows); - let outer = (Some abs.V.abs_id, None) in + let outer = (Some abs.abs_id, None) in super#visit_abs outer abs end in @@ -247,15 +244,15 @@ let end_borrow_get_borrow (allowed_abs : V.AbstractionId.id option) give the value back. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_value (config : C.config) (bid : V.BorrowId.id) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = +let give_back_value (config : config) (bid : BorrowId.id) (nv : typed_value) + (ctx : eval_ctx) : eval_ctx = (* Sanity check *) assert (not (loans_in_value nv)); assert (not (bottom_in_value ctx.ended_regions nv)); (* Debug *) log#ldebug (lazy - ("give_back_value:\n- bid: " ^ V.BorrowId.to_string bid ^ "\n- value: " + ("give_back_value:\n- bid: " ^ BorrowId.to_string bid ^ "\n- value: " ^ typed_value_to_string ctx nv ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* We use a reference to check that we updated exactly one loan *) @@ -274,17 +271,17 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* The visitor to give back the values *) let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** This is a bit annoying, but as we need the type of the value we are exploring, for sanity checks, we need to implement {!visit_typed_avalue} instead of overriding {!visit_ALoan} *) - method! visit_typed_value opt_abs (v : V.typed_value) : V.typed_value = - match v.V.value with + method! visit_typed_value opt_abs (v : typed_value) : typed_value = + match v.value with | VLoan lc -> - let value = self#visit_typed_Loan opt_abs v.V.ty lc in - ({ v with V.value } : V.typed_value) + let value = self#visit_typed_Loan opt_abs v.ty lc in + ({ v with value } : typed_value) | _ -> super#visit_typed_value opt_abs v method visit_typed_Loan opt_abs ty lc = @@ -301,8 +298,8 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) if nv.ty <> expected_ty then ( log#serror ("give_back_value: improper type:\n- expected: " - ^ PA.ty_to_string ctx ty ^ "\n- received: " - ^ PA.ty_to_string ctx nv.ty); + ^ ty_to_string ctx ty ^ "\n- received: " + ^ ty_to_string ctx nv.ty); raise (Failure "Value given back doesn't have the proper type")); (* Replace *) set_replaced (); @@ -313,26 +310,25 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) are exploring, in order to be able to project the value we give back, we need to reimplement {!visit_typed_avalue} instead of {!visit_ALoan} *) - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) + method! visit_typed_avalue opt_abs (av : typed_avalue) : typed_avalue = + match av.value with + | ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.ty lc in + ({ av with value } : typed_avalue) | _ -> super#visit_typed_avalue opt_abs av (** We need to inspect ignored mutable borrows, to insert loan projectors if necessary. *) - method! visit_ABorrow (opt_abs : V.abs option) (bc : V.aborrow_content) - : V.avalue = + method! visit_ABorrow (opt_abs : abs option) (bc : aborrow_content) + : avalue = match bc with - | V.AIgnoredMutBorrow (bid', child) -> + | AIgnoredMutBorrow (bid', child) -> if bid' = Some bid then (* Insert a loans projector - note that if this case happens, * it is necessarily because we ended a parent abstraction, * and the given back value is thus a symbolic value *) - match nv.V.value with + match nv.value with | VSymbolic sv -> let abs = Option.get opt_abs in (* Remember the given back value as a meta-value @@ -346,26 +342,26 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* Continue giving back in the child value *) let child = super#visit_typed_avalue opt_abs child in (* Return *) - V.ABorrow - (V.AEndedIgnoredMutBorrow + ABorrow + (AEndedIgnoredMutBorrow { given_back; child; given_back_meta }) | _ -> raise (Failure "Unreachable") else (* Continue exploring *) - V.ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) + ABorrow (super#visit_AIgnoredMutBorrow opt_abs bid' child) | _ -> (* Continue exploring *) super#visit_ABorrow opt_abs bc (** We are not specializing an already existing method, but adding a new method (for projections, we need type information) *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = + method visit_typed_ALoan (opt_abs : abs option) (ty : rty) + (lc : aloan_content) : avalue = (* Preparing a bit *) let regions, ancestors_regions = match opt_abs with | None -> raise (Failure "Unreachable") - | Some abs -> (abs.V.regions, abs.V.ancestors_regions) + | Some abs -> (abs.regions, abs.ancestors_regions) in (* Rk.: there is a small issue with the types of the aloan values. * See the comment at the level of definition of {!typed_avalue} *) @@ -443,13 +439,13 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) apply_registered_reborrows ctx (** Give back a *modified* symbolic value. *) -let give_back_symbolic_value (_config : C.config) - (proj_regions : T.RegionId.Set.t) (proj_ty : T.rty) (sv : V.symbolic_value) - (nsv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = +let give_back_symbolic_value (_config : config) (proj_regions : RegionId.Set.t) + (proj_ty : rty) (sv : symbolic_value) (nsv : symbolic_value) + (ctx : eval_ctx) : eval_ctx = (* Sanity checks *) assert (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty); (match nsv.sv_kind with - | V.SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack + | SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> () | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate @@ -458,13 +454,13 @@ let give_back_symbolic_value (_config : C.config) (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in (* Substitution function, to replace the borrow projectors over symbolic values *) - let subst (_abs : V.abs) local_given_back = + let subst (_abs : abs) local_given_back = (* See the below comments: there is something wrong here *) let _ = raise Utils.Unimplemented in (* Compute the projection over the given back value *) let child_proj = match nsv.sv_kind with - | V.SynthRetGivenBack -> + | SynthRetGivenBack -> (* The given back value comes from the return value of the function we are currently synthesizing (as it is given back, it means we ended one of the regions appearing in the signature: we are @@ -472,8 +468,8 @@ let give_back_symbolic_value (_config : C.config) As we don't allow borrow overwrites on returned value, we can (and MUST) forget the borrows *) - V.AIgnoredProjBorrows - | V.FunCallGivenBack -> + AIgnoredProjBorrows + | FunCallGivenBack -> (* TODO: there is something wrong here. Consider this: {[ @@ -486,16 +482,16 @@ let give_back_symbolic_value (_config : C.config) borrow in the type [&'a mut T] was ended: we give back a value of type [T]! We thus *mustn't* introduce a projector here. *) - V.AProjBorrows (nsv, sv.V.sv_ty) + AProjBorrows (nsv, sv.sv_ty) | _ -> raise (Failure "Unreachable") in - V.AProjLoans (sv, (mv, child_proj) :: local_given_back) + AProjLoans (sv, (mv, child_proj) :: local_given_back) in update_intersecting_aproj_loans proj_regions proj_ty sv subst ctx (** Auxiliary function to end borrows. See {!give_back}. - This function is similar to {!give_back_value} but gives back an {!V.avalue} + This function is similar to {!give_back_value} but gives back an {!avalue} (coming from an abstraction). It is used when ending a borrow inside an abstraction, when the corresponding @@ -504,11 +500,10 @@ let give_back_symbolic_value (_config : C.config) REMARK: this function can't be used to give back the values borrowed by end abstraction when ending this abstraction. When doing this, we need - to convert the {!V.avalue} to a {!type:V.value} by introducing the proper symbolic values. + to convert the {!avalue} to a {!type:value} by introducing the proper symbolic values. *) -let give_back_avalue_to_same_abstraction (_config : C.config) - (bid : V.BorrowId.id) (nv : V.typed_avalue) (nsv : V.typed_value) - (ctx : C.eval_ctx) : C.eval_ctx = +let give_back_avalue_to_same_abstraction (_config : config) (bid : BorrowId.id) + (nv : typed_avalue) (nsv : typed_value) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -517,7 +512,7 @@ let give_back_avalue_to_same_abstraction (_config : C.config) in let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** This is a bit annoying, but as we need the type of the avalue we are exploring, in order to be able to project the value we give @@ -527,12 +522,11 @@ let give_back_avalue_to_same_abstraction (_config : C.config) TODO: it is possible to do this by remembering the type of the last typed avalue we entered. *) - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) + method! visit_typed_avalue opt_abs (av : typed_avalue) : typed_avalue = + match av.value with + | ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.ty lc in + ({ av with value } : typed_avalue) | _ -> super#visit_typed_avalue opt_abs av (** We are not specializing an already existing method, but adding a @@ -541,21 +535,21 @@ let give_back_avalue_to_same_abstraction (_config : C.config) TODO: it is possible to do this by remembering the type of the last typed avalue we entered. *) - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = + method visit_typed_ALoan (opt_abs : abs option) (ty : rty) + (lc : aloan_content) : avalue = match lc with - | V.AMutLoan (bid', child) -> + | AMutLoan (bid', child) -> if bid' = bid then ( (* Sanity check - about why we need to call {!ty_get_ref} * (and don't do the same thing as in {!give_back_value}) * see the comment at the level of the definition of * {!typed_avalue} *) let _, expected_ty, _ = ty_get_ref ty in - if nv.V.ty <> expected_ty then ( + if nv.ty <> expected_ty then ( log#serror ("give_back_avalue_to_same_abstraction: improper type:\n\ - - expected: " ^ PA.ty_to_string ctx ty ^ "\n- received: " - ^ PA.ty_to_string ctx nv.V.ty); + - expected: " ^ ty_to_string ctx ty ^ "\n- received: " + ^ ty_to_string ctx nv.ty); raise (Failure "Value given back doesn't have the proper type")); (* This is the loan we are looking for: apply the projection to * the value we give back and replaced this mutable loan with @@ -563,18 +557,17 @@ let give_back_avalue_to_same_abstraction (_config : C.config) (* Register the insertion *) set_replaced (); (* Return the new value *) - V.ALoan - (V.AEndedMutLoan - { given_back = nv; child; given_back_meta = nsv })) + ALoan + (AEndedMutLoan { given_back = nv; child; given_back_meta = nsv })) else (* Continue exploring *) super#visit_ALoan opt_abs lc - | V.ASharedLoan (_, _, _) + | ASharedLoan (_, _, _) (* We are giving back a value to a *mutable* loan: nothing special to do *) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> (* Nothing special to do *) super#visit_ALoan opt_abs lc - | V.AIgnoredMutLoan (bid_opt, child) -> + | AIgnoredMutLoan (bid_opt, child) -> (* This loan is ignored, but we may have to project on a subvalue * of the value which is given back *) if bid_opt = Some bid then ( @@ -583,14 +576,14 @@ let give_back_avalue_to_same_abstraction (_config : C.config) * we don't register the fact that we inserted the value somewhere * (i.e., we don't call {!set_replaced}) *) (* Sanity check *) - assert (nv.V.ty = ty); - V.ALoan - (V.AEndedIgnoredMutLoan + assert (nv.ty = ty); + ALoan + (AEndedIgnoredMutLoan { given_back = nv; child; given_back_meta = nsv })) else super#visit_ALoan opt_abs lc - | V.AEndedIgnoredMutLoan + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Nothing special to do *) super#visit_ALoan opt_abs lc end @@ -612,8 +605,7 @@ let give_back_avalue_to_same_abstraction (_config : C.config) we update. TODO: this was not the case before, so some sanity checks are not useful anymore. *) -let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : - C.eval_ctx = +let give_back_shared _config (bid : BorrowId.id) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we updated exactly one loan *) let replaced : bool ref = ref false in let set_replaced () = @@ -622,21 +614,20 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : in let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_VLoan opt_abs lc = match lc with | VSharedLoan (bids, shared_value) -> - if V.BorrowId.Set.mem bid bids then ( + if BorrowId.Set.mem bid bids then ( (* This is the loan we are looking for *) set_replaced (); (* If there remains exactly one borrow identifier, we need * to end the loan. Otherwise, we just remove the current * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value + if BorrowId.Set.cardinal bids = 1 then shared_value.value else - VLoan - (VSharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) + VLoan (VSharedLoan (BorrowId.Set.remove bid bids, shared_value))) else (* Not the loan we are looking for: continue exploring *) VLoan (super#visit_VSharedLoan opt_abs bids shared_value) @@ -650,18 +641,18 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : (* Nothing special to do (we are giving back a *shared* borrow) *) ALoan (super#visit_AMutLoan opt_abs bid av) | ASharedLoan (bids, shared_value, child) -> - if V.BorrowId.Set.mem bid bids then ( + if BorrowId.Set.mem bid bids then ( (* This is the loan we are looking for *) set_replaced (); (* If there remains exactly one borrow identifier, we need * to end the loan. Otherwise, we just remove the current * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then + if BorrowId.Set.cardinal bids = 1 then ALoan (AEndedSharedLoan (shared_value, child)) else ALoan (ASharedLoan - (V.BorrowId.Set.remove bid bids, shared_value, child))) + (BorrowId.Set.remove bid bids, shared_value, child))) else (* Not the loan we are looking for: continue exploring *) super#visit_ALoan opt_abs lc @@ -692,8 +683,8 @@ let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : to an environment by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) - (ctx : C.eval_ctx) : C.eval_ctx = +let reborrow_shared (original_bid : BorrowId.id) (new_bid : BorrowId.id) + (ctx : eval_ctx) : eval_ctx = (* Keep track of changes *) let r = ref false in let set_ref () = @@ -703,24 +694,24 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) let obj = object - inherit [_] C.map_env as super + inherit [_] map_env as super method! visit_VSharedLoan env bids sv = (* Shared loan: check if the borrow id we are looking for is in the set of borrow ids. If yes, insert the new borrow id, otherwise explore inside the shared value *) - if V.BorrowId.Set.mem original_bid bids then ( + if BorrowId.Set.mem original_bid bids then ( set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in + let bids' = BorrowId.Set.add new_bid bids in VSharedLoan (bids', sv)) else super#visit_VSharedLoan env bids sv method! visit_ASharedLoan env bids v av = (* This case is similar to the {!SharedLoan} case *) - if V.BorrowId.Set.mem original_bid bids then ( + if BorrowId.Set.mem original_bid bids then ( set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.ASharedLoan (bids', v, av)) + let bids' = BorrowId.Set.add new_bid bids in + ASharedLoan (bids', v, av)) else super#visit_ASharedLoan env bids v av end in @@ -730,11 +721,11 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) assert !r; { ctx with env } -(** Convert an {!type:V.avalue} to a {!type:V.value}. +(** Convert an {!type:avalue} to a {!type:value}. This function is used when ending abstractions: whenever we end a borrow - in an abstraction, we converted the borrowed {!V.avalue} to a fresh symbolic - {!type:V.value}, then give back this {!type:V.value} to the context. + in an abstraction, we converted the borrowed {!avalue} to a fresh symbolic + {!type:value}, then give back this {!type:value} to the context. Note that some regions may have ended in the symbolic value we generate. For instance, consider the following function signature: @@ -746,19 +737,19 @@ let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) be expanded (because expanding this symbolic value would require expanding a reference whose region has already ended). *) -let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) - (av : V.typed_avalue) : V.symbolic_value = +let convert_avalue_to_given_back_value (abs_kind : abs_kind) (av : typed_avalue) + : symbolic_value = let sv_kind = match abs_kind with - | V.FunCall _ -> V.FunCallGivenBack - | V.SynthRet _ -> V.SynthRetGivenBack - | V.SynthInput _ -> V.SynthInputGivenBack - | V.Loop _ -> V.LoopGivenBack - | V.Identity -> + | FunCall _ -> FunCallGivenBack + | SynthRet _ -> SynthRetGivenBack + | SynthInput _ -> SynthInputGivenBack + | Loop _ -> LoopGivenBack + | Identity -> (* Identity abstractions give back nothing *) raise (Failure "Unreachable") in - mk_fresh_symbolic_value sv_kind av.V.ty + mk_fresh_symbolic_value sv_kind av.ty (** Auxiliary function: see {!end_borrow_aux}. @@ -776,9 +767,8 @@ let convert_avalue_to_given_back_value (abs_kind : V.abs_kind) borrows. This kind of internal reshuffling. should be similar to ending abstractions (it is tantamount to ending *sub*-abstractions). *) -let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) - (l : V.BorrowId.id) (bc : g_borrow_content) (ctx : C.eval_ctx) : C.eval_ctx - = +let give_back (config : config) (abs_id_opt : AbstractionId.id option) + (l : BorrowId.id) (bc : g_borrow_content) (ctx : eval_ctx) : eval_ctx = (* Debug *) log#ldebug (lazy @@ -787,7 +777,7 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) | Concrete bc -> borrow_content_to_string ctx bc | Abstract bc -> aborrow_content_to_string ctx bc in - "give_back:\n- bid: " ^ V.BorrowId.to_string l ^ "\n- content: " ^ bc + "give_back:\n- bid: " ^ BorrowId.to_string l ^ "\n- content: " ^ bc ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* This is used for sanity checks *) let sanity_ek = @@ -820,7 +810,7 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) which takes care of ending *sub*-abstractions. *) let abs_id = Option.get abs_id_opt in - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in let sv = convert_avalue_to_given_back_value abs.kind av in (* Update the context *) give_back_avalue_to_same_abstraction config l av @@ -843,16 +833,16 @@ let give_back (config : C.config) (abs_id_opt : V.AbstractionId.id option) | AEndedSharedBorrow ) -> raise (Failure "Unreachable") -let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) - (ctx0 : C.eval_ctx) : cm_fun = - let check_disappeared (ctx : C.eval_ctx) : unit = +let check_borrow_disappeared (fun_name : string) (l : BorrowId.id) + (ctx0 : eval_ctx) : cm_fun = + let check_disappeared (ctx : eval_ctx) : unit = let _ = match lookup_borrow_opt ek_all l ctx with | None -> () (* Ok *) | Some _ -> log#lerror (lazy - (fun_name ^ ": " ^ V.BorrowId.to_string l + (fun_name ^ ": " ^ BorrowId.to_string l ^ ": borrow didn't disappear:\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx)); @@ -863,7 +853,7 @@ let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) | Some _ -> log#lerror (lazy - (fun_name ^ ": " ^ V.BorrowId.to_string l + (fun_name ^ ": " ^ BorrowId.to_string l ^ ": loan didn't disappear:\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx)); @@ -892,8 +882,8 @@ let check_borrow_disappeared (fun_name : string) (l : V.BorrowId.id) perform anything smart and is trusted, and another function for the book-keeping. *) -let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) : cm_fun = +let rec end_borrow_aux (config : config) (chain : borrow_or_abs_ids) + (allowed_abs : AbstractionId.id option) (l : BorrowId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain0 = chain in @@ -902,7 +892,7 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) in log#ldebug (lazy - ("end borrow: " ^ V.BorrowId.to_string l ^ ":\n- original context:\n" + ("end borrow: " ^ BorrowId.to_string l ^ ":\n- original context:\n" ^ eval_ctx_to_string ctx)); (* Utility function for the sanity checks: check that the borrow disappeared @@ -928,7 +918,7 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) (* Debug *) log#ldebug (lazy - ("end borrow: " ^ V.BorrowId.to_string l + ("end borrow: " ^ BorrowId.to_string l ^ ": found outer borrows/abs or inner loans:" ^ show_priority_borrows_or_abs priority)); (* End the priority borrows, abstractions, then try again to end the target @@ -978,20 +968,19 @@ let rec end_borrow_aux (config : C.config) (chain : borrow_or_abs_ids) (* Do a sanity check and continue *) cf_check cf ctx -and end_borrows_aux (config : C.config) (chain : borrow_or_abs_ids) - (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) : cm_fun - = +and end_borrows_aux (config : config) (chain : borrow_or_abs_ids) + (allowed_abs : AbstractionId.id option) (lset : BorrowId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the borrow ids, * so that we actually end from the smallest id to the highest id - just * a matter of taste, and may make debugging easier *) - let ids = V.BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in + let ids = BorrowId.Set.fold (fun id ids -> id :: ids) lset [] in List.fold_left (fun cf id -> end_borrow_aux config chain allowed_abs id cf) cf ids -and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = +and end_abstraction_aux (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Check that we don't loop *) let chain = @@ -1002,11 +991,11 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ AbstractionId.to_string abs_id ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0)); (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in (* Check that we can end the abstraction *) if abs.can_end then () @@ -1014,7 +1003,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) raise (Failure ("Can't end abstraction " - ^ V.AbstractionId.to_string abs.abs_id + ^ AbstractionId.to_string abs.abs_id ^ " as it is set as non-endable")); (* End the parent abstractions first *) @@ -1024,7 +1013,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ AbstractionId.to_string abs_id ^ "\n- context after parent abstractions ended:\n" ^ eval_ctx_to_string ctx))) in @@ -1036,7 +1025,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ AbstractionId.to_string abs_id ^ "\n- context after loans ended:\n" ^ eval_ctx_to_string ctx))) in @@ -1048,9 +1037,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) * changes... *) let cc = comp_update cc (fun ctx -> - let ended_regions = - T.RegionId.Set.union ctx.ended_regions abs.V.regions - in + let ended_regions = RegionId.Set.union ctx.ended_regions abs.regions in { ctx with ended_regions }) in @@ -1065,7 +1052,7 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_aux: " - ^ V.AbstractionId.to_string abs_id + ^ AbstractionId.to_string abs_id ^ "\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx))) in @@ -1076,22 +1063,22 @@ and end_abstraction_aux (config : C.config) (chain : borrow_or_abs_ids) (* Apply the continuation *) cc cf ctx -and end_abstractions_aux (config : C.config) (chain : borrow_or_abs_ids) - (abs_ids : V.AbstractionId.Set.t) : cm_fun = +and end_abstractions_aux (config : config) (chain : borrow_or_abs_ids) + (abs_ids : AbstractionId.Set.t) : cm_fun = fun cf -> (* This is not necessary, but we prefer to reorder the abstraction ids, * so that we actually end from the smallest id to the highest id - just * a matter of taste, and may make debugging easier *) - let abs_ids = V.AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in + let abs_ids = AbstractionId.Set.fold (fun id ids -> id :: ids) abs_ids [] in List.fold_left (fun cf id -> end_abstraction_aux config chain id cf) cf abs_ids -and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = +and end_abstraction_loans (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in (* End the first loan we find. * * We ignore the "ignored mut/shared loans": as we should have already ended @@ -1121,12 +1108,12 @@ and end_abstraction_loans (config : C.config) (chain : borrow_or_abs_ids) (* Continue *) cc cf ctx -and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) : cm_fun = +and end_abstraction_borrows (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> log#ldebug (lazy - ("end_abstraction_borrows: abs_id: " ^ V.AbstractionId.to_string abs_id)); + ("end_abstraction_borrows: abs_id: " ^ AbstractionId.to_string abs_id)); (* Note that the abstraction mustn't contain any loans *) (* We end the borrows, starting with the *inner* ones. This is important when considering nested borrows which have the same lifetime. @@ -1146,7 +1133,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) *) let obj = object - inherit [_] V.iter_abs as super + inherit [_] iter_abs as super method! visit_aborrow_content env bc = (* In-depth exploration *) @@ -1154,29 +1141,27 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) (* No exception was raise: we can raise an exception for the * current borrow *) match bc with - | V.AMutBorrow _ | V.ASharedBorrow _ -> + | AMutBorrow _ | ASharedBorrow _ -> (* Raise an exception *) raise (FoundABorrowContent bc) - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> (* Raise an exception only if the asb contains borrows *) if List.exists - (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) + (fun x -> match x with AsbBorrow _ -> true | _ -> false) asb then raise (FoundABorrowContent bc) else () - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + | AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ + | AEndedSharedBorrow -> (* Nothing to do for ignored borrows *) () method! visit_aproj env sproj = (match sproj with - | V.AProjLoans _ -> raise (Failure "Unexpected") - | V.AProjBorrows (sv, proj_ty) -> - raise (FoundAProjBorrows (sv, proj_ty)) - | V.AEndedProjLoans _ | V.AEndedProjBorrows _ | V.AIgnoredProjBorrows -> - ()); + | AProjLoans _ -> raise (Failure "Unexpected") + | AProjBorrows (sv, proj_ty) -> raise (FoundAProjBorrows (sv, proj_ty)) + | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj env sproj (** We may need to end borrows in "regular" values, because of shared values *) @@ -1187,7 +1172,7 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) end in (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in try (* Explore the abstraction, looking for borrows *) obj#visit_abs () abs; @@ -1202,37 +1187,37 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) ^ aborrow_content_to_string ctx bc)); let ctx = match bc with - | V.AMutBorrow (bid, av) -> + | AMutBorrow (bid, av) -> (* First, convert the avalue to a (fresh symbolic) value *) let sv = convert_avalue_to_given_back_value abs.kind av in (* Replace the mut borrow to register the fact that we ended * it and store with it the freshly generated given back value *) - let ended_borrow = V.ABorrow (V.AEndedMutBorrow (sv, av)) in + let ended_borrow = ABorrow (AEndedMutBorrow (sv, av)) in let ctx = update_aborrow ek_all bid ended_borrow ctx in (* Give the value back *) let sv = mk_typed_value_from_symbolic_value sv in give_back_value config bid sv ctx - | V.ASharedBorrow bid -> + | ASharedBorrow bid -> (* Replace the shared borrow to account for the fact it ended *) - let ended_borrow = V.ABorrow V.AEndedSharedBorrow in + let ended_borrow = ABorrow AEndedSharedBorrow in let ctx = update_aborrow ek_all bid ended_borrow ctx in (* Give back *) give_back_shared config bid ctx - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> (* Retrieve the borrow ids *) let bids = List.filter_map (fun asb -> match asb with - | V.AsbBorrow bid -> Some bid - | V.AsbProjReborrows (_, _) -> None) + | AsbBorrow bid -> Some bid + | AsbProjReborrows (_, _) -> None) asb in (* There should be at least one borrow identifier in the set, which we * can use to identify the whole set *) let repr_bid = List.hd bids in (* Replace the shared borrow with Bottom *) - let ctx = update_aborrow ek_all repr_bid V.ABottom ctx in + let ctx = update_aborrow ek_all repr_bid ABottom ctx in (* Give back the shared borrows *) let ctx = List.fold_left @@ -1241,8 +1226,8 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) in (* Continue *) ctx - | V.AEndedMutBorrow _ | V.AIgnoredMutBorrow _ - | V.AEndedIgnoredMutBorrow _ | V.AEndedSharedBorrow -> + | AEndedMutBorrow _ | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ + | AEndedSharedBorrow -> raise (Failure "Unexpected") in (* Reexplore *) @@ -1252,11 +1237,11 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) log#ldebug (lazy ("end_abstraction_borrows: found aproj borrows: " - ^ aproj_to_string ctx (V.AProjBorrows (sv, proj_ty)))); + ^ aproj_to_string ctx (AProjBorrows (sv, proj_ty)))); (* Generate a fresh symbolic value *) - let nsv = mk_fresh_symbolic_value V.FunCallGivenBack proj_ty in + let nsv = mk_fresh_symbolic_value FunCallGivenBack proj_ty in (* Replace the proj_borrows - there should be exactly one *) - let ended_borrow = V.AEndedProjBorrows nsv in + let ended_borrow = AEndedProjBorrows nsv in let ctx = update_aproj_borrows abs.abs_id sv ended_borrow ctx in (* Give back the symbolic value *) let ctx = @@ -1299,15 +1284,15 @@ and end_abstraction_borrows (config : C.config) (chain : borrow_or_abs_ids) end_abstraction_borrows config chain abs_id cf ctx (** Remove an abstraction from the context, as well as all its references *) -and end_abstraction_remove_from_context (_config : C.config) - (abs_id : V.AbstractionId.id) : cm_fun = +and end_abstraction_remove_from_context (_config : config) + (abs_id : AbstractionId.id) : cm_fun = fun cf ctx -> - let ctx, abs = C.ctx_remove_abs ctx abs_id in + let ctx, abs = ctx_remove_abs ctx abs_id in let abs = Option.get abs in (* Apply the continuation *) let expr = cf ctx in (* Synthesize the symbolic AST *) - S.synthesize_end_abstraction ctx abs expr + SynthesizeSymbolic.synthesize_end_abstraction ctx abs expr (** End a proj_loan over a symbolic value by ending the proj_borrows which intersect this proj_loans. @@ -1323,9 +1308,9 @@ and end_abstraction_remove_from_context (_config : C.config) intersecting proj_borrows, either in the concrete context or in an abstraction *) -and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) - (abs_id : V.AbstractionId.id) (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) : cm_fun = +and end_proj_loans_symbolic (config : config) (chain : borrow_or_abs_ids) + (abs_id : AbstractionId.id) (regions : RegionId.Set.t) (sv : symbolic_value) + : cm_fun = fun cf ctx -> (* Small helpers for sanity checks *) let check ctx = no_aproj_over_symbolic_in_context sv ctx in @@ -1382,8 +1367,8 @@ and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) let abs_ids = List.map fst external_projs in let abs_ids = List.fold_left - (fun s id -> V.AbstractionId.Set.add id s) - V.AbstractionId.Set.empty abs_ids + (fun s id -> AbstractionId.Set.add id s) + AbstractionId.Set.empty abs_ids in (* End the abstractions and continue *) end_abstractions_aux config chain abs_ids cf ctx @@ -1426,7 +1411,7 @@ and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) *) (* End the projector of borrows - TODO: not completely sure what to * replace it with... Maybe we should introduce an ABottomProj? *) - let ctx = update_aproj_borrows abs_id sv V.AIgnoredProjBorrows ctx in + let ctx = update_aproj_borrows abs_id sv AIgnoredProjBorrows ctx in (* Sanity check: no other occurrence of an intersecting projector of borrows *) assert ( Option.is_none @@ -1449,9 +1434,9 @@ and end_proj_loans_symbolic (config : C.config) (chain : borrow_or_abs_ids) (* Continue *) cc cf ctx -let end_borrow config : V.BorrowId.id -> cm_fun = end_borrow_aux config [] None +let end_borrow config : BorrowId.id -> cm_fun = end_borrow_aux config [] None -let end_borrows config : V.BorrowId.Set.t -> cm_fun = +let end_borrows config : BorrowId.Set.t -> cm_fun = end_borrows_aux config [] None let end_abstraction config = end_abstraction_aux config [] @@ -1478,20 +1463,20 @@ let end_abstractions_no_synth config ids ctx = The returned value (previously shared) is checked: - it mustn't contain loans - - it mustn't contain {!V.Bottom} + - it mustn't contain {!Bottom} - it mustn't contain reserved borrows TODO: this kind of checks should be put in an auxiliary helper, because they are redundant. The loan to update mustn't be a borrowed value. *) -let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) - (cf : V.typed_value -> m_fun) : m_fun = +let promote_shared_loan_to_mut_loan (l : BorrowId.id) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy - ("promote_shared_loan_to_mut_loan:\n- loan: " ^ V.BorrowId.to_string l + ("promote_shared_loan_to_mut_loan:\n- loan: " ^ BorrowId.to_string l ^ "\n- context:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Lookup the shared loan - note that we can't promote a shared loan * in a shared value, but we can do it in a mutably borrowed value. @@ -1505,7 +1490,7 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) raise (Failure "Expected a shared loan, found a mut loan") | _, Concrete (VSharedLoan (bids, sv)) -> (* Check that there is only one borrow id (l) and update the loan *) - assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); + assert (BorrowId.Set.mem l bids && BorrowId.Set.cardinal bids = 1); (* We need to check that there aren't any loans in the value: we should have gotten rid of those already, but it is better to do a sanity check. *) @@ -1531,8 +1516,8 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) This function updates a shared borrow to a mutable borrow (and that is all: it doesn't touch the corresponding loan). *) -let replace_reserved_borrow_with_mut_borrow (l : V.BorrowId.id) (cf : m_fun) - (borrowed_value : V.typed_value) : m_fun = +let replace_reserved_borrow_with_mut_borrow (l : BorrowId.id) (cf : m_fun) + (borrowed_value : typed_value) : m_fun = fun ctx -> (* Lookup the reserved borrow - note that we don't go inside borrows/loans: there can't be reserved borrows inside other borrows/loans @@ -1558,8 +1543,8 @@ let replace_reserved_borrow_with_mut_borrow (l : V.BorrowId.id) (cf : m_fun) cf ctx (** Promote a reserved mut borrow to a mut borrow. *) -let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : - cm_fun = +let rec promote_reserved_mut_borrow (config : config) (l : BorrowId.id) : cm_fun + = fun cf ctx -> (* Lookup the value *) let ek = @@ -1595,7 +1580,7 @@ let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : assert (not (reserved_in_value sv)); (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) - let bids = V.BorrowId.Set.remove l bids in + let bids = BorrowId.Set.remove l bids in let cc = end_borrows config bids in (* Promote the loan - TODO: this will fail if the value contains * any loans. In practice, it shouldn't, but we could also @@ -1619,9 +1604,8 @@ let rec promote_reserved_mut_borrow (config : C.config) (l : V.BorrowId.id) : "Can't activate a reserved mutable borrow referencing a loan inside\n\ \ an abstraction") -let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) - (destructure_shared_values : bool) (ctx : C.eval_ctx) (abs0 : V.abs) : V.abs - = +let destructure_abs (abs_kind : abs_kind) (can_end : bool) + (destructure_shared_values : bool) (ctx : eval_ctx) (abs0 : abs) : abs = (* Accumulator to store the destructured values *) let avalues = ref [] in (* Utility function to store a value in the accumulator *) @@ -1635,8 +1619,8 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) *) let push_fail _ = raise (Failure "Unreachable") in (* Function to explore an avalue and destructure it *) - let rec list_avalues (allow_borrows : bool) (push : V.typed_avalue -> unit) - (av : V.typed_avalue) : unit = + let rec list_avalues (allow_borrows : bool) (push : typed_avalue -> unit) + (av : typed_avalue) : unit = let ty = av.ty in match av.value with | ABottom | AIgnored -> () @@ -1655,7 +1639,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) in (* Push a value *) let ignored = mk_aignored child_av.ty in - let value = V.ALoan (ASharedLoan (bids, sv, ignored)) in + let value = ALoan (ASharedLoan (bids, sv, ignored)) in push { value; ty }; (* Explore the child *) list_avalues false push_fail child_av; @@ -1671,7 +1655,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) list_avalues false push_fail child_av; (* Explore the whole loan *) let ignored = mk_aignored child_av.ty in - let value = V.ALoan (AMutLoan (bid, ignored)) in + let value = ALoan (AMutLoan (bid, ignored)) in push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) @@ -1699,7 +1683,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) list_avalues false push_fail child_av; (* Explore the borrow *) let ignored = mk_aignored child_av.ty in - let value = V.ABorrow (AMutBorrow (bid, ignored)) in + let value = ABorrow (AMutBorrow (bid, ignored)) in push { value; ty } | ASharedBorrow _ -> (* Nothing specific to do: keep the value as it is *) @@ -1731,7 +1715,7 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) (* For now, we fore all symbolic values containing borrows to be eagerly expanded *) assert (not (ty_has_borrows ctx.type_context.type_infos ty)) - and list_values (v : V.typed_value) : V.typed_avalue list * V.typed_value = + and list_values (v : typed_value) : typed_avalue list * typed_value = let ty = v.ty in match v.value with | VLiteral _ -> ([], v) @@ -1753,24 +1737,23 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) if destructure_shared_values then ( (* Rem.: the shared value can't contain loans nor borrows *) assert (ty_no_regions ty); - let av : V.typed_avalue = + let av : typed_avalue = assert (not (value_has_loans_or_borrows ctx sv.value)); (* We introduce fresh ids for the symbolic values *) - let mk_value_with_fresh_sids (v : V.typed_value) : V.typed_value - = + let mk_value_with_fresh_sids (v : typed_value) : typed_value = let visitor = object - inherit [_] V.map_typed_avalue + inherit [_] map_typed_avalue method! visit_symbolic_value_id _ _ = - C.fresh_symbolic_value_id () + fresh_symbolic_value_id () end in visitor#visit_typed_value () v in let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) - let value = V.ALoan (ASharedLoan (bids, sv, mk_aignored ty)) in + let value = ALoan (ASharedLoan (bids, sv, mk_aignored ty)) in { value; ty } in let avl = List.append [ av ] avl in @@ -1790,32 +1773,32 @@ let destructure_abs (abs_kind : V.abs_kind) (can_end : bool) (* Update *) { abs0 with avalues; kind = abs_kind; can_end } -let abs_is_destructured (destructure_shared_values : bool) (ctx : C.eval_ctx) - (abs : V.abs) : bool = +let abs_is_destructured (destructure_shared_values : bool) (ctx : eval_ctx) + (abs : abs) : bool = let abs' = destructure_abs abs.kind abs.can_end destructure_shared_values ctx abs in abs = abs' -let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) - (destructure_shared_values : bool) (ctx : C.eval_ctx) (v : V.typed_value) : - V.abs list = +let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) + (destructure_shared_values : bool) (ctx : eval_ctx) (v : typed_value) : + abs list = (* Convert the value to a list of avalues *) let absl = ref [] in - let push_abs (r_id : T.RegionId.id) (avalues : V.typed_avalue list) : unit = + let push_abs (r_id : RegionId.id) (avalues : typed_avalue list) : unit = if avalues = [] then () else (* Create the abs - note that we keep the order of the avalues as it is (unlike the environments) *) let abs = { - V.abs_id = C.fresh_abstraction_id (); + abs_id = fresh_abstraction_id (); kind = abs_kind; can_end; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton r_id; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton r_id; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -1830,8 +1813,8 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) is [true], this shared value will be stripped of its shared loans. *) let rec to_avalues (allow_borrows : bool) (inside_borrowed : bool) - (group : bool) (r_id : T.RegionId.id) (v : V.typed_value) : - V.typed_avalue list * V.typed_value = + (group : bool) (r_id : RegionId.id) (v : typed_value) : + typed_avalue list * typed_value = (* Debug *) log#ldebug (lazy @@ -1863,7 +1846,7 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) let field_values = List.map (fun fv -> - let r_id = C.fresh_region_id () in + let r_id = fresh_region_id () in let avl, fv = to_avalues allow_borrows inside_borrowed group r_id fv in @@ -1887,18 +1870,18 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) match bc with | VSharedBorrow bid -> assert (ty_no_regions ref_ty); - let ty = T.TRef (RVar r_id, ref_ty, kind) in - let value = V.ABorrow (ASharedBorrow bid) in - ([ { V.value; ty } ], v) + let ty = TRef (RVar r_id, ref_ty, kind) in + let value = ABorrow (ASharedBorrow bid) in + ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> - let r_id = if group then r_id else C.fresh_region_id () in + let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx bv.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ty = T.TRef (RVar r_id, ref_ty, kind) in + let ty = TRef (RVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in - let av = V.ABorrow (AMutBorrow (bid, ignored)) in - let av = { V.value = av; ty } in + let av = ABorrow (AMutBorrow (bid, ignored)) in + let av = { value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, because we don't support nested borrows for now) *) let avl, bv = to_avalues false true true r_id bv in @@ -1910,21 +1893,21 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) | VLoan lc -> ( match lc with | VSharedLoan (bids, sv) -> - let r_id = if group then r_id else C.fresh_region_id () in + let r_id = if group then r_id else fresh_region_id () in (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx sv.value)); (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (RVar r_id) ty Shared in + let ty = mk_ref_ty (RVar r_id) ty RShared in let ignored = mk_aignored ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in - let av = V.ALoan (ASharedLoan (bids, sv, ignored)) in - let av = { V.value = av; ty } in + let av = ALoan (ASharedLoan (bids, sv, ignored)) in + let av = { value = av; ty } in (* Continue exploring, looking for loans (and forbidding borrows, because we don't support nested borrows for now) *) - let value : V.value = + let value : value = if destructure_shared_values then sv.value else VLoan (VSharedLoan (bids, sv)) in @@ -1934,10 +1917,10 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (RVar r_id) ty Mut in + let ty = mk_ref_ty (RVar r_id) ty RMut in let ignored = mk_aignored ty in - let av = V.ALoan (AMutLoan (bid, ignored)) in - let av = { V.value = av; ty } in + let av = ALoan (AMutLoan (bid, ignored)) in + let av = { value = av; ty } in ([ av ], v)) | VSymbolic _ -> (* For now, we force all the symbolic values containing borrows to @@ -1947,28 +1930,28 @@ let convert_value_to_abstractions (abs_kind : V.abs_kind) (can_end : bool) ([], v) in (* Generate the avalues *) - let r_id = C.fresh_region_id () in + let r_id = fresh_region_id () in let values, _ = to_avalues true false false r_id v in (* Introduce an abstraction for the returned values *) push_abs r_id values; (* Return *) List.rev !absl -type borrow_or_loan_id = BorrowId of V.borrow_id | LoanId of V.loan_id +type borrow_or_loan_id = BorrowId of borrow_id | LoanId of loan_id type g_loan_content_with_ty = - (T.ety * V.loan_content, T.rty * V.aloan_content) concrete_or_abs + (ety * loan_content, rty * aloan_content) concrete_or_abs type g_borrow_content_with_ty = - (T.ety * V.borrow_content, T.rty * V.aborrow_content) concrete_or_abs + (ety * borrow_content, rty * aborrow_content) concrete_or_abs type merge_abstraction_info = { - loans : V.loan_id_set; - borrows : V.borrow_id_set; + loans : loan_id_set; + borrows : borrow_id_set; borrows_loans : borrow_or_loan_id list; (** We use a list to preserve the order in which the borrows were found *) - loan_to_content : g_loan_content_with_ty V.BorrowId.Map.t; - borrow_to_content : g_borrow_content_with_ty V.BorrowId.Map.t; + loan_to_content : g_loan_content_with_ty BorrowId.Map.t; + borrow_to_content : g_borrow_content_with_ty BorrowId.Map.t; } (** Small utility to help merging abstractions. @@ -1983,54 +1966,54 @@ type merge_abstraction_info = { - all the borrows are destructured (for instance, shared loans can't contain shared loans). *) -let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : +let compute_merge_abstraction_info (ctx : eval_ctx) (abs : abs) : merge_abstraction_info = - let loans : V.loan_id_set ref = ref V.BorrowId.Set.empty in - let borrows : V.borrow_id_set ref = ref V.BorrowId.Set.empty in + let loans : loan_id_set ref = ref BorrowId.Set.empty in + let borrows : borrow_id_set ref = ref BorrowId.Set.empty in let borrows_loans : borrow_or_loan_id list ref = ref [] in - let loan_to_content : g_loan_content_with_ty V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty + let loan_to_content : g_loan_content_with_ty BorrowId.Map.t ref = + ref BorrowId.Map.empty in - let borrow_to_content : g_borrow_content_with_ty V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty + let borrow_to_content : g_borrow_content_with_ty BorrowId.Map.t ref = + ref BorrowId.Map.empty in let push_loans ids (lc : g_loan_content_with_ty) : unit = - assert (V.BorrowId.Set.disjoint !loans ids); - loans := V.BorrowId.Set.union !loans ids; - V.BorrowId.Set.iter + assert (BorrowId.Set.disjoint !loans ids); + loans := BorrowId.Set.union !loans ids; + BorrowId.Set.iter (fun id -> - assert (not (V.BorrowId.Map.mem id !loan_to_content)); - loan_to_content := V.BorrowId.Map.add id lc !loan_to_content; + assert (not (BorrowId.Map.mem id !loan_to_content)); + loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans) ids in let push_loan id (lc : g_loan_content_with_ty) : unit = - assert (not (V.BorrowId.Set.mem id !loans)); - loans := V.BorrowId.Set.add id !loans; - assert (not (V.BorrowId.Map.mem id !loan_to_content)); - loan_to_content := V.BorrowId.Map.add id lc !loan_to_content; + assert (not (BorrowId.Set.mem id !loans)); + loans := BorrowId.Set.add id !loans; + assert (not (BorrowId.Map.mem id !loan_to_content)); + loan_to_content := BorrowId.Map.add id lc !loan_to_content; borrows_loans := LoanId id :: !borrows_loans in let push_borrow id (bc : g_borrow_content_with_ty) : unit = - assert (not (V.BorrowId.Set.mem id !borrows)); - borrows := V.BorrowId.Set.add id !borrows; - assert (not (V.BorrowId.Map.mem id !borrow_to_content)); - borrow_to_content := V.BorrowId.Map.add id bc !borrow_to_content; + assert (not (BorrowId.Set.mem id !borrows)); + borrows := BorrowId.Set.add id !borrows; + assert (not (BorrowId.Map.mem id !borrow_to_content)); + borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; borrows_loans := BorrowId id :: !borrows_loans in let iter_avalues = object - inherit [_] V.iter_typed_avalue as super + inherit [_] iter_typed_avalue as super (** We redefine this to track the types *) method! visit_typed_avalue _ v = - super#visit_typed_avalue (Some (Abstract v.V.ty)) v + super#visit_typed_avalue (Some (Abstract v.ty)) v (** We redefine this to track the types *) - method! visit_typed_value _ (v : V.typed_value) = - super#visit_typed_value (Some (Concrete v.V.ty)) v + method! visit_typed_value _ (v : typed_value) = + super#visit_typed_value (Some (Concrete v.ty)) v method! visit_loan_content env lc = (* Can happen if we explore shared values whose sub-values are @@ -2059,10 +2042,10 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : in (* Register the loans *) (match lc with - | V.ASharedLoan (bids, _, _) -> push_loans bids (Abstract (ty, lc)) - | V.AMutLoan (bid, _) -> push_loan bid (Abstract (ty, lc)) - | V.AEndedMutLoan _ | V.AEndedSharedLoan _ | V.AIgnoredMutLoan _ - | V.AEndedIgnoredMutLoan _ | V.AIgnoredSharedLoan _ -> + | ASharedLoan (bids, _, _) -> push_loans bids (Abstract (ty, lc)) + | AMutLoan (bid, _) -> push_loan bid (Abstract (ty, lc)) + | AEndedMutLoan _ | AEndedSharedLoan _ | AIgnoredMutLoan _ + | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) raise (Failure "Unreachable")); (* Continue *) @@ -2076,20 +2059,20 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : in (* Explore the borrow content *) (match bc with - | V.AMutBorrow (bid, _) -> push_borrow bid (Abstract (ty, bc)) - | V.ASharedBorrow bid -> push_borrow bid (Abstract (ty, bc)) - | V.AProjSharedBorrow asb -> + | AMutBorrow (bid, _) -> push_borrow bid (Abstract (ty, bc)) + | ASharedBorrow bid -> push_borrow bid (Abstract (ty, bc)) + | AProjSharedBorrow asb -> let register asb = match asb with - | V.AsbBorrow bid -> push_borrow bid (Abstract (ty, bc)) - | V.AsbProjReborrows _ -> + | AsbBorrow bid -> push_borrow bid (Abstract (ty, bc)) + | AsbProjReborrows _ -> (* Can only happen if the symbolic value (potentially) contains borrows - i.e., we have nested borrows *) raise (Failure "Unreachable") in List.iter register asb - | V.AIgnoredMutBorrow _ | V.AEndedIgnoredMutBorrow _ - | V.AEndedMutBorrow _ | V.AEndedSharedBorrow -> + | AIgnoredMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedMutBorrow _ + | AEndedSharedBorrow -> (* The abstraction has been destructured, so those shouldn't appear *) raise (Failure "Unreachable")); super#visit_aborrow_content env bc @@ -2100,7 +2083,7 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : end in - List.iter (iter_avalues#visit_typed_avalue None) abs.V.avalues; + List.iter (iter_avalues#visit_typed_avalue None) abs.avalues; { loans = !loans; @@ -2112,12 +2095,7 @@ let compute_merge_abstraction_info (ctx : C.eval_ctx) (abs : V.abs) : type merge_duplicates_funcs = { merge_amut_borrows : - V.borrow_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + borrow_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -2127,19 +2105,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) - merge_ashared_borrows : V.borrow_id -> T.rty -> T.rty -> V.typed_avalue; + merge_ashared_borrows : borrow_id -> rty -> rty -> typed_avalue; (** Parameters: - [id] - [ty0] - [ty1] *) merge_amut_loans : - V.loan_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + loan_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -2150,14 +2123,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) merge_ashared_loans : - V.loan_id_set -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - V.typed_avalue; + loan_id_set -> + rty -> + typed_value -> + typed_avalue -> + rty -> + typed_value -> + typed_avalue -> + typed_avalue; (** Parameters: - [ids] - [ty0] @@ -2173,9 +2146,9 @@ type merge_duplicates_funcs = { Merge two abstractions into one, without updating the context. *) -let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : C.eval_ctx) - (abs0 : V.abs) (abs1 : V.abs) : V.abs = +let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) + (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs0 : abs) + (abs1 : abs) : abs = log#ldebug (lazy ("merge_into_abstraction_aux:\n- abs0:\n" ^ abs_to_string ctx abs0 @@ -2211,8 +2184,8 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then ( - assert (V.BorrowId.Set.disjoint borrows0 borrows1); - assert (V.BorrowId.Set.disjoint loans0 loans1)); + assert (BorrowId.Set.disjoint borrows0 borrows1); + assert (BorrowId.Set.disjoint loans0 loans1)); (* Merge. There are several cases: @@ -2232,8 +2205,8 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) We ignore this case for now: we check that whenever we merge two shared loans, then their sets of ids are equal. *) - let merged_borrows = ref V.BorrowId.Set.empty in - let merged_loans = ref V.BorrowId.Set.empty in + let merged_borrows = ref BorrowId.Set.empty in + let merged_loans = ref BorrowId.Set.empty in let avalues = ref [] in let push_avalue av = log#ldebug @@ -2247,35 +2220,35 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) in let intersect = - V.BorrowId.Set.union - (V.BorrowId.Set.inter loans0 borrows1) - (V.BorrowId.Set.inter loans1 borrows0) + BorrowId.Set.union + (BorrowId.Set.inter loans0 borrows1) + (BorrowId.Set.inter loans1 borrows0) in - let filter_bids (bids : V.BorrowId.Set.t) : V.BorrowId.Set.t = - let bids = V.BorrowId.Set.diff bids intersect in - assert (not (V.BorrowId.Set.is_empty bids)); + let filter_bids (bids : BorrowId.Set.t) : BorrowId.Set.t = + let bids = BorrowId.Set.diff bids intersect in + assert (not (BorrowId.Set.is_empty bids)); bids in - let filter_bid (bid : V.BorrowId.id) : V.BorrowId.id option = - if V.BorrowId.Set.mem bid intersect then None else Some bid + let filter_bid (bid : BorrowId.id) : BorrowId.id option = + if BorrowId.Set.mem bid intersect then None else Some bid in - let borrow_is_merged id = V.BorrowId.Set.mem id !merged_borrows in + let borrow_is_merged id = BorrowId.Set.mem id !merged_borrows in let set_borrow_as_merged id = - merged_borrows := V.BorrowId.Set.add id !merged_borrows + merged_borrows := BorrowId.Set.add id !merged_borrows in - let loan_is_merged id = V.BorrowId.Set.mem id !merged_loans in + let loan_is_merged id = BorrowId.Set.mem id !merged_loans in let set_loan_as_merged id = - merged_loans := V.BorrowId.Set.add id !merged_loans + merged_loans := BorrowId.Set.add id !merged_loans in - let set_loans_as_merged ids = V.BorrowId.Set.iter set_loan_as_merged ids in + let set_loans_as_merged ids = BorrowId.Set.iter set_loan_as_merged ids in (* Some utility functions *) (* Merge two aborrow contents - note that those contents must have the same id *) - let merge_aborrow_contents (ty0 : T.rty) (bc0 : V.aborrow_content) - (ty1 : T.rty) (bc1 : V.aborrow_content) : V.typed_avalue = + let merge_aborrow_contents (ty0 : rty) (bc0 : aborrow_content) (ty1 : rty) + (bc1 : aborrow_content) : typed_avalue = match (bc0, bc1) with - | V.AMutBorrow (id, child0), V.AMutBorrow (_, child1) -> + | AMutBorrow (id, child0), AMutBorrow (_, child1) -> (Option.get merge_funs).merge_amut_borrows id ty0 child0 ty1 child1 | ASharedBorrow id, ASharedBorrow _ -> (Option.get merge_funs).merge_ashared_borrows id ty0 ty1 @@ -2289,7 +2262,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) in let merge_g_borrow_contents (bc0 : g_borrow_content_with_ty) - (bc1 : g_borrow_content_with_ty) : V.typed_avalue = + (bc1 : g_borrow_content_with_ty) : typed_avalue = match (bc0, bc1) with | Concrete _, Concrete _ -> (* This can happen only in case of nested borrows *) @@ -2301,10 +2274,10 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) raise (Failure "Unreachable") in - let merge_aloan_contents (ty0 : T.rty) (lc0 : V.aloan_content) (ty1 : T.rty) - (lc1 : V.aloan_content) : V.typed_avalue option = + let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) + (lc1 : aloan_content) : typed_avalue option = match (lc0, lc1) with - | V.AMutLoan (id, child0), V.AMutLoan (_, child1) -> + | AMutLoan (id, child0), AMutLoan (_, child1) -> (* Register the loan id *) set_loan_as_merged id; (* Merge *) @@ -2316,9 +2289,9 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) (* Check that the sets of ids are the same - if it is not the case, it means we actually need to merge more than 2 avalues: we ignore this case for now *) - assert (V.BorrowId.Set.equal ids0 ids1); + assert (BorrowId.Set.equal ids0 ids1); let ids = ids0 in - if V.BorrowId.Set.is_empty ids then ( + if BorrowId.Set.is_empty ids then ( (* If the set of ids is empty, we can eliminate this shared loan. For now, we check that we can eliminate the whole shared value altogether. @@ -2328,10 +2301,10 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) to preserve (in practice it works because we destructure the shared values in the abstractions, and forbid nested borrows). *) - assert (not (value_has_loans_or_borrows ctx sv0.V.value)); - assert (not (value_has_loans_or_borrows ctx sv0.V.value)); - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (not (value_has_loans_or_borrows ctx sv0.value)); + assert (not (value_has_loans_or_borrows ctx sv0.value)); + assert (is_aignored child0.value); + assert (is_aignored child1.value); None) else ( (* Register the loan ids *) @@ -2350,7 +2323,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) to register the merged loan ids: the caller doesn't do it (contrary to the borrow case) *) let merge_g_loan_contents (lc0 : g_loan_content_with_ty) - (lc1 : g_loan_content_with_ty) : V.typed_avalue option = + (lc1 : g_loan_content_with_ty) : typed_avalue option = match (lc0, lc1) with | Concrete _, Concrete _ -> (* This can not happen: the values should have been destructured *) @@ -2374,7 +2347,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) log#ldebug (lazy ("merge_into_abstraction_aux: merging borrow " - ^ V.BorrowId.to_string bid)); + ^ BorrowId.to_string bid)); (* Check if the borrow has already been merged - this can happen because we go through all the borrows/loans in [abs0] *then* @@ -2388,10 +2361,10 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) | None -> () | Some bid -> (* Lookup the contents *) - let bc0 = V.BorrowId.Map.find_opt bid borrow_to_content0 in - let bc1 = V.BorrowId.Map.find_opt bid borrow_to_content1 in + let bc0 = BorrowId.Map.find_opt bid borrow_to_content0 in + let bc1 = BorrowId.Map.find_opt bid borrow_to_content1 in (* Merge *) - let av : V.typed_avalue = + let av : typed_avalue = match (bc0, bc1) with | None, Some bc | Some bc, None -> ( match bc with @@ -2401,7 +2374,7 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) loan *) raise (Failure "Unreachable") - | Abstract (ty, bc) -> { V.value = V.ABorrow bc; ty }) + | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some bc0, Some bc1 -> assert (merge_funs <> None); merge_g_borrow_contents bc0 bc1 @@ -2421,17 +2394,17 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) log#ldebug (lazy ("merge_into_abstraction_aux: merging loan " - ^ V.BorrowId.to_string bid)); + ^ BorrowId.to_string bid)); (* Check if we need to filter it *) match filter_bid bid with | None -> () | Some bid -> (* Lookup the contents *) - let lc0 = V.BorrowId.Map.find_opt bid loan_to_content0 in - let lc1 = V.BorrowId.Map.find_opt bid loan_to_content1 in + let lc0 = BorrowId.Map.find_opt bid loan_to_content0 in + let lc1 = BorrowId.Map.find_opt bid loan_to_content1 in (* Merge *) - let av : V.typed_avalue option = + let av : typed_avalue option = match (lc0, lc1) with | None, Some lc | Some lc, None -> ( match lc with @@ -2441,21 +2414,21 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) raise (Failure "Unreachable") | Abstract (ty, lc) -> ( match lc with - | V.ASharedLoan (bids, sv, child) -> + | ASharedLoan (bids, sv, child) -> let bids = filter_bids bids in - assert (not (V.BorrowId.Set.is_empty bids)); - assert (is_aignored child.V.value); + assert (not (BorrowId.Set.is_empty bids)); + assert (is_aignored child.value); assert ( - not (value_has_loans_or_borrows ctx sv.V.value)); - let lc = V.ASharedLoan (bids, sv, child) in + not (value_has_loans_or_borrows ctx sv.value)); + let lc = ASharedLoan (bids, sv, child) in set_loans_as_merged bids; - Some { V.value = V.ALoan lc; ty } - | V.AMutLoan _ -> + Some { value = ALoan lc; ty } + | AMutLoan _ -> set_loan_as_merged bid; - Some { V.value = V.ALoan lc; ty } - | V.AEndedMutLoan _ | V.AEndedSharedLoan _ - | V.AIgnoredMutLoan _ | V.AEndedIgnoredMutLoan _ - | V.AIgnoredSharedLoan _ -> + Some { value = ALoan lc; ty } + | AEndedMutLoan _ | AEndedSharedLoan _ + | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ + | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) raise (Failure "Unreachable"))) | Some lc0, Some lc1 -> @@ -2475,8 +2448,8 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) meaning it is easier to find fixed points). *) let avalues = - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unexpected") @@ -2488,21 +2461,21 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) (* Filter the regions *) (* Create the new abstraction *) - let abs_id = C.fresh_abstraction_id () in + let abs_id = fresh_abstraction_id () in (* Note that one of the two abstractions might a parent of the other *) let parents = - V.AbstractionId.Set.diff - (V.AbstractionId.Set.union abs0.parents abs1.parents) - (V.AbstractionId.Set.of_list [ abs0.abs_id; abs1.abs_id ]) + AbstractionId.Set.diff + (AbstractionId.Set.union abs0.parents abs1.parents) + (AbstractionId.Set.of_list [ abs0.abs_id; abs1.abs_id ]) in - let original_parents = V.AbstractionId.Set.elements parents in - let regions = T.RegionId.Set.union abs0.regions abs1.regions in + let original_parents = AbstractionId.Set.elements parents in + let regions = RegionId.Set.union abs0.regions abs1.regions in let ancestors_regions = - T.RegionId.Set.diff (T.RegionId.Set.union abs0.regions abs1.regions) regions + RegionId.Set.diff (RegionId.Set.union abs0.regions abs1.regions) regions in let abs = { - V.abs_id; + abs_id; kind = abs_kind; can_end; parents; @@ -2519,19 +2492,19 @@ let merge_into_abstraction_aux (abs_kind : V.abs_kind) (can_end : bool) abs (** Merge the regions in a context to a single region *) -let ctx_merge_regions (ctx : C.eval_ctx) (rid : T.RegionId.id) - (rids : T.RegionId.Set.t) : C.eval_ctx = - let rsubst x = if T.RegionId.Set.mem x rids then rid else x in +let ctx_merge_regions (ctx : eval_ctx) (rid : RegionId.id) + (rids : RegionId.Set.t) : eval_ctx = + let rsubst x = if RegionId.Set.mem x rids then rid else x in let env = Substitute.env_subst_rids rsubst ctx.env in - { ctx with C.env } + { ctx with env } -let merge_into_abstraction (abs_kind : V.abs_kind) (can_end : bool) - (merge_funs : merge_duplicates_funcs option) (ctx : C.eval_ctx) - (abs_id0 : V.AbstractionId.id) (abs_id1 : V.AbstractionId.id) : - C.eval_ctx * V.AbstractionId.id = +let merge_into_abstraction (abs_kind : abs_kind) (can_end : bool) + (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) + (abs_id0 : AbstractionId.id) (abs_id1 : AbstractionId.id) : + eval_ctx * AbstractionId.id = (* Lookup the abstractions *) - let abs0 = C.ctx_lookup_abs ctx abs_id0 in - let abs1 = C.ctx_lookup_abs ctx abs_id1 in + let abs0 = ctx_lookup_abs ctx abs_id0 in + let abs1 = ctx_lookup_abs ctx abs_id1 in (* Merge them *) let nabs = @@ -2540,8 +2513,8 @@ let merge_into_abstraction (abs_kind : V.abs_kind) (can_end : bool) (* Update the environment: replace the abstraction 1 with the result of the merge, remove the abstraction 0 *) - let ctx = fst (C.ctx_subst_abs ctx abs_id1 nabs) in - let ctx = fst (C.ctx_remove_abs ctx abs_id0) in + let ctx = fst (ctx_subst_abs ctx abs_id1 nabs) in + let ctx = fst (ctx_remove_abs ctx abs_id0) in (* Merge all the regions from the abstraction into one (the first - i.e., the one with the smallest id). Note that we need to do this in the whole @@ -2552,11 +2525,11 @@ let merge_into_abstraction (abs_kind : V.abs_kind) (can_end : bool) let ctx = let regions = nabs.regions in (* Pick the first region id (this is the smallest) *) - let rid = T.RegionId.Set.min_elt regions in + let rid = RegionId.Set.min_elt regions in (* If there is only one region, do nothing *) - if T.RegionId.Set.cardinal regions = 1 then ctx + if RegionId.Set.cardinal regions = 1 then ctx else - let rids = T.RegionId.Set.remove rid regions in + let rids = RegionId.Set.remove rid regions in ctx_merge_regions ctx rid rids in diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 6302dcc3..e47ba82d 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -1,49 +1,44 @@ -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging -module S = SynthesizeSymbolic +open Types +open Values +open Contexts open Cps -open InterpreterProjectors (** When copying values, we duplicate the shared borrows. This is tantamount to reborrowing the shared value. The [reborrow_shared original_id new_bid ctx] applies this change to an environment [ctx] by inserting a new borrow id in the set of borrows tracked by a shared value, referenced by the [original_bid] argument. *) -val reborrow_shared : V.BorrowId.id -> V.BorrowId.id -> C.eval_ctx -> C.eval_ctx +val reborrow_shared : BorrowId.id -> BorrowId.id -> eval_ctx -> eval_ctx (** End a borrow identified by its id, while preserving the invariants. If the borrow is inside another borrow/an abstraction or contains loans, [end_borrow] will end those borrows/abstractions/loans first. *) -val end_borrow : C.config -> V.BorrowId.id -> cm_fun +val end_borrow : config -> BorrowId.id -> cm_fun (** End a set of borrows identified by their ids, while preserving the invariants. *) -val end_borrows : C.config -> V.BorrowId.Set.t -> cm_fun +val end_borrows : config -> BorrowId.Set.t -> cm_fun (** End an abstraction while preserving the invariants. *) -val end_abstraction : C.config -> V.AbstractionId.id -> cm_fun +val end_abstraction : config -> AbstractionId.id -> cm_fun (** End a set of abstractions while preserving the invariants. *) -val end_abstractions : C.config -> V.AbstractionId.Set.t -> cm_fun +val end_abstractions : config -> AbstractionId.Set.t -> cm_fun (** End a borrow and return the resulting environment, ignoring synthesis *) -val end_borrow_no_synth : C.config -> V.BorrowId.id -> C.eval_ctx -> C.eval_ctx +val end_borrow_no_synth : config -> BorrowId.id -> eval_ctx -> eval_ctx (** End a set of borrows and return the resulting environment, ignoring synthesis *) -val end_borrows_no_synth : - C.config -> V.BorrowId.Set.t -> C.eval_ctx -> C.eval_ctx +val end_borrows_no_synth : config -> BorrowId.Set.t -> eval_ctx -> eval_ctx (** End an abstraction and return the resulting environment, ignoring synthesis *) val end_abstraction_no_synth : - C.config -> V.AbstractionId.id -> C.eval_ctx -> C.eval_ctx + config -> AbstractionId.id -> eval_ctx -> eval_ctx (** End a set of abstractions and return the resulting environment, ignoring synthesis *) val end_abstractions_no_synth : - C.config -> V.AbstractionId.Set.t -> C.eval_ctx -> C.eval_ctx + config -> AbstractionId.Set.t -> eval_ctx -> eval_ctx (** Promote a reserved mut borrow to a mut borrow, while preserving the invariants. @@ -54,7 +49,7 @@ val end_abstractions_no_synth : the corresponding shared loan with a mutable loan (after having ended the other shared borrows which point to this loan). *) -val promote_reserved_mut_borrow : C.config -> V.BorrowId.id -> cm_fun +val promote_reserved_mut_borrow : config -> BorrowId.id -> cm_fun (** Transform an abstraction to an abstraction where the values are not structured. @@ -96,7 +91,7 @@ val promote_reserved_mut_borrow : C.config -> V.BorrowId.id -> cm_fun - [ctx] - [abs] *) -val destructure_abs : V.abs_kind -> bool -> bool -> C.eval_ctx -> V.abs -> V.abs +val destructure_abs : abs_kind -> bool -> bool -> eval_ctx -> abs -> abs (** Return [true] if the values in an abstraction are destructured. @@ -104,7 +99,7 @@ val destructure_abs : V.abs_kind -> bool -> bool -> C.eval_ctx -> V.abs -> V.abs The input boolean is [destructure_shared_value]. See {!destructure_abs}. *) -val abs_is_destructured : bool -> C.eval_ctx -> V.abs -> bool +val abs_is_destructured : bool -> eval_ctx -> abs -> bool (** Turn a value into a abstractions. @@ -130,7 +125,7 @@ val abs_is_destructured : bool -> C.eval_ctx -> V.abs -> bool - [v] *) val convert_value_to_abstractions : - V.abs_kind -> bool -> bool -> C.eval_ctx -> V.typed_value -> V.abs list + abs_kind -> bool -> bool -> eval_ctx -> typed_value -> abs list (** See {!merge_into_abstraction}. @@ -139,12 +134,7 @@ val convert_value_to_abstractions : *) type merge_duplicates_funcs = { merge_amut_borrows : - V.borrow_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + borrow_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -154,19 +144,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) - merge_ashared_borrows : V.borrow_id -> T.rty -> T.rty -> V.typed_avalue; + merge_ashared_borrows : borrow_id -> rty -> rty -> typed_avalue; (** Parameters: - [id] - [ty0] - [ty1] *) merge_amut_loans : - V.loan_id -> - T.rty -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue; + loan_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; (** Parameters: - [id] - [ty0] @@ -177,14 +162,14 @@ type merge_duplicates_funcs = { The children should be [AIgnored]. *) merge_ashared_loans : - V.loan_id_set -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - V.typed_avalue; + loan_id_set -> + rty -> + typed_value -> + typed_avalue -> + rty -> + typed_value -> + typed_avalue -> + typed_avalue; (** Parameters: - [ids] - [ty0] @@ -247,10 +232,10 @@ type merge_duplicates_funcs = { results from the merge. *) val merge_into_abstraction : - V.abs_kind -> + abs_kind -> bool -> merge_duplicates_funcs option -> - C.eval_ctx -> - V.AbstractionId.id -> - V.AbstractionId.id -> - C.eval_ctx * V.AbstractionId.id + eval_ctx -> + AbstractionId.id -> + AbstractionId.id -> + eval_ctx * AbstractionId.id diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index cde39e9b..b13d545c 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -3,17 +3,15 @@ also in Invariants or InterpreterProjectors *) -module T = Types -module V = Values -module C = Contexts -module Subst = Substitute -module L = Logging +open Types +open Values +open Contexts open Utils open TypesUtils open InterpreterUtils (** The local logger *) -let log = L.borrows_log +let log = Logging.borrows_log (** TODO: cleanup this a bit, once we have a better understanding about what we need. @@ -33,19 +31,19 @@ type exploration_kind = { let ek_all : exploration_kind = { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } -type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id +type borrow_ids = Borrows of BorrowId.Set.t | Borrow of BorrowId.id [@@deriving show] type borrow_ids_or_symbolic_value = | BorrowIds of borrow_ids - | SymbolicValue of V.symbolic_value + | SymbolicValue of symbolic_value [@@deriving show] exception FoundBorrowIds of borrow_ids type priority_borrows_or_abs = | OuterBorrows of borrow_ids - | OuterAbs of V.AbstractionId.id + | OuterAbs of AbstractionId.id | InnerLoans of borrow_ids [@@deriving show] @@ -55,20 +53,17 @@ let update_if_none opt x = match opt with None -> Some x | _ -> opt exception FoundPriority of priority_borrows_or_abs type loan_or_borrow_content = - | LoanContent of V.loan_content - | BorrowContent of V.borrow_content + | LoanContent of loan_content + | BorrowContent of borrow_content [@@deriving show] -type borrow_or_abs_id = - | BorrowId of V.BorrowId.id - | AbsId of V.AbstractionId.id - +type borrow_or_abs_id = BorrowId of BorrowId.id | AbsId of AbstractionId.id type borrow_or_abs_ids = borrow_or_abs_id list let borrow_or_abs_id_to_string (id : borrow_or_abs_id) : string = match id with - | AbsId id -> "abs@" ^ V.AbstractionId.to_string id - | BorrowId id -> "l@" ^ V.BorrowId.to_string id + | AbsId id -> "abs@" ^ AbstractionId.to_string id + | BorrowId id -> "l@" ^ BorrowId.to_string id let borrow_or_abs_ids_chain_to_string (ids : borrow_or_abs_ids) : string = let ids = List.rev ids in @@ -100,8 +95,8 @@ let add_borrow_or_abs_id_to_chain (msg : string) (id : borrow_or_abs_id) TODO: rename *) let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) - (compare_regions : T.region -> T.region -> bool) (ty1 : T.rty) (ty2 : T.rty) - : bool = + (compare_regions : region -> region -> bool) (ty1 : rty) (ty2 : rty) : bool + = let compare = compare_rtys default combine compare_regions in (* Sanity check - TODO: don't do this at every recursive call *) assert (ty_is_rty ty1 && ty_is_rty ty2); @@ -166,8 +161,8 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) | _ -> log#lerror (lazy - ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ T.show_ty ty1 - ^ "\n- ty2: " ^ T.show_ty ty2)); + ("compare_rtys: unexpected inputs:" ^ "\n- ty1: " ^ show_ty ty1 + ^ "\n- ty2: " ^ show_ty ty2)); raise (Failure "Unreachable") (** Check if two different projections intersect. This is necessary when @@ -177,8 +172,8 @@ let rec compare_rtys (default : bool) (combine : bool -> bool -> bool) Note that the two abstractions have different views (in terms of regions) of the symbolic value (hence the two region types). *) -let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = +let projections_intersect (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) + (rset2 : RegionId.Set.t) : bool = let default = false in let combine b1 b2 = b1 || b2 in let compare_regions r1 r2 = @@ -192,8 +187,8 @@ let projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) The regions in the types shouldn't be erased (this function will raise an exception otherwise). *) -let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) - (rset2 : T.RegionId.Set.t) : bool = +let projection_contains (ty1 : rty) (rset1 : RegionId.Set.t) (ty2 : rty) + (rset2 : RegionId.Set.t) : bool = let default = true in let combine b1 b2 = b1 && b2 in let compare_regions r1 r2 = @@ -209,8 +204,8 @@ let projection_contains (ty1 : T.rty) (rset1 : T.RegionId.Set.t) (ty2 : T.rty) the {!InterpreterUtils.abs_or_var_id} is not necessarily {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.VarId} or {!constructor:Aeneas.InterpreterUtils.abs_or_var_id.DummyVarId}: there can be concrete loans in abstractions (in the shared values). *) -let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = +let lookup_loan_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : + (abs_or_var_id * g_loan_content) option = (* We store here whether we are inside an abstraction or a value - note that we * could also track that with the environment, it would probably be more idiomatic * and cleaner *) @@ -218,17 +213,17 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_borrow_content env bc = match bc with - | V.VSharedBorrow bid -> + | VSharedBorrow bid -> (* Nothing specific to do *) super#visit_VSharedBorrow env bid - | V.VReservedMutBorrow bid -> + | VReservedMutBorrow bid -> (* Nothing specific to do *) super#visit_VReservedMutBorrow env bid - | V.VMutBorrow (bid, mv) -> + | VMutBorrow (bid, mv) -> (* Control the dive *) if ek.enter_mut_borrows then super#visit_VMutBorrow env bid mv else () @@ -240,14 +235,14 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) *) method! visit_loan_content env lc = match lc with - | V.VSharedLoan (bids, sv) -> + | VSharedLoan (bids, sv) -> (* Check if this is the loan we are looking for, and control the dive *) - if V.BorrowId.Set.mem l bids then + if BorrowId.Set.mem l bids then raise (FoundGLoanContent (Concrete lc)) else if ek.enter_shared_loans then super#visit_VSharedLoan env bids sv else () - | V.VMutLoan bid -> + | VMutLoan bid -> (* Check if this is the loan we are looking for *) if bid = l then raise (FoundGLoanContent (Concrete lc)) else super#visit_VMutLoan env bid @@ -257,19 +252,19 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) (because there are no use cases requiring finer control) *) method! visit_aloan_content env lc = match lc with - | V.AMutLoan (bid, av) -> + | AMutLoan (bid, av) -> if bid = l then raise (FoundGLoanContent (Abstract lc)) else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then + | ASharedLoan (bids, v, av) -> + if BorrowId.Set.mem l bids then raise (FoundGLoanContent (Abstract lc)) else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) + | AIgnoredMutLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> super#visit_aloan_content env lc method! visit_EBinding env bv v = @@ -277,7 +272,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) abs_or_var := Some (match bv with - | BVar b -> VarId b.C.index + | BVar b -> VarId b.index | BDummy id -> DummyVarId id); super#visit_EBinding env bv v; abs_or_var := None @@ -285,7 +280,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) method! visit_EAbs env abs = assert (Option.is_none !abs_or_var); if ek.enter_abs then ( - abs_or_var := Some (AbsId abs.V.abs_id); + abs_or_var := Some (AbsId abs.abs_id); super#visit_EAbs env abs; abs_or_var := None) else () @@ -305,7 +300,7 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) The loan is referred to by a borrow id. Raises an exception if no loan was found. *) -let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : +let lookup_loan (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : abs_or_var_id * g_loan_content = match lookup_loan_opt ek l ctx with | None -> raise (Failure "Unreachable") @@ -317,13 +312,13 @@ let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : This is a helper function: it might break invariants. *) -let update_loan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = +let update_loan (ek : exploration_kind) (l : BorrowId.id) (nlc : loan_content) + (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) let r = ref false in - let update () : V.loan_content = + let update () : loan_content = assert (not !r); r := true; nlc @@ -331,7 +326,7 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_borrow_content env bc = match bc with @@ -350,7 +345,7 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.id) | VSharedLoan (bids, sv) -> (* Shared loan: check if this is the loan we are looking for, and control the dive. *) - if V.BorrowId.Set.mem l bids then update () + if BorrowId.Set.mem l bids then update () else if ek.enter_shared_loans then super#visit_VSharedLoan env bids sv else VSharedLoan (bids, sv) @@ -380,13 +375,13 @@ let update_loan (ek : exploration_kind) (l : V.BorrowId.id) This is a helper function: it might break invariants. *) -let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = +let update_aloan (ek : exploration_kind) (l : BorrowId.id) (nlc : aloan_content) + (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one loan: when updating * inside values, we check we don't update more than one loan. Then, upon * returning we check that we updated at least once. *) let r = ref false in - let update () : V.aloan_content = + let update () : aloan_content = assert (not !r); r := true; nlc @@ -394,21 +389,21 @@ let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_aloan_content env lc = match lc with - | V.AMutLoan (bid, av) -> + | AMutLoan (bid, av) -> if bid = l then update () else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then update () + | ASharedLoan (bids, v, av) -> + if BorrowId.Set.mem l bids then update () else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) + | AIgnoredMutLoan (_, _) + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> super#visit_aloan_content env lc (** Note that once inside the abstractions, we don't control diving @@ -424,11 +419,11 @@ let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) ctx (** Lookup a borrow content from a borrow id. *) -let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : g_borrow_content option = +let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) + : g_borrow_content option = let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_borrow_content env bc = match bc with @@ -486,8 +481,8 @@ let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) Raise an exception if no loan was found *) -let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) - : g_borrow_content = +let lookup_borrow (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : + g_borrow_content = match lookup_borrow_opt ek l ctx with | None -> raise (Failure "Unreachable") | Some lc -> lc @@ -498,13 +493,13 @@ let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) This is a helper function: it might break invariants. *) -let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) - (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = +let update_borrow (ek : exploration_kind) (l : BorrowId.id) + (nbc : borrow_content) (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one borrow: when updating * inside values, we check we don't update more than one borrow. Then, upon * returning we check that we updated at least once. *) let r = ref false in - let update () : V.borrow_content = + let update () : borrow_content = assert (not !r); r := true; nbc @@ -512,7 +507,7 @@ let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_borrow_content env bc = match bc with @@ -555,13 +550,13 @@ let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) This is a helper function: it might break invariants. *) -let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) - (ctx : C.eval_ctx) : C.eval_ctx = +let update_aborrow (ek : exploration_kind) (l : BorrowId.id) (nv : avalue) + (ctx : eval_ctx) : eval_ctx = (* We use a reference to check that we update exactly one borrow: when updating * inside values, we check we don't update more than one borrow. Then, upon * returning we check that we updated at least once. *) let r = ref false in - let update () : V.avalue = + let update () : avalue = assert (not !r); r := true; nv @@ -569,22 +564,22 @@ let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_ABorrow env bc = match bc with - | V.AMutBorrow (bid, av) -> + | AMutBorrow (bid, av) -> if bid = l then update () - else V.ABorrow (super#visit_AMutBorrow env bid av) - | V.ASharedBorrow bid -> + else ABorrow (super#visit_AMutBorrow env bid av) + | ASharedBorrow bid -> if bid = l then update () - else V.ABorrow (super#visit_ASharedBorrow env bid) - | V.AIgnoredMutBorrow _ | V.AEndedMutBorrow _ | V.AEndedSharedBorrow - | V.AEndedIgnoredMutBorrow _ -> + else ABorrow (super#visit_ASharedBorrow env bid) + | AIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedSharedBorrow + | AEndedIgnoredMutBorrow _ -> super#visit_ABorrow env bc - | V.AProjSharedBorrow asb -> + | AProjSharedBorrow asb -> if borrow_in_asb l asb then update () - else V.ABorrow (super#visit_AProjSharedBorrow env asb) + else ABorrow (super#visit_AProjSharedBorrow env asb) method! visit_abs env abs = if ek.enter_abs then super#visit_abs env abs else abs @@ -597,16 +592,16 @@ let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) ctx (** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) -let update_outer_borrows (outer : V.AbstractionId.id option * borrow_ids option) - (x : borrow_ids) : V.AbstractionId.id option * borrow_ids option = +let update_outer_borrows (outer : AbstractionId.id option * borrow_ids option) + (x : borrow_ids) : AbstractionId.id option * borrow_ids option = let abs, opt = outer in (abs, update_if_none opt x) (** Return the first loan we find in a value *) -let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = +let get_first_loan_in_value (v : typed_value) : loan_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_loan_content _ lc = raise (FoundLoanContent lc) end in @@ -617,10 +612,10 @@ let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = with FoundLoanContent lc -> Some lc (** Return the first loan we find in a list of values *) -let get_first_loan_in_values (vs : V.typed_value list) : V.loan_content option = +let get_first_loan_in_values (vs : typed_value list) : loan_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_loan_content _ lc = raise (FoundLoanContent lc) end in @@ -631,10 +626,10 @@ let get_first_loan_in_values (vs : V.typed_value list) : V.loan_content option = with FoundLoanContent lc -> Some lc (** Return the first borrow we find in a value *) -let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = +let get_first_borrow_in_value (v : typed_value) : borrow_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) end in @@ -652,10 +647,10 @@ let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = - if [false]: return the first loan we find, do not dive into borrowed values *) let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) - (v : V.typed_value) : loan_or_borrow_content option = + (v : typed_value) : loan_or_borrow_content option = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_borrow_content _ bc = if with_borrows then raise (FoundBorrowContent bc) else () @@ -671,17 +666,13 @@ let get_first_outer_loan_or_borrow_in_value (with_borrows : bool) | FoundLoanContent lc -> Some (LoanContent lc) | FoundBorrowContent bc -> Some (BorrowContent bc) -type gproj_borrows = - | AProjBorrows of V.AbstractionId.id * V.symbolic_value - | ProjBorrows of V.symbolic_value - let proj_borrows_intersects_proj_loans - (proj_borrows : T.RegionId.Set.t * V.symbolic_value * T.rty) - (proj_loans : T.RegionId.Set.t * V.symbolic_value) : bool = + (proj_borrows : RegionId.Set.t * symbolic_value * rty) + (proj_loans : RegionId.Set.t * symbolic_value) : bool = let b_regions, b_sv, b_ty = proj_borrows in let l_regions, l_sv = proj_loans in if same_symbolic_id b_sv l_sv then - projections_intersect l_sv.V.sv_ty l_regions b_ty b_regions + projections_intersect l_sv.sv_ty l_regions b_ty b_regions else false (** Result of looking up aproj_borrows which intersect a given aproj_loans in @@ -698,8 +689,8 @@ let proj_borrows_intersects_proj_loans found, as well as the projection types used in those abstractions. *) type looked_up_aproj_borrows = - | NonSharedProj of V.AbstractionId.id * T.rty - | SharedProjs of (V.AbstractionId.id * T.rty) list + | NonSharedProj of AbstractionId.id * rty + | SharedProjs of (AbstractionId.id * rty) list (** Lookup the aproj_borrows (including aproj_shared_borrows) over a symbolic value which intersect a given set of regions. @@ -710,15 +701,15 @@ type looked_up_aproj_borrows = This is a helper function. *) let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : looked_up_aproj_borrows option = let found : looked_up_aproj_borrows option ref = ref None in - let set_non_shared ((id, ty) : V.AbstractionId.id * T.rty) : unit = + let set_non_shared ((id, ty) : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (NonSharedProj (id, ty)) | Some _ -> raise (Failure "Unreachable") in - let add_shared (x : V.AbstractionId.id * T.rty) : unit = + let add_shared (x : AbstractionId.id * rty) : unit = match !found with | None -> found := Some (SharedProjs [ x ]) | Some (SharedProjs pl) -> found := Some (SharedProjs (x :: pl)) @@ -727,7 +718,7 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) let check_add_proj_borrows (is_shared : bool) abs sv' proj_ty = if proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) + (abs.regions, sv', proj_ty) (regions, sv) then let x = (abs.abs_id, proj_ty) in @@ -736,7 +727,7 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) in let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_abstract_shared_borrow abs asb = @@ -748,8 +739,8 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) if lookup_shared then let abs = Option.get abs in match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv', proj_ty) -> + | AsbBorrow _ -> () + | AsbProjReborrows (sv', proj_ty) -> let is_shared = true in check_add_proj_borrows is_shared abs sv' proj_ty else () @@ -781,9 +772,8 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) Returns the id of the owning abstraction, and the projection type used in this abstraction. *) -let lookup_intersecting_aproj_borrows_not_shared_opt - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - (V.AbstractionId.id * T.rty) option = +let lookup_intersecting_aproj_borrows_not_shared_opt (regions : RegionId.Set.t) + (sv : symbolic_value) (ctx : eval_ctx) : (AbstractionId.id * rty) option = let lookup_shared = false in match lookup_intersecting_aproj_borrows_opt lookup_shared regions sv ctx with | None -> None @@ -796,10 +786,10 @@ let lookup_intersecting_aproj_borrows_not_shared_opt This is a helper function: it might break invariants. *) let update_intersecting_aproj_borrows (can_update_shared : bool) - (update_shared : V.AbstractionId.id -> T.rty -> V.abstract_shared_borrows) - (update_non_shared : V.AbstractionId.id -> T.rty -> V.aproj) - (regions : T.RegionId.Set.t) (sv : V.symbolic_value) (ctx : C.eval_ctx) : - C.eval_ctx = + (update_shared : AbstractionId.id -> rty -> abstract_shared_borrows) + (update_non_shared : AbstractionId.id -> rty -> aproj) + (regions : RegionId.Set.t) (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx + = (* Small helpers for sanity checks *) let shared = ref None in let add_shared () = @@ -813,7 +803,7 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) let check_proj_borrows is_shared abs sv' proj_ty = if proj_borrows_intersects_proj_loans - (abs.V.regions, sv', proj_ty) + (abs.regions, sv', proj_ty) (regions, sv) then ( if is_shared then add_shared () else set_non_shared (); @@ -823,7 +813,7 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_abstract_shared_borrows abs asb = @@ -832,11 +822,10 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) (* Explore *) if can_update_shared then let abs = Option.get abs in - let update (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = + let update (asb : abstract_shared_borrow) : abstract_shared_borrows = match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv', proj_ty) -> + | AsbBorrow _ -> [ asb ] + | AsbProjReborrows (sv', proj_ty) -> let is_shared = true in if check_proj_borrows is_shared abs sv' proj_ty then update_shared abs.abs_id proj_ty @@ -872,8 +861,8 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) This is a helper function: it might break invariants. *) -let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) (nv : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = +let update_intersecting_aproj_borrows_non_shared (regions : RegionId.Set.t) + (sv : symbolic_value) (nv : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = false in let update_shared _ _ = raise (Failure "Unexpected") in @@ -898,8 +887,8 @@ let update_intersecting_aproj_borrows_non_shared (regions : T.RegionId.Set.t) This is a helper function: it might break invariants. *) -let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) - (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = +let remove_intersecting_aproj_borrows_shared (regions : RegionId.Set.t) + (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Small helpers *) let can_update_shared = true in let update_shared _ _ = [] in @@ -935,19 +924,19 @@ let remove_intersecting_aproj_borrows_shared (regions : T.RegionId.Set.t) [subst]: takes as parameters the abstraction in which we perform the substitution and the list of given back values at the projector of - loans where we perform the substitution (see the fields in {!V.AProjLoans}). + loans where we perform the substitution (see the fields in {!AProjLoans}). Note that the symbolic value at this place is necessarily equal to [sv], which is why we don't give it as parameters. *) -let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) - (proj_ty : T.rty) (sv : V.symbolic_value) - (subst : V.abs -> (V.msymbolic_value * V.aproj) list -> V.aproj) - (ctx : C.eval_ctx) : C.eval_ctx = +let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) + (proj_ty : rty) (sv : symbolic_value) + (subst : abs -> (msymbolic_value * aproj) list -> aproj) (ctx : eval_ctx) : + eval_ctx = (* *) assert (ty_is_rty proj_ty); (* Small helpers for sanity checks *) let updated = ref false in - let update abs local_given_back : V.aproj = + let update abs local_given_back : aproj = (* Note that we can update more than once! *) updated := true; subst abs local_given_back @@ -955,7 +944,7 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_aproj abs sproj = @@ -968,8 +957,7 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) if same_symbolic_id sv sv' then ( assert (sv.sv_ty = sv'.sv_ty); if - projections_intersect proj_ty proj_regions sv'.V.sv_ty - abs.regions + projections_intersect proj_ty proj_regions sv'.sv_ty abs.regions then update abs given_back else super#visit_aproj (Some abs) sproj) else super#visit_aproj (Some abs) sproj @@ -982,18 +970,18 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) (* Return *) ctx -(** Helper function: lookup an {!V.AProjLoans} by using an abstraction id and a +(** Helper function: lookup an {!AProjLoans} by using an abstraction id and a symbolic value. We return the information from the looked up projector of loans. See the - fields in {!V.AProjLoans} (we don't return the symbolic value, because it + fields in {!AProjLoans} (we don't return the symbolic value, because it is equal to [sv]). Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (ctx : C.eval_ctx) : (V.msymbolic_value * V.aproj) list = +let lookup_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) + (ctx : eval_ctx) : (msymbolic_value * aproj) list = (* Small helpers for sanity checks *) let found = ref None in let set_found x = @@ -1004,12 +992,12 @@ let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (* The visitor *) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else () - method! visit_aproj (abs : V.abs option) sproj = + method! visit_aproj (abs : abs option) sproj = (match sproj with | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> @@ -1037,8 +1025,8 @@ let lookup_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) -let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = +let update_aproj_loans (abs_id : AbstractionId.id) (sv : symbolic_value) + (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1050,12 +1038,12 @@ let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_abs _ abs = if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs - method! visit_aproj (abs : V.abs option) sproj = + method! visit_aproj (abs : abs option) sproj = match sproj with | AProjBorrows _ | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> @@ -1086,8 +1074,8 @@ let update_aproj_loans (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) TODO: factorize with {!update_aproj_loans}? *) -let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) - (nproj : V.aproj) (ctx : C.eval_ctx) : C.eval_ctx = +let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) + (nproj : aproj) (ctx : eval_ctx) : eval_ctx = (* Small helpers for sanity checks *) let found = ref false in let update () = @@ -1099,12 +1087,12 @@ let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (* The visitor *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_abs _ abs = if abs.abs_id = abs_id then super#visit_abs (Some abs) abs else abs - method! visit_aproj (abs : V.abs option) sproj = + method! visit_aproj (abs : abs option) sproj = match sproj with | AProjLoans _ | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> @@ -1127,26 +1115,26 @@ let update_aproj_borrows (abs_id : V.AbstractionId.id) (sv : V.symbolic_value) (** Helper function: might break invariants. - Converts an {!V.AProjLoans} to an {!V.AEndedProjLoans}. The projector is identified + Converts an {!AProjLoans} to an {!AEndedProjLoans}. The projector is identified by a symbolic value and an abstraction id. *) -let update_aproj_loans_to_ended (abs_id : V.AbstractionId.id) - (sv : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = +let update_aproj_loans_to_ended (abs_id : AbstractionId.id) + (sv : symbolic_value) (ctx : eval_ctx) : eval_ctx = (* Lookup the projector of loans *) let given_back = lookup_aproj_loans abs_id sv ctx in (* Create the new value for the projector *) - let nproj = V.AEndedProjLoans (sv, given_back) in + let nproj = AEndedProjLoans (sv, given_back) in (* Insert it *) let ctx = update_aproj_loans abs_id sv nproj ctx in (* Return *) ctx -let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) - : unit = +let no_aproj_over_symbolic_in_context (sv : symbolic_value) (ctx : eval_ctx) : + unit = (* The visitor *) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_aproj env sproj = (match sproj with @@ -1167,26 +1155,26 @@ let no_aproj_over_symbolic_in_context (sv : V.symbolic_value) (ctx : C.eval_ctx) **Remark:** we don't take the *ignored* mut/shared loans into account. *) -let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : +let get_first_non_ignored_aloan_in_abstraction (abs : abs) : borrow_ids_or_symbolic_value option = (* Explore to find a loan *) let obj = object - inherit [_] V.iter_abs as super + inherit [_] iter_abs as super method! visit_aloan_content env lc = match lc with - | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) - | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) - | V.AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AEndedSharedLoan (_, _) -> + | AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) + | ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) + | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } + | AEndedSharedLoan (_, _) -> super#visit_aloan_content env lc - | V.AIgnoredMutLoan (_, _) -> + | AIgnoredMutLoan (_, _) -> (* Ignore *) super#visit_aloan_content env lc - | V.AEndedIgnoredMutLoan + | AEndedIgnoredMutLoan { given_back = _; child = _; given_back_meta = _ } - | V.AIgnoredSharedLoan _ -> + | AIgnoredSharedLoan _ -> (* Ignore *) super#visit_aloan_content env lc @@ -1220,8 +1208,8 @@ let get_first_non_ignored_aloan_in_abstraction (abs : V.abs) : (* There are loan projections over symbolic values *) Some (SymbolicValue sv) -let lookup_shared_value_opt (ctx : C.eval_ctx) (bid : V.BorrowId.id) : - V.typed_value option = +let lookup_shared_value_opt (ctx : eval_ctx) (bid : BorrowId.id) : + typed_value option = match lookup_loan_opt ek_all bid ctx with | None -> None | Some (_, lc) -> ( @@ -1230,6 +1218,5 @@ let lookup_shared_value_opt (ctx : C.eval_ctx) (bid : V.BorrowId.id) : Some sv | _ -> None) -let lookup_shared_value (ctx : C.eval_ctx) (bid : V.BorrowId.id) : V.typed_value - = +let lookup_shared_value (ctx : eval_ctx) (bid : BorrowId.id) : typed_value = Option.get (lookup_shared_value_opt ctx bid) diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 2b7ff7d0..ff21cd77 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -3,26 +3,21 @@ * some path utilities for replacement. We might change that in the future (by * using indices to identify the values for instance). *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Types +open PrimitiveValues +open Values +open Contexts open TypesUtils -module Inv = Invariants -module S = SynthesizeSymbolic module SA = SymbolicAst open Cps open ValuesUtils open InterpreterUtils open InterpreterProjectors -open InterpreterBorrows +open Print.EvalCtx +module S = SynthesizeSymbolic (** The local logger *) -let log = L.expansion_log +let log = Logging.expansion_log (** Projector kind *) type proj_kind = LoanProj | BorrowProj @@ -53,10 +48,10 @@ type proj_kind = LoanProj | BorrowProj Note that 2. and 3. may have a little bit of duplicated code, but hopefully it would make things clearer. *) -let apply_symbolic_expansion_to_target_avalues (config : C.config) +let apply_symbolic_expansion_to_target_avalues (config : config) (allow_reborrows : bool) (proj_kind : proj_kind) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = + (original_sv : symbolic_value) (expansion : symbolic_expansion) + (ctx : eval_ctx) : eval_ctx = (* Symbolic values contained in the expansion might contain already ended regions *) let check_symbolic_no_ended = false in (* Prepare reborrows registration *) @@ -66,7 +61,7 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (* Visitor to apply the expansion *) let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** When visiting an abstraction, we remember the regions it owns to be able to properly reduce projectors when expanding symbolic values *) @@ -94,12 +89,12 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (* Explore in depth first - we won't update anything: we simply * want to check we don't have to expand inner symbolic value *) match (aproj, proj_kind) with - | V.AEndedProjBorrows _, _ -> V.ASymbolic aproj - | V.AEndedProjLoans _, _ -> + | AEndedProjBorrows _, _ -> ASymbolic aproj + | AEndedProjLoans _, _ -> (* Explore the given back values to make sure we don't have to expand * anything in there *) - V.ASymbolic (self#visit_aproj (Some current_abs) aproj) - | V.AProjLoans (sv, given_back), LoanProj -> + ASymbolic (self#visit_aproj (Some current_abs) aproj) + | AProjLoans (sv, given_back), LoanProj -> (* Check if this is the symbolic value we are looking for *) if same_symbolic_id sv original_sv then ( (* There mustn't be any given back values *) @@ -107,14 +102,14 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (* Apply the projector *) let projected_value = apply_proj_loans_on_symbolic_expansion proj_regions - ancestors_regions expansion original_sv.V.sv_ty + ancestors_regions expansion original_sv.sv_ty in (* Replace *) - projected_value.V.value) + projected_value.value) else (* Not the searched symbolic value: nothing to do *) super#visit_ASymbolic (Some current_abs) aproj - | V.AProjBorrows (sv, proj_ty), BorrowProj -> + | AProjBorrows (sv, proj_ty), BorrowProj -> (* Check if this is the symbolic value we are looking for *) if same_symbolic_id sv original_sv then (* Convert the symbolic expansion to a value on which we can @@ -132,15 +127,15 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) proj_regions ancestors_regions expansion proj_ty in (* Replace *) - projected_value.V.value + projected_value.value else (* Not the searched symbolic value: nothing to do *) super#visit_ASymbolic (Some current_abs) aproj - | V.AProjLoans _, BorrowProj - | V.AProjBorrows (_, _), LoanProj - | V.AIgnoredProjBorrows, _ -> + | AProjLoans _, BorrowProj + | AProjBorrows (_, _), LoanProj + | AIgnoredProjBorrows, _ -> (* Nothing to do *) - V.ASymbolic aproj + ASymbolic aproj end in (* Apply the expansion *) @@ -151,9 +146,9 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) (** Auxiliary function. Apply a symbolic expansion to avalues in a context. *) -let apply_symbolic_expansion_to_avalues (config : C.config) - (allow_reborrows : bool) (original_sv : V.symbolic_value) - (expansion : V.symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = +let apply_symbolic_expansion_to_avalues (config : config) + (allow_reborrows : bool) (original_sv : symbolic_value) + (expansion : symbolic_expansion) (ctx : eval_ctx) : eval_ctx = let apply_expansion proj_kind ctx = apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind original_sv expansion ctx @@ -168,9 +163,8 @@ let apply_symbolic_expansion_to_avalues (config : C.config) Simply replace the symbolic values (*not avalues*) in the context with a given value. Will break invariants if not used properly. *) -let replace_symbolic_values (at_most_once : bool) - (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : - C.eval_ctx = +let replace_symbolic_values (at_most_once : bool) (original_sv : symbolic_value) + (nv : value) (ctx : eval_ctx) : eval_ctx = (* Count *) let replaced = ref false in let replace () = @@ -181,7 +175,7 @@ let replace_symbolic_values (at_most_once : bool) (* Visitor to apply the substitution *) let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_VSymbolic env spc = if same_symbolic_id spc original_sv then replace () @@ -193,13 +187,13 @@ let replace_symbolic_values (at_most_once : bool) (* Return *) ctx -let apply_symbolic_expansion_non_borrow (config : C.config) - (original_sv : V.symbolic_value) (expansion : V.symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = +let apply_symbolic_expansion_non_borrow (config : config) + (original_sv : symbolic_value) (expansion : symbolic_expansion) + (ctx : eval_ctx) : eval_ctx = (* Apply the expansion to non-abstraction values *) let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in let at_most_once = false in - let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in + let ctx = replace_symbolic_values at_most_once original_sv nv.value ctx in (* Apply the expansion to abstraction values *) let allow_reborrows = false in apply_symbolic_expansion_to_avalues config allow_reborrows original_sv @@ -216,47 +210,47 @@ let apply_symbolic_expansion_non_borrow (config : C.config) doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_non_assumed_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (def_id : T.TypeDeclId.id) (generics : T.generic_args) - (ctx : C.eval_ctx) : V.symbolic_expansion list = + (kind : sv_kind) (def_id : TypeDeclId.id) (generics : generic_args) + (ctx : eval_ctx) : symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) - let def = C.ctx_lookup_type_decl ctx def_id in - assert (List.length generics.regions = List.length def.T.generics.regions); + let def = ctx_lookup_type_decl ctx def_id in + assert (List.length generics.regions = List.length def.generics.regions); (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = - Assoc.type_decl_get_inst_norm_variants_fields_rtypes ctx def generics + AssociatedTypes.type_decl_get_inst_norm_variants_fields_rtypes ctx def + generics in (* Check if there is strictly more than one variant *) if List.length variants_fields_types > 1 && not expand_enumerations then raise (Failure "Not allowed to expand enumerations with several variants"); (* Initialize the expanded value for a given variant *) - let initialize - ((variant_id, field_types) : T.VariantId.id option * T.rty list) : - V.symbolic_expansion = + let initialize ((variant_id, field_types) : VariantId.id option * rty list) : + symbolic_expansion = let field_values = - List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value kind ty) field_types + List.map (fun (ty : rty) -> mk_fresh_symbolic_value kind ty) field_types in - let see = V.SeAdt (variant_id, field_values) in + let see = SeAdt (variant_id, field_values) in see in (* Initialize all the expanded values of all the variants *) List.map initialize variants_fields_types -let compute_expanded_symbolic_tuple_value (kind : V.sv_kind) - (field_types : T.rty list) : V.symbolic_expansion = +let compute_expanded_symbolic_tuple_value (kind : sv_kind) + (field_types : rty list) : symbolic_expansion = (* Generate the field values *) let field_values = List.map (fun sv_ty -> mk_fresh_symbolic_value kind sv_ty) field_types in let variant_id = None in - let see = V.SeAdt (variant_id, field_values) in + let see = SeAdt (variant_id, field_values) in see -let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : - V.symbolic_expansion = +let compute_expanded_symbolic_box_value (kind : sv_kind) (boxed_ty : rty) : + symbolic_expansion = (* Introduce a fresh symbolic value *) let boxed_value = mk_fresh_symbolic_value kind boxed_ty in - let see = V.SeAdt (None, [ boxed_value ]) in + let see = SeAdt (None, [ boxed_value ]) in see (** Compute the expansion of an adt value. @@ -269,51 +263,51 @@ let compute_expanded_symbolic_box_value (kind : V.sv_kind) (boxed_ty : T.rty) : doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (kind : V.sv_kind) (adt_id : T.type_id) (generics : T.generic_args) - (ctx : C.eval_ctx) : V.symbolic_expansion list = + (kind : sv_kind) (adt_id : type_id) (generics : generic_args) + (ctx : eval_ctx) : symbolic_expansion list = match (adt_id, generics.regions, generics.types) with - | T.TAdtId def_id, _, _ -> + | TAdtId def_id, _, _ -> compute_expanded_symbolic_non_assumed_adt_value expand_enumerations kind def_id generics ctx - | T.TTuple, [], _ -> + | TTuple, [], _ -> [ compute_expanded_symbolic_tuple_value kind generics.types ] - | T.TAssumed T.TBox, [], [ boxed_ty ] -> + | TAssumed TBox, [], [ boxed_ty ] -> [ compute_expanded_symbolic_box_value kind boxed_ty ] | _ -> raise (Failure "compute_expanded_symbolic_adt_value: unexpected combination") -let expand_symbolic_value_shared_borrow (config : C.config) - (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (ref_ty : T.rty) : cm_fun = +let expand_symbolic_value_shared_borrow (config : config) + (original_sv : symbolic_value) (original_sv_place : SA.mplace option) + (ref_ty : rty) : cm_fun = fun cf ctx -> (* First, replace the projectors on borrows. * The important point is that the symbolic value to expand may appear * several times, if it has been copied. In this case, we need to introduce * one fresh borrow id per instance. *) - let borrows = ref V.BorrowId.Set.empty in + let borrows = ref BorrowId.Set.empty in let fresh_borrow () = - let bid' = C.fresh_borrow_id () in - borrows := V.BorrowId.Set.add bid' !borrows; + let bid' = fresh_borrow_id () in + borrows := BorrowId.Set.add bid' !borrows; bid' in (* Small utility used on shared borrows in abstractions (regular borrow * projector and asb). * Returns [Some] if the symbolic value has been expanded to an asb list, * [None] otherwise *) - let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : - V.abstract_shared_borrows option = + let reborrow_ashared proj_regions (sv : symbolic_value) (proj_ty : rty) : + abstract_shared_borrows option = if same_symbolic_id sv original_sv then match proj_ty with - | T.TRef (r, ref_ty, T.Shared) -> + | TRef (r, ref_ty, RShared) -> (* Projector over the shared value *) - let shared_asb = V.AsbProjReborrows (sv, ref_ty) in + let shared_asb = AsbProjReborrows (sv, ref_ty) in (* Check if the region is in the set of projected regions *) if region_in_set r proj_regions then (* In the set: we need to reborrow *) let bid = fresh_borrow () in - Some [ V.AsbBorrow bid; shared_asb ] + Some [ AsbBorrow bid; shared_asb ] else (* Not in the set: ignore *) Some [ shared_asb ] | _ -> raise (Failure "Unexpected") @@ -324,7 +318,7 @@ let expand_symbolic_value_shared_borrow (config : C.config) (* Visitor to replace the projectors on borrows *) let obj = object (self) - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_VSymbolic env sv = if same_symbolic_id sv original_sv then @@ -334,21 +328,21 @@ let expand_symbolic_value_shared_borrow (config : C.config) method! visit_EAbs proj_regions abs = assert (Option.is_none proj_regions); - let proj_regions = Some abs.V.regions in + let proj_regions = Some abs.regions in super#visit_EAbs proj_regions abs method! visit_AProjSharedBorrow proj_regions asb = - let expand_asb (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = + let expand_asb (asb : abstract_shared_borrow) : abstract_shared_borrows + = match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv, proj_ty) -> ( + | AsbBorrow _ -> [ asb ] + | AsbProjReborrows (sv, proj_ty) -> ( match reborrow_ashared (Option.get proj_regions) sv proj_ty with | None -> [ asb ] | Some asb -> asb) in let asb = List.concat (List.map expand_asb asb) in - V.AProjSharedBorrow asb + AProjSharedBorrow asb (** We carefully updated {!visit_ASymbolic} so that {!visit_aproj} is called only on child projections (i.e., projections which appear in {!AEndedProjLoans}). @@ -365,27 +359,27 @@ let expand_symbolic_value_shared_borrow (config : C.config) method! visit_ASymbolic proj_regions aproj = match aproj with | AEndedProjBorrows _ | AIgnoredProjBorrows -> - (* We ignore borrows *) V.ASymbolic aproj + (* We ignore borrows *) ASymbolic aproj | AProjLoans _ -> (* Loans are handled later *) - V.ASymbolic aproj + ASymbolic aproj | AProjBorrows (sv, proj_ty) -> ( (* Check if we need to reborrow *) match reborrow_ashared (Option.get proj_regions) sv proj_ty with | None -> super#visit_ASymbolic proj_regions aproj - | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) + | Some asb -> ABorrow (AProjSharedBorrow asb)) | AEndedProjLoans _ -> (* Sanity check: make sure there is nothing to expand inside the * children projections *) - V.ASymbolic (self#visit_aproj proj_regions aproj) + ASymbolic (self#visit_aproj proj_regions aproj) end in (* Call the visitor *) let ctx = obj#visit_eval_ctx None ctx in (* Finally, replace the projectors on loans *) let bids = !borrows in - assert (not (V.BorrowId.Set.is_empty bids)); - let see = V.SeSharedRef (bids, shared_sv) in + assert (not (BorrowId.Set.is_empty bids)); + let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see @@ -398,28 +392,26 @@ let expand_symbolic_value_shared_borrow (config : C.config) expr (** TODO: simplify and merge with the other expansion function *) -let expand_symbolic_value_borrow (config : C.config) - (original_sv : V.symbolic_value) (original_sv_place : SA.mplace option) - (region : T.region) (ref_ty : T.rty) (rkind : T.ref_kind) : cm_fun = +let expand_symbolic_value_borrow (config : config) + (original_sv : symbolic_value) (original_sv_place : SA.mplace option) + (region : region) (ref_ty : rty) (rkind : ref_kind) : cm_fun = fun cf ctx -> - assert (region <> T.RErased); + assert (region <> RErased); (* Check that we are allowed to expand the reference *) assert (not (region_in_set region ctx.ended_regions)); (* Match on the reference kind *) match rkind with - | T.Mut -> + | RMut -> (* Simple case: simply create a fresh symbolic value and a fresh * borrow id *) let sv = mk_fresh_symbolic_value original_sv.sv_kind ref_ty in - let bid = C.fresh_borrow_id () in - let see = V.SeMutRef (bid, sv) in + let bid = fresh_borrow_id () in + let see = SeMutRef (bid, sv) in (* Expand the symbolic values - we simply perform a substitution (and * check that we perform exactly one substitution) *) let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in let at_most_once = true in - let ctx = - replace_symbolic_values at_most_once original_sv nv.V.value ctx - in + let ctx = replace_symbolic_values at_most_once original_sv nv.value ctx in (* Expand the symbolic avalues *) let allow_reborrows = true in let ctx = @@ -431,7 +423,7 @@ let expand_symbolic_value_borrow (config : C.config) (* Update the synthesized program *) S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see expr - | T.Shared -> + | RShared -> expand_symbolic_value_shared_borrow config original_sv original_sv_place ref_ty cf ctx @@ -451,9 +443,9 @@ let expand_symbolic_value_borrow (config : C.config) We need this continuation separately (i.e., we can't compose it with the continuations in [see_cf_l]) because we perform a join *before* calling it. *) -let apply_branching_symbolic_expansions_non_borrow (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) - (see_cf_l : (V.symbolic_expansion option * st_cm_fun) list) +let apply_branching_symbolic_expansions_non_borrow (config : config) + (sv : symbolic_value) (sv_place : SA.mplace option) + (see_cf_l : (symbolic_expansion option * st_cm_fun) list) (cf_after_join : st_m_fun) : m_fun = fun ctx -> assert (see_cf_l <> []); @@ -494,25 +486,25 @@ let apply_branching_symbolic_expansions_non_borrow (config : C.config) let seel = List.map fst see_cf_l in S.synthesize_symbolic_expansion sv sv_place seel subterms -let expand_symbolic_bool (config : C.config) (sv : V.symbolic_value) +let expand_symbolic_bool (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_true : st_cm_fun) (cf_false : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> (* Compute the expanded value *) let original_sv = sv in let original_sv_place = sv_place in - let rty = original_sv.V.sv_ty in - assert (rty = T.TLiteral PV.TBool); + let rty = original_sv.sv_ty in + assert (rty = TLiteral TBool); (* Expand the symbolic value to true or false and continue execution *) - let see_true = V.SeLiteral (PV.VBool true) in - let see_false = V.SeLiteral (PV.VBool false) in + let see_true = SeLiteral (VBool true) in + let see_false = SeLiteral (VBool false) in let seel = [ (Some see_true, cf_true); (Some see_false, cf_false) ] in (* Apply the symbolic expansion (this also outputs the updated symbolic AST) *) apply_branching_symbolic_expansions_non_borrow config original_sv original_sv_place seel cf_after_join ctx -let expand_symbolic_value_no_branching (config : C.config) - (sv : V.symbolic_value) (sv_place : SA.mplace option) : cm_fun = +let expand_symbolic_value_no_branching (config : config) (sv : symbolic_value) + (sv_place : SA.mplace option) : cm_fun = fun cf ctx -> (* Debug *) log#ldebug @@ -524,12 +516,12 @@ let expand_symbolic_value_no_branching (config : C.config) * fresh symbolic values in the context (which thus gets updated) *) let original_sv = sv in let original_sv_place = sv_place in - let rty = original_sv.V.sv_ty in + let rty = original_sv.sv_ty in let cc : cm_fun = fun cf ctx -> match rty with (* ADTs *) - | T.TAdt (adt_id, generics) -> + | TAdt (adt_id, generics) -> (* Compute the expanded value *) let allow_branching = false in let seel = @@ -548,14 +540,14 @@ let expand_symbolic_value_no_branching (config : C.config) S.synthesize_symbolic_expansion_no_branching original_sv original_sv_place see expr (* Borrows *) - | T.TRef (region, ref_ty, rkind) -> + | TRef (region, ref_ty, rkind) -> expand_symbolic_value_borrow config original_sv original_sv_place region ref_ty rkind cf ctx | _ -> raise (Failure ("expand_symbolic_value_no_branching: unexpected type: " - ^ T.show_rty rty)) + ^ show_rty rty)) in (* Debug *) let cc = @@ -567,12 +559,12 @@ let expand_symbolic_value_no_branching (config : C.config) ^ "\n\n- original context:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n- new context:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx))) + assert (not (symbolic_value_id_in_ctx original_sv.sv_id ctx))) in (* Continue *) cc cf ctx -let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) +let expand_symbolic_adt (config : config) (sv : symbolic_value) (sv_place : SA.mplace option) (cf_branches : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = fun ctx -> @@ -582,11 +574,11 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) * fresh symbolic values in the context (which thus gets updated) *) let original_sv = sv in let original_sv_place = sv_place in - let rty = original_sv.V.sv_ty in + let rty = original_sv.sv_ty in (* Execute *) match rty with (* ADTs *) - | T.TAdt (adt_id, generics) -> + | TAdt (adt_id, generics) -> let allow_branching = true in (* Compute the expanded value *) let seel = @@ -598,15 +590,14 @@ let expand_symbolic_adt (config : C.config) (sv : V.symbolic_value) apply_branching_symbolic_expansions_non_borrow config original_sv original_sv_place seel cf_after_join ctx | _ -> - raise - (Failure ("expand_symbolic_adt: unexpected type: " ^ T.show_rty rty)) + raise (Failure ("expand_symbolic_adt: unexpected type: " ^ show_rty rty)) -let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) - (sv_place : SA.mplace option) (int_type : T.integer_type) - (tgts : (V.scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) +let expand_symbolic_int (config : config) (sv : symbolic_value) + (sv_place : SA.mplace option) (int_type : integer_type) + (tgts : (scalar_value * st_cm_fun) list) (otherwise : st_cm_fun) (cf_after_join : st_m_fun) : m_fun = (* Sanity check *) - assert (sv.V.sv_ty = T.TLiteral (PV.TInteger int_type)); + assert (sv.sv_ty = TLiteral (TInteger int_type)); (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is @@ -617,7 +608,7 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) * (optional expansion, statement to execute) *) let seel = - List.map (fun (v, cf) -> (Some (V.SeLiteral (PV.VScalar v)), cf)) tgts + List.map (fun (v, cf) -> (Some (SeLiteral (VScalar v)), cf)) tgts in let seel = List.append seel [ (None, otherwise) ] in (* Then expand and evaluate - this generates the proper symbolic AST *) @@ -632,15 +623,15 @@ let expand_symbolic_int (config : C.config) (sv : V.symbolic_value) an enumeration with strictly more than one variant, a slice, etc.) or if we need to expand a recursive type (because this leads to looping). *) -let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = +let greedy_expand_symbolics_with_borrows (config : config) : cm_fun = fun cf ctx -> (* The visitor object, to look for symbolic values in the concrete environment *) let obj = object - inherit [_] C.iter_eval_ctx + inherit [_] iter_eval_ctx method! visit_VSymbolic _ sv = - if ty_has_borrows ctx.type_context.type_infos sv.V.sv_ty then + if ty_has_borrows ctx.type_context.type_infos sv.sv_ty then raise (FoundSymbolicValue sv) else () @@ -669,7 +660,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = (* {!expand_symbolic_value_no_branching} checks if there are branchings, * but we prefer to also check it here - this leads to cleaner messages * and debugging *) - let def = C.ctx_lookup_type_decl ctx def_id in + let def = ctx_lookup_type_decl ctx def_id in (match def.kind with | Struct _ | Enum ([] | [ _ ]) -> () | Enum (_ :: _) -> @@ -678,17 +669,17 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = ("Attempted to greedily expand a symbolic enumeration \ with > 1 variants (option \ [greedy_expand_symbolics_with_borrows] of [config]): " - ^ Print.name_to_string def.name)) + ^ name_to_string ctx def.name)) | Opaque -> raise (Failure "Attempted to greedily expand an opaque type")); (* Also, we need to check if the definition is recursive *) - if C.ctx_type_decl_is_rec ctx def_id then + if ctx_type_decl_is_rec ctx def_id then raise (Failure ("Attempted to greedily expand a recursive definition \ (option [greedy_expand_symbolics_with_borrows] of \ [config]): " - ^ Print.name_to_string def.name)) + ^ name_to_string ctx def.name)) else expand_symbolic_value_no_branching config sv None | TAdt ((TTuple | TAssumed TBox), _) | TRef (_, _, _) -> (* Ok *) @@ -707,7 +698,7 @@ let greedy_expand_symbolics_with_borrows (config : C.config) : cm_fun = (* Apply *) expand cf ctx -let greedy_expand_symbolic_values (config : C.config) : cm_fun = +let greedy_expand_symbolic_values (config : config) : cm_fun = fun cf ctx -> if Config.greedy_expand_symbolics_with_borrows then ( log#ldebug (lazy "greedy_expand_symbolic_values"); diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index b9165ecb..6ea75d0b 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -1,15 +1,8 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic -module SA = SymbolicAst +open PrimitiveValues +open Values +open Contexts open Cps -open InterpreterBorrows +module SA = SymbolicAst type proj_kind = LoanProj | BorrowProj @@ -20,15 +13,11 @@ type proj_kind = LoanProj | BorrowProj This function does *not* update the synthesis. *) val apply_symbolic_expansion_non_borrow : - C.config -> - V.symbolic_value -> - V.symbolic_expansion -> - C.eval_ctx -> - C.eval_ctx + config -> symbolic_value -> symbolic_expansion -> eval_ctx -> eval_ctx (** Expand a symhbolic value, without branching *) val expand_symbolic_value_no_branching : - C.config -> V.symbolic_value -> SA.mplace option -> cm_fun + config -> symbolic_value -> SA.mplace option -> cm_fun (** Expand a symbolic enumeration (leads to branching if the enumeration has more than one variant). @@ -44,12 +33,7 @@ val expand_symbolic_value_no_branching : then call it). *) val expand_symbolic_adt : - C.config -> - V.symbolic_value -> - SA.mplace option -> - st_cm_fun -> - st_m_fun -> - m_fun + config -> symbolic_value -> SA.mplace option -> st_cm_fun -> st_m_fun -> m_fun (** Expand a symbolic boolean. @@ -58,8 +42,8 @@ val expand_symbolic_adt : parameter (here, there are exactly two branches). *) val expand_symbolic_bool : - C.config -> - V.symbolic_value -> + config -> + symbolic_value -> SA.mplace option -> st_cm_fun -> st_cm_fun -> @@ -86,16 +70,16 @@ val expand_symbolic_bool : switch. The continuation is thus for the execution *after* the switch. *) val expand_symbolic_int : - C.config -> - V.symbolic_value -> + config -> + symbolic_value -> SA.mplace option -> - T.integer_type -> - (V.scalar_value * st_cm_fun) list -> + integer_type -> + (scalar_value * st_cm_fun) list -> st_cm_fun -> st_m_fun -> m_fun (** If this mode is activated through the [config], greedily expand the symbolic - values which need to be expanded. See {!type:C.config} for more information. + values which need to be expanded. See {!type:config} for more information. *) -val greedy_expand_symbolic_values : C.config -> cm_fun +val greedy_expand_symbolic_values : config -> cm_fun diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 58426cad..1e28fd4b 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -1,25 +1,21 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module LA = LlbcAst +open PrimitiveValues +open Types +open Values +open LlbcAst open Scalars -module E = Expressions +open Expressions open Utils -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic +open SynthesizeSymbolic open Cps open InterpreterUtils open InterpreterExpansion open InterpreterPaths (** The local logger *) -let log = L.expressions_log +let log = Logging.expressions_log (** As long as there are symbolic values at a given place (potentially in subvalues) which contain borrows and are primitively copyable, expand them. @@ -29,8 +25,8 @@ let log = L.expressions_log Note that the place should have been prepared so that there are no remaining loans. *) -let expand_primitively_copyable_at_place (config : C.config) - (access : access_kind) (p : E.place) : cm_fun = +let expand_primitively_copyable_at_place (config : config) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> (* Small helper *) let rec expand : cm_fun = @@ -43,8 +39,7 @@ let expand_primitively_copyable_at_place (config : C.config) | None -> cf ctx | Some sv -> let cc = - expand_symbolic_value_no_branching config sv - (Some (S.mk_mplace p ctx)) + expand_symbolic_value_no_branching config sv (Some (mk_mplace p ctx)) in comp cc expand cf ctx in @@ -56,8 +51,8 @@ let expand_primitively_copyable_at_place (config : C.config) We also check that the value *doesn't contain bottoms or reserved borrows*. *) -let read_place (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = +let read_place (access : access_kind) (p : place) (cf : typed_value -> m_fun) : + m_fun = fun ctx -> let v = read_place access p ctx in (* Check that there are no bottoms in the value *) @@ -67,9 +62,9 @@ let read_place (access : access_kind) (p : E.place) (* Call the continuation *) cf v ctx -let access_rplace_reorganize_and_read (config : C.config) - (expand_prim_copy : bool) (access : access_kind) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = +let access_rplace_reorganize_and_read (config : config) + (expand_prim_copy : bool) (access : access_kind) (p : place) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Make sure we can evaluate the path *) let cc = update_ctx_along_read_place config access p in @@ -87,16 +82,15 @@ let access_rplace_reorganize_and_read (config : C.config) (* Compose *) comp cc read_place cf ctx -let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) - (access : access_kind) (p : E.place) : cm_fun = +let access_rplace_reorganize (config : config) (expand_prim_copy : bool) + (access : access_kind) (p : place) : cm_fun = fun cf ctx -> access_rplace_reorganize_and_read config expand_prim_copy access p (fun _v -> cf) ctx (** Convert an operand constant operand value to a typed value *) -let literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : - V.typed_value = +let literal_to_typed_value (ty : literal_type) (cv : literal) : typed_value = (* Check the type while converting - we actually need some information * contained in the type *) log#ldebug @@ -105,13 +99,13 @@ let literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : ^ Print.PrimitiveValues.literal_to_string cv)); match (ty, cv) with (* Scalar, boolean... *) - | PV.TBool, VBool v -> { V.value = V.VLiteral (VBool v); ty = T.TLiteral ty } - | TChar, VChar v -> { V.value = V.VLiteral (VChar v); ty = T.TLiteral ty } - | TInteger int_ty, PV.VScalar v -> + | TBool, VBool v -> { value = VLiteral (VBool v); ty = TLiteral ty } + | TChar, VChar v -> { value = VLiteral (VChar v); ty = TLiteral ty } + | TInteger int_ty, VScalar v -> (* Check the type and the ranges *) assert (int_ty = v.int_ty); assert (check_scalar_value_in_range v); - { V.value = V.VLiteral (PV.VScalar v); ty = T.TLiteral ty } + { value = VLiteral (VScalar v); ty = TLiteral ty } (* Remaining cases (invalid) *) | _, _ -> raise (Failure "Improperly typed constant value") @@ -126,8 +120,8 @@ let literal_to_typed_value (ty : PV.literal_type) (cv : V.literal) : parameter to control this copy ([allow_adt_copy]). Note that here by ADT we mean the user-defined ADTs (not tuples or assumed types). *) -let rec copy_value (allow_adt_copy : bool) (config : C.config) - (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = +let rec copy_value (allow_adt_copy : bool) (config : config) (ctx : eval_ctx) + (v : typed_value) : eval_ctx * typed_value = log#ldebug (lazy ("copy_value: " @@ -170,7 +164,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) | VSharedBorrow bid -> (* We need to create a new borrow id for the copied borrow, and * update the context accordingly *) - let bid' = C.fresh_borrow_id () in + let bid' = fresh_borrow_id () in let ctx = InterpreterBorrows.reborrow_shared bid bid' ctx in (ctx, { v with value = VBorrow (VSharedBorrow bid') }) | VMutBorrow (_, _) -> raise (Failure "Can't copy a mutable borrow") @@ -188,7 +182,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - assert (ty_is_primitively_copyable (Subst.erase_regions sp.sv_ty)); + assert (ty_is_primitively_copyable (Substitute.erase_regions sp.sv_ty)); (* If the type is copyable, we simply return the current value. Side * remark: what is important to look at when copying symbolic values * is symbolic expansion. The important subcase is the expansion of shared @@ -233,8 +227,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) what we do in the formalization (because we don't enforce the same constraints as MIR in the formalization). *) -let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : - cm_fun = +let prepare_eval_operand_reorganize (config : config) (op : operand) : cm_fun = fun cf ctx -> let prepare : cm_fun = fun cf ctx -> @@ -258,8 +251,8 @@ let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : prepare cf ctx (** Evaluate an operand, without reorganizing the context before *) -let eval_operand_no_reorganize (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = +let eval_operand_no_reorganize (config : config) (op : operand) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug @@ -271,11 +264,11 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) | Constant cv -> ( match cv.value with | CLiteral lit -> - cf (literal_to_typed_value (TypesUtils.ty_as_literal cv.ty) lit) ctx + cf (literal_to_typed_value (ty_as_literal cv.ty) lit) ctx | CTraitConst (trait_ref, generics, const_name) -> ( - assert (generics = TypesUtils.mk_empty_generic_args); + assert (generics = empty_generic_args); match trait_ref.trait_id with - | T.TraitImpl _ -> + | TraitImpl _ -> (* This shouldn't happen: if we refer to a concrete implementation, we should directly refer to the top-level constant *) raise (Failure "Unreachable") @@ -285,14 +278,13 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) let ctx0 = ctx in (* Lookup the trait declaration to retrieve the type of the symbolic value *) let trait_decl = - C.ctx_lookup_trait_decl ctx - trait_ref.trait_decl_ref.trait_decl_id + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in let _, (ty, _) = List.find (fun (name, _) -> name = const_name) trait_decl.consts in (* Introduce a fresh symbolic value *) - let v = mk_fresh_symbolic_typed_value V.TraitConst ty in + let v = mk_fresh_symbolic_typed_value TraitConst ty in (* Continue the evaluation *) let e = cf v ctx in (* We have to wrap the generated expression *) @@ -310,7 +302,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) | CVar vid -> ( let ctx0 = ctx in (* Lookup the const generic value *) - let cv = C.ctx_lookup_const_generic_value ctx vid in + let cv = ctx_lookup_const_generic_value ctx vid in (* Copy the value *) let allow_adt_copy = false in let ctx, v = copy_value allow_adt_copy config ctx cv in @@ -322,7 +314,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) | Some e -> (* If we are synthesizing a symbolic AST, it means that we are in symbolic mode: the value of the const generic is necessarily symbolic. *) - assert (is_symbolic cv.V.value); + assert (is_symbolic cv.value); (* *) Some (SymbolicAst.IntroSymbolic @@ -362,15 +354,15 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) fun ctx -> (* Check that there are no bottoms in the value we are about to move *) assert (not (bottom_in_value ctx.ended_regions v)); - let bottom : V.typed_value = { V.value = VBottom; ty = v.ty } in + let bottom : typed_value = { value = VBottom; ty = v.ty } in let ctx = write_place access p bottom ctx in cf v ctx in (* Compose and apply *) comp cc move cf ctx -let eval_operand (config : C.config) (op : E.operand) - (cf : V.typed_value -> m_fun) : m_fun = +let eval_operand (config : config) (op : operand) (cf : typed_value -> m_fun) : + m_fun = fun ctx -> (* Debug *) log#ldebug @@ -387,13 +379,13 @@ let eval_operand (config : C.config) (op : E.operand) See [prepare_eval_operand_reorganize]. *) -let prepare_eval_operands_reorganize (config : C.config) (ops : E.operand list) - : cm_fun = +let prepare_eval_operands_reorganize (config : config) (ops : operand list) : + cm_fun = fold_left_apply_continuation (prepare_eval_operand_reorganize config) ops (** Evaluate several operands. *) -let eval_operands (config : C.config) (ops : E.operand list) - (cf : V.typed_value list -> m_fun) : m_fun = +let eval_operands (config : config) (ops : operand list) + (cf : typed_value list -> m_fun) : m_fun = fun ctx -> (* Prepare the operands *) let prepare = prepare_eval_operands_reorganize config ops in @@ -404,8 +396,8 @@ let eval_operands (config : C.config) (ops : E.operand list) (* Compose and apply *) comp prepare eval cf ctx -let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) - (cf : V.typed_value * V.typed_value -> m_fun) : m_fun = +let eval_two_operands (config : config) (op1 : operand) (op2 : operand) + (cf : typed_value * typed_value -> m_fun) : m_fun = let eval_op = eval_operands config [ op1; op2 ] in let use_res cf res = match res with @@ -414,73 +406,73 @@ let eval_two_operands (config : C.config) (op1 : E.operand) (op2 : E.operand) in comp eval_op use_res cf -let eval_unary_op_concrete (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op_concrete (config : config) (unop : unop) (op : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operand *) let eval_op = eval_operand config op in (* Apply the unop *) - let apply cf (v : V.typed_value) : m_fun = - match (unop, v.V.value) with - | E.Not, V.VLiteral (VBool b) -> - cf (Ok { v with V.value = V.VLiteral (VBool (not b)) }) - | E.Neg, V.VLiteral (PV.VScalar sv) -> ( - let i = Z.neg sv.PV.value in + let apply cf (v : typed_value) : m_fun = + match (unop, v.value) with + | Not, VLiteral (VBool b) -> + cf (Ok { v with value = VLiteral (VBool (not b)) }) + | Neg, VLiteral (VScalar sv) -> ( + let i = Z.neg sv.value in match mk_scalar sv.int_ty i with | Error _ -> cf (Error EPanic) - | Ok sv -> cf (Ok { v with V.value = V.VLiteral (PV.VScalar sv) })) - | E.Cast (E.CastInteger (src_ty, tgt_ty)), V.VLiteral (PV.VScalar sv) -> ( + | Ok sv -> cf (Ok { v with value = VLiteral (VScalar sv) })) + | Cast (CastInteger (src_ty, tgt_ty)), VLiteral (VScalar sv) -> ( assert (src_ty = sv.int_ty); - let i = sv.PV.value in + let i = sv.value in match mk_scalar tgt_ty i with | Error _ -> cf (Error EPanic) | Ok sv -> - let ty = T.TLiteral (TInteger tgt_ty) in - let value = V.VLiteral (PV.VScalar sv) in - cf (Ok { V.ty; value })) + let ty = TLiteral (TInteger tgt_ty) in + let value = VLiteral (VScalar sv) in + cf (Ok { ty; value })) | _ -> raise (Failure "Invalid input for unop") in comp eval_op apply cf -let eval_unary_op_symbolic (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op_symbolic (config : config) (unop : unop) (op : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operand *) let eval_op = eval_operand config op in (* Generate a fresh symbolic value to store the result *) - let apply cf (v : V.typed_value) : m_fun = + let apply cf (v : typed_value) : m_fun = fun ctx -> - let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_id = fresh_symbolic_value_id () in let res_sv_ty = - match (unop, v.V.ty) with - | E.Not, (T.TLiteral TBool as lty) -> lty - | E.Neg, (T.TLiteral (TInteger _) as lty) -> lty - | E.Cast (E.CastInteger (_, tgt_ty)), _ -> T.TLiteral (TInteger tgt_ty) + match (unop, v.ty) with + | Not, (TLiteral TBool as lty) -> lty + | Neg, (TLiteral (TInteger _) as lty) -> lty + | Cast (CastInteger (_, tgt_ty)), _ -> TLiteral (TInteger tgt_ty) | _ -> raise (Failure "Invalid input for unop") in let res_sv = - { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } + { sv_kind = FunCallRet; sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuation *) let expr = cf (Ok (mk_typed_value_from_symbolic_value res_sv)) ctx in (* Synthesize the symbolic AST *) - S.synthesize_unary_op ctx unop v - (S.mk_opt_place_from_op op ctx) + synthesize_unary_op ctx unop v + (mk_opt_place_from_op op ctx) res_sv None expr in (* Compose and apply *) comp eval_op apply cf ctx -let eval_unary_op (config : C.config) (unop : E.unop) (op : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_unary_op (config : config) (unop : unop) (op : operand) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with - | C.ConcreteMode -> eval_unary_op_concrete config unop op cf - | C.SymbolicMode -> eval_unary_op_symbolic config unop op cf + | ConcreteMode -> eval_unary_op_concrete config unop op cf + | SymbolicMode -> eval_unary_op_symbolic config unop op cf (** Small helper for [eval_binary_op_concrete]: computes the result of applying the binop *after* the operands have been successfully evaluated *) -let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) - (v2 : V.typed_value) : (V.typed_value, eval_error) result = +let eval_binary_op_concrete_compute (binop : binop) (v1 : typed_value) + (v2 : typed_value) : (typed_value, eval_error) result = (* Equality check binops (Eq, Ne) accept values from a wide variety of types. * The remaining binops only operate on scalars. *) if binop = Eq || binop = Ne then ( @@ -489,53 +481,52 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) (* Equality/inequality check is primitive only for a subset of types *) assert (ty_is_primitively_copyable v1.ty); let b = v1 = v2 in - Ok { V.value = V.VLiteral (VBool b); ty = T.TLiteral TBool }) + Ok { value = VLiteral (VBool b); ty = TLiteral TBool }) else (* For the non-equality operations, the input values are necessarily scalars *) - match (v1.V.value, v2.V.value) with - | V.VLiteral (PV.VScalar sv1), V.VLiteral (PV.VScalar sv2) -> ( + match (v1.value, v2.value) with + | VLiteral (VScalar sv1), VLiteral (VScalar sv2) -> ( (* There are binops which require the two operands to have the same type, and binops for which it is not the case. There are also binops which return booleans, and binops which return integers. *) match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> + | Lt | Le | Ge | Gt -> (* The two operands must have the same type and the result is a boolean *) assert (sv1.int_ty = sv2.int_ty); let b = match binop with - | E.Lt -> Z.lt sv1.PV.value sv2.PV.value - | E.Le -> Z.leq sv1.PV.value sv2.PV.value - | E.Ge -> Z.geq sv1.PV.value sv2.PV.value - | E.Gt -> Z.gt sv1.PV.value sv2.PV.value - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> + | Lt -> Z.lt sv1.value sv2.value + | Le -> Z.leq sv1.value sv2.value + | Ge -> Z.geq sv1.value sv2.value + | Gt -> Z.gt sv1.value sv2.value + | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr | Shl + | Shr | Ne | Eq -> raise (Failure "Unreachable") in Ok - ({ V.value = V.VLiteral (VBool b); ty = T.TLiteral TBool } - : V.typed_value) - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd | E.BitOr - -> ( + ({ value = VLiteral (VBool b); ty = TLiteral TBool } + : typed_value) + | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> ( (* The two operands must have the same type and the result is an integer *) assert (sv1.int_ty = sv2.int_ty); let res = match binop with - | E.Div -> - if sv2.PV.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.div sv1.PV.value sv2.PV.value) - | E.Rem -> + | Div -> + if sv2.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.div sv1.value sv2.value) + | Rem -> (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) - if sv2.PV.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.rem sv1.PV.value sv2.PV.value) - | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.PV.value sv2.PV.value) - | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.PV.value sv2.PV.value) - | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.PV.value sv2.PV.value) - | E.BitXor -> raise Unimplemented - | E.BitAnd -> raise Unimplemented - | E.BitOr -> raise Unimplemented - | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> + if sv2.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.rem sv1.value sv2.value) + | Add -> mk_scalar sv1.int_ty (Z.add sv1.value sv2.value) + | Sub -> mk_scalar sv1.int_ty (Z.sub sv1.value sv2.value) + | Mul -> mk_scalar sv1.int_ty (Z.mul sv1.value sv2.value) + | BitXor -> raise Unimplemented + | BitAnd -> raise Unimplemented + | BitOr -> raise Unimplemented + | Lt | Le | Ge | Gt | Shl | Shr | Ne | Eq -> raise (Failure "Unreachable") in match res with @@ -543,97 +534,93 @@ let eval_binary_op_concrete_compute (binop : E.binop) (v1 : V.typed_value) | Ok sv -> Ok { - V.value = V.VLiteral (PV.VScalar sv); - ty = T.TLiteral (TInteger sv1.int_ty); + value = VLiteral (VScalar sv); + ty = TLiteral (TInteger sv1.int_ty); }) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) + | Shl | Shr -> raise Unimplemented + | Ne | Eq -> raise (Failure "Unreachable")) | _ -> raise (Failure "Invalid inputs for binop") -let eval_binary_op_concrete (config : C.config) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op_concrete (config : config) (binop : binop) (op1 : operand) + (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = (* Evaluate the operands *) let eval_ops = eval_two_operands config op1 op2 in (* Compute the result of the binop *) - let compute cf (res : V.typed_value * V.typed_value) = + let compute cf (res : typed_value * typed_value) = let v1, v2 = res in cf (eval_binary_op_concrete_compute binop v1 v2) in (* Compose and apply *) comp eval_ops compute cf -let eval_binary_op_symbolic (config : C.config) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_binary_op_symbolic (config : config) (binop : binop) (op1 : operand) + (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> (* Evaluate the operands *) let eval_ops = eval_two_operands config op1 op2 in (* Compute the result of applying the binop *) - let compute cf ((v1, v2) : V.typed_value * V.typed_value) : m_fun = + let compute cf ((v1, v2) : typed_value * typed_value) : m_fun = fun ctx -> (* Generate a fresh symbolic value to store the result *) - let res_sv_id = C.fresh_symbolic_value_id () in + let res_sv_id = fresh_symbolic_value_id () in let res_sv_ty = if binop = Eq || binop = Ne then ( (* Equality operations *) assert (v1.ty = v2.ty); (* Equality/inequality check is primitive only for a subset of types *) assert (ty_is_primitively_copyable v1.ty); - T.TLiteral TBool) + TLiteral TBool) else (* Other operations: input types are integers *) - match (v1.V.ty, v2.V.ty) with - | T.TLiteral (TInteger int_ty1), T.TLiteral (TInteger int_ty2) -> ( + match (v1.ty, v2.ty) with + | TLiteral (TInteger int_ty1), TLiteral (TInteger int_ty2) -> ( match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> + | Lt | Le | Ge | Gt -> assert (int_ty1 = int_ty2); - T.TLiteral TBool - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr -> + TLiteral TBool + | Div | Rem | Add | Sub | Mul | BitXor | BitAnd | BitOr -> assert (int_ty1 = int_ty2); - T.TLiteral (TInteger int_ty1) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> raise (Failure "Unreachable")) + TLiteral (TInteger int_ty1) + | Shl | Shr -> raise Unimplemented + | Ne | Eq -> raise (Failure "Unreachable")) | _ -> raise (Failure "Invalid inputs for binop") in let res_sv = - { V.sv_kind = V.FunCallRet; V.sv_id = res_sv_id; sv_ty = res_sv_ty } + { sv_kind = FunCallRet; sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Call the continuattion *) let v = mk_typed_value_from_symbolic_value res_sv in let expr = cf (Ok v) ctx in (* Synthesize the symbolic AST *) - let p1 = S.mk_opt_place_from_op op1 ctx in - let p2 = S.mk_opt_place_from_op op2 ctx in - S.synthesize_binary_op ctx binop v1 p1 v2 p2 res_sv None expr + let p1 = mk_opt_place_from_op op1 ctx in + let p2 = mk_opt_place_from_op op2 ctx in + synthesize_binary_op ctx binop v1 p1 v2 p2 res_sv None expr in (* Compose and apply *) comp eval_ops compute cf ctx -let eval_binary_op (config : C.config) (binop : E.binop) (op1 : E.operand) - (op2 : E.operand) (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun - = +let eval_binary_op (config : config) (binop : binop) (op1 : operand) + (op2 : operand) (cf : (typed_value, eval_error) result -> m_fun) : m_fun = match config.mode with - | C.ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf - | C.SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf + | ConcreteMode -> eval_binary_op_concrete config binop op1 op2 cf + | SymbolicMode -> eval_binary_op_symbolic config binop op1 op2 cf -let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) - (cf : V.typed_value -> m_fun) : m_fun = +let eval_rvalue_ref (config : config) (p : place) (bkind : borrow_kind) + (cf : typed_value -> m_fun) : m_fun = fun ctx -> match bkind with - | Shared | TwoPhaseMut | Shallow -> + | BShared | BTwoPhaseMut | BShallow -> (* **REMARK**: we initially treated shallow borrows like shared borrows. In practice this restricted the behaviour too much, so for now we forbid them. *) - assert (bkind <> Shallow); + assert (bkind <> BShallow); (* Access the value *) let access = match bkind with - | Shared | Shallow -> Read - | TwoPhaseMut -> Write + | BShared | BShallow -> Read + | BTwoPhaseMut -> Write | _ -> raise (Failure "Unreachable") in @@ -642,22 +629,20 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) access_rplace_reorganize_and_read config expand_prim_copy access p in (* Evaluate the borrowing operation *) - let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = fun ctx -> (* Generate the fresh borrow id *) - let bid = C.fresh_borrow_id () in + let bid = fresh_borrow_id () in (* Compute the loan value, with which to replace the value at place p *) let nv = match v.value with | VLoan (VSharedLoan (bids, sv)) -> (* Shared loan: insert the new borrow id *) - let bids1 = V.BorrowId.Set.add bid bids in + let bids1 = BorrowId.Set.add bid bids in { v with value = VLoan (VSharedLoan (bids1, sv)) } | _ -> (* Not a shared loan: add a wrapper *) - let v' = - V.VLoan (VSharedLoan (V.BorrowId.Set.singleton bid, v)) - in + let v' = VLoan (VSharedLoan (BorrowId.Set.singleton bid, v)) in { v with value = v' } in (* Update the borrowed value in the context *) @@ -666,27 +651,27 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) * Note that the reference is *mutable* if we do a two-phase borrow *) let ref_kind = match bkind with - | Shared | Shallow -> T.Shared - | TwoPhaseMut -> T.Mut + | BShared | BShallow -> RShared + | BTwoPhaseMut -> RMut | _ -> raise (Failure "Unreachable") in - let rv_ty = T.TRef (T.RErased, v.ty, ref_kind) in + let rv_ty = TRef (RErased, v.ty, ref_kind) in let bc = match bkind with - | Shared | Shallow -> + | BShared | BShallow -> (* See the remark at the beginning of the match branch: we handle shallow borrows like shared borrows *) - V.VSharedBorrow bid - | TwoPhaseMut -> VReservedMutBorrow bid + VSharedBorrow bid + | BTwoPhaseMut -> VReservedMutBorrow bid | _ -> raise (Failure "Unreachable") in - let rv : V.typed_value = { value = VBorrow bc; ty = rv_ty } in + let rv : typed_value = { value = VBorrow bc; ty = rv_ty } in (* Continue *) cf rv ctx in (* Compose and apply *) comp prepare eval cf ctx - | Mut -> + | BMut -> (* Access the value *) let access = Write in let expand_prim_copy = false in @@ -694,13 +679,13 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) access_rplace_reorganize_and_read config expand_prim_copy access p in (* Evaluate the borrowing operation *) - let eval (cf : V.typed_value -> m_fun) (v : V.typed_value) : m_fun = + let eval (cf : typed_value -> m_fun) (v : typed_value) : m_fun = fun ctx -> (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) - let bid = C.fresh_borrow_id () in - let rv_ty = T.TRef (RErased, v.ty, Mut) in - let rv : V.typed_value = - { V.value = VBorrow (VMutBorrow (bid, v)); ty = rv_ty } + let bid = fresh_borrow_id () in + let rv_ty = TRef (RErased, v.ty, RMut) in + let rv : typed_value = + { value = VBorrow (VMutBorrow (bid, v)); ty = rv_ty } in (* Compute the value with which to replace the value at place p *) let nv = { v with value = VLoan (VMutLoan bid) } in @@ -712,63 +697,61 @@ let eval_rvalue_ref (config : C.config) (p : E.place) (bkind : E.borrow_kind) (* Compose and apply *) comp prepare eval cf ctx -let eval_rvalue_aggregate (config : C.config) - (aggregate_kind : E.aggregate_kind) (ops : E.operand list) - (cf : V.typed_value -> m_fun) : m_fun = +let eval_rvalue_aggregate (config : config) (aggregate_kind : aggregate_kind) + (ops : operand list) (cf : typed_value -> m_fun) : m_fun = (* Evaluate the operands *) let eval_ops = eval_operands config ops in (* Compute the value *) - let compute (cf : V.typed_value -> m_fun) (values : V.typed_value list) : - m_fun = + let compute (cf : typed_value -> m_fun) (values : typed_value list) : m_fun = fun ctx -> (* Match on the aggregate kind *) match aggregate_kind with | AggregatedAdt (type_id, opt_variant_id, generics) -> ( match type_id with | TTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.VAdt { variant_id = None; field_values = values } in - let generics = TypesUtils.mk_generic_args [] tys [] [] in - let ty = T.TAdt (T.TTuple, generics) in - let aggregated : V.typed_value = { V.value = v; ty } in + let tys = List.map (fun (v : typed_value) -> v.ty) values in + let v = VAdt { variant_id = None; field_values = values } in + let generics = mk_generic_args [] tys [] [] in + let ty = TAdt (TTuple, generics) in + let aggregated : typed_value = { value = v; ty } in (* Call the continuation *) cf aggregated ctx | TAdtId def_id -> (* Sanity checks *) - let type_decl = C.ctx_lookup_type_decl ctx def_id in + let type_decl = ctx_lookup_type_decl ctx def_id in assert ( List.length type_decl.generics.regions = List.length generics.regions); let expected_field_types = - Assoc.ctx_adt_get_inst_norm_field_etypes ctx def_id opt_variant_id - generics + AssociatedTypes.ctx_adt_get_inst_norm_field_etypes ctx def_id + opt_variant_id generics in assert ( expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); + = List.map (fun (v : typed_value) -> v.ty) values); (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } + let av : adt_value = + { variant_id = opt_variant_id; field_values = values } in - let aty = T.TAdt (T.TAdtId def_id, generics) in - let aggregated : V.typed_value = { V.value = VAdt av; ty = aty } in + let aty = TAdt (TAdtId def_id, generics) in + let aggregated : typed_value = { value = VAdt av; ty = aty } in (* Call the continuation *) cf aggregated ctx | TAssumed _ -> raise (Failure "Unreachable")) | AggregatedArray (ety, cg) -> ( (* Sanity check: all the values have the proper type *) - assert (List.for_all (fun (v : V.typed_value) -> v.V.ty = ety) values); + assert (List.for_all (fun (v : typed_value) -> v.ty = ety) values); (* Sanity check: the number of values is consistent with the length *) let len = (literal_as_scalar (const_generic_as_literal cg)).value in assert (len = Z.of_int (List.length values)); let generics = TypesUtils.mk_generic_args [] [ ety ] [ cg ] [] in - let ty = T.TAdt (T.TAssumed T.TArray, generics) in + let ty = TAdt (TAssumed TArray, generics) in (* In order to generate a better AST, we introduce a symbolic value equal to the array. The reason is that otherwise, the array we introduce here might be duplicated in the generated code: by introducing a symbolic value we introduce a let-binding in the generated code. *) - let saggregated = mk_fresh_symbolic_typed_value V.Aggregate ty in + let saggregated = mk_fresh_symbolic_typed_value Aggregate ty in (* Call the continuation *) match cf saggregated ctx with | None -> None @@ -780,32 +763,32 @@ let eval_rvalue_aggregate (config : C.config) (* Compose and apply *) comp eval_ops compute cf -let eval_rvalue_not_global (config : C.config) (rvalue : E.rvalue) - (cf : (V.typed_value, eval_error) result -> m_fun) : m_fun = +let eval_rvalue_not_global (config : config) (rvalue : rvalue) + (cf : (typed_value, eval_error) result -> m_fun) : m_fun = fun ctx -> log#ldebug (lazy "eval_rvalue"); (* Small helpers *) - let wrap_in_result (cf : (V.typed_value, eval_error) result -> m_fun) - (v : V.typed_value) : m_fun = + let wrap_in_result (cf : (typed_value, eval_error) result -> m_fun) + (v : typed_value) : m_fun = cf (Ok v) in let comp_wrap f = comp f wrap_in_result cf in (* Delegate to the proper auxiliary function *) match rvalue with - | E.Use op -> comp_wrap (eval_operand config op) ctx - | E.RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx - | E.UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx - | E.BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx - | E.Aggregate (aggregate_kind, ops) -> + | Use op -> comp_wrap (eval_operand config op) ctx + | RvRef (p, bkind) -> comp_wrap (eval_rvalue_ref config p bkind) ctx + | UnaryOp (unop, op) -> eval_unary_op config unop op cf ctx + | BinaryOp (binop, op1, op2) -> eval_binary_op config binop op1 op2 cf ctx + | Aggregate (aggregate_kind, ops) -> comp_wrap (eval_rvalue_aggregate config aggregate_kind ops) ctx - | E.Discriminant _ -> + | Discriminant _ -> raise (Failure "Unreachable: discriminant reads should have been eliminated from \ the AST") - | E.Global _ -> raise (Failure "Unreachable") + | Global _ -> raise (Failure "Unreachable") -let eval_fake_read (config : C.config) (p : E.place) : cm_fun = +let eval_fake_read (config : config) (p : place) : cm_fun = fun cf ctx -> let expand_prim_copy = false in let cf_prepare cf = diff --git a/compiler/InterpreterExpressions.mli b/compiler/InterpreterExpressions.mli index 3beba610..f8d979f4 100644 --- a/compiler/InterpreterExpressions.mli +++ b/compiler/InterpreterExpressions.mli @@ -1,13 +1,6 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module LA = LlbcAst -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Expressions +open Values +open Contexts open Cps open InterpreterPaths @@ -19,7 +12,7 @@ open InterpreterPaths This function doesn't reorganize the context to make sure we can read the place. If needs be, you should call {!InterpreterPaths.update_ctx_along_read_place} first. *) -val read_place : access_kind -> E.place -> (V.typed_value -> m_fun) -> m_fun +val read_place : access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Auxiliary function. @@ -38,12 +31,7 @@ val read_place : access_kind -> E.place -> (V.typed_value -> m_fun) -> m_fun primitively copyable and contain borrows. *) val access_rplace_reorganize_and_read : - C.config -> - bool -> - access_kind -> - E.place -> - (V.typed_value -> m_fun) -> - m_fun + config -> bool -> access_kind -> place -> (typed_value -> m_fun) -> m_fun (** Evaluate an operand. @@ -54,11 +42,11 @@ val access_rplace_reorganize_and_read : of the environment, before evaluating all the operands at once. Use {!eval_operands} instead. *) -val eval_operand : C.config -> E.operand -> (V.typed_value -> m_fun) -> m_fun +val eval_operand : config -> operand -> (typed_value -> m_fun) -> m_fun (** Evaluate several operands at once. *) val eval_operands : - C.config -> E.operand list -> (V.typed_value list -> m_fun) -> m_fun + config -> operand list -> (typed_value list -> m_fun) -> m_fun (** Evaluate an rvalue which is not a global (globals are handled elsewhere). @@ -68,7 +56,7 @@ val eval_operands : reads should have been eliminated from the AST. *) val eval_rvalue_not_global : - C.config -> E.rvalue -> ((V.typed_value, eval_error) result -> m_fun) -> m_fun + config -> rvalue -> ((typed_value, eval_error) result -> m_fun) -> m_fun (** Evaluate a fake read (update the context so that we can read a place) *) -val eval_fake_read : C.config -> E.place -> cm_fun +val eval_fake_read : config -> place -> cm_fun diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 5b170ac5..30b9316d 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -5,7 +5,6 @@ module E = Expressions module C = Contexts module Subst = Substitute module A = LlbcAst -module L = Logging open ValuesUtils module Inv = Invariants module S = SynthesizeSymbolic @@ -16,7 +15,7 @@ open InterpreterLoopsMatchCtxs open InterpreterLoopsFixedPoint (** The local logger *) -let log = L.loops_log +let log = Logging.loops_log (** Evaluate a loop in concrete mode *) let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 50bc7767..d14230c6 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -1,26 +1,17 @@ (** Core definitions for the [IntepreterLoops*] *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic -module UF = UnionFind +open Types +open Values +open Contexts open InterpreterUtils -open InterpreterExpressions type updt_env_kind = - | AbsInLeft of V.AbstractionId.id - | LoanInLeft of V.BorrowId.id - | LoansInLeft of V.BorrowId.Set.t - | AbsInRight of V.AbstractionId.id - | LoanInRight of V.BorrowId.id - | LoansInRight of V.BorrowId.Set.t + | AbsInLeft of AbstractionId.id + | LoanInLeft of BorrowId.id + | LoansInLeft of BorrowId.Set.t + | AbsInRight of AbstractionId.id + | LoanInRight of BorrowId.id + | LoansInRight of BorrowId.Set.t (** Utility exception *) exception ValueMatchFailure of updt_env_kind @@ -28,10 +19,10 @@ exception ValueMatchFailure of updt_env_kind (** Utility exception *) exception Distinct of string -type ctx_or_update = (C.eval_ctx, updt_env_kind) result +type ctx_or_update = (eval_ctx, updt_env_kind) result (** Union Find *) -module UnionFind = UF.Make (UF.StoreMap) +module UF = UnionFind.Make (UnionFind.StoreMap) (** A small utility - @@ -41,13 +32,13 @@ module UnionFind = UF.Make (UF.StoreMap) instance, [borrow_to_abs] maps to a *set* of ids). *) type abs_borrows_loans_maps = { - abs_ids : V.AbstractionId.id list; - abs_to_borrows : V.BorrowId.Set.t V.AbstractionId.Map.t; - abs_to_loans : V.BorrowId.Set.t V.AbstractionId.Map.t; - abs_to_borrows_loans : V.BorrowId.Set.t V.AbstractionId.Map.t; - borrow_to_abs : V.AbstractionId.Set.t V.BorrowId.Map.t; - loan_to_abs : V.AbstractionId.Set.t V.BorrowId.Map.t; - borrow_loan_to_abs : V.AbstractionId.Set.t V.BorrowId.Map.t; + abs_ids : AbstractionId.id list; + abs_to_borrows : BorrowId.Set.t AbstractionId.Map.t; + abs_to_loans : BorrowId.Set.t AbstractionId.Map.t; + abs_to_borrows_loans : BorrowId.Set.t AbstractionId.Map.t; + borrow_to_abs : AbstractionId.Set.t BorrowId.Map.t; + loan_to_abs : AbstractionId.Set.t BorrowId.Map.t; + borrow_loan_to_abs : AbstractionId.Set.t BorrowId.Map.t; } (** See {!InterpreterLoopsMatchCtxs.MakeMatcher} and {!InterpreterLoopsCore.Matcher}. @@ -56,14 +47,14 @@ type abs_borrows_loans_maps = { {!InterpreterLoopsMatchCtxs.MakeMatcher} functor. *) module type PrimMatcher = sig - val match_etys : T.ety -> T.ety -> T.ety - val match_rtys : T.rty -> T.rty -> T.rty + val match_etys : ety -> ety -> ety + val match_rtys : rty -> rty -> rty (** The input primitive values are not equal *) - val match_distinct_literals : T.ety -> V.literal -> V.literal -> V.typed_value + val match_distinct_literals : ety -> literal -> literal -> typed_value (** The input ADTs don't have the same variant *) - val match_distinct_adts : T.ety -> V.adt_value -> V.adt_value -> V.typed_value + val match_distinct_adts : ety -> adt_value -> adt_value -> typed_value (** The meta-value is the result of a match. @@ -76,11 +67,11 @@ module type PrimMatcher = sig calling the match function. *) val match_shared_borrows : - (V.typed_value -> V.typed_value -> V.typed_value) -> - T.ety -> - V.borrow_id -> - V.borrow_id -> - V.borrow_id + (typed_value -> typed_value -> typed_value) -> + ety -> + borrow_id -> + borrow_id -> + borrow_id (** The input parameters are: - [ty] @@ -91,13 +82,13 @@ module type PrimMatcher = sig - [bv]: the result of matching [bv0] with [bv1] *) val match_mut_borrows : - T.ety -> - V.borrow_id -> - V.typed_value -> - V.borrow_id -> - V.typed_value -> - V.typed_value -> - V.borrow_id * V.typed_value + ety -> + borrow_id -> + typed_value -> + borrow_id -> + typed_value -> + typed_value -> + borrow_id * typed_value (** Parameters: [ty] @@ -106,17 +97,16 @@ module type PrimMatcher = sig [v]: the result of matching the shared values coming from the two loans *) val match_shared_loans : - T.ety -> - V.loan_id_set -> - V.loan_id_set -> - V.typed_value -> - V.loan_id_set * V.typed_value + ety -> + loan_id_set -> + loan_id_set -> + typed_value -> + loan_id_set * typed_value - val match_mut_loans : T.ety -> V.loan_id -> V.loan_id -> V.loan_id + val match_mut_loans : ety -> loan_id -> loan_id -> loan_id (** There are no constraints on the input symbolic values *) - val match_symbolic_values : - V.symbolic_value -> V.symbolic_value -> V.symbolic_value + val match_symbolic_values : symbolic_value -> symbolic_value -> symbolic_value (** Match a symbolic value with a value which is not symbolic. @@ -126,7 +116,7 @@ module type PrimMatcher = sig end loans in one of the two environments). *) val match_symbolic_with_other : - bool -> V.symbolic_value -> V.typed_value -> V.typed_value + bool -> symbolic_value -> typed_value -> typed_value (** Match a bottom value with a value which is not bottom. @@ -135,11 +125,11 @@ module type PrimMatcher = sig is important when throwing exceptions, for instance when we need to end loans in one of the two environments). *) - val match_bottom_with_other : bool -> V.typed_value -> V.typed_value + val match_bottom_with_other : bool -> typed_value -> typed_value (** The input ADTs don't have the same variant *) val match_distinct_aadts : - T.rty -> V.adt_avalue -> T.rty -> V.adt_avalue -> T.rty -> V.typed_avalue + rty -> adt_avalue -> rty -> adt_avalue -> rty -> typed_avalue (** Parameters: [ty0] @@ -149,7 +139,7 @@ module type PrimMatcher = sig [ty]: result of matching ty0 and ty1 *) val match_ashared_borrows : - T.rty -> V.borrow_id -> T.rty -> V.borrow_id -> T.rty -> V.typed_avalue + rty -> borrow_id -> rty -> borrow_id -> rty -> typed_avalue (** Parameters: [ty0] @@ -162,15 +152,15 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_borrows : - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue + rty -> + borrow_id -> + typed_avalue -> + rty -> + borrow_id -> + typed_avalue -> + rty -> + typed_avalue -> + typed_avalue (** Parameters: [ty0] @@ -186,18 +176,18 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_ashared_loans : - T.rty -> - V.loan_id_set -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.loan_id_set -> - V.typed_value -> - V.typed_avalue -> - T.rty -> - V.typed_value -> - V.typed_avalue -> - V.typed_avalue + rty -> + loan_id_set -> + typed_value -> + typed_avalue -> + rty -> + loan_id_set -> + typed_value -> + typed_avalue -> + rty -> + typed_value -> + typed_avalue -> + typed_avalue (** Parameters: [ty0] @@ -210,20 +200,20 @@ module type PrimMatcher = sig [av]: result of matching av0 and av1 *) val match_amut_loans : - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.borrow_id -> - V.typed_avalue -> - T.rty -> - V.typed_avalue -> - V.typed_avalue + rty -> + borrow_id -> + typed_avalue -> + rty -> + borrow_id -> + typed_avalue -> + rty -> + typed_avalue -> + typed_avalue (** Match two arbitrary avalues whose constructors don't match (this function is typically used to raise the proper exception). *) - val match_avalues : V.typed_avalue -> V.typed_avalue -> V.typed_avalue + val match_avalues : typed_avalue -> typed_avalue -> typed_avalue end module type Matcher = sig @@ -231,15 +221,14 @@ module type Matcher = sig Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) - val match_typed_values : - C.eval_ctx -> V.typed_value -> V.typed_value -> V.typed_value + val match_typed_values : eval_ctx -> typed_value -> typed_value -> typed_value (** Match two avalues. Rem.: this function raises exceptions of type {!Aeneas.InterpreterLoopsCore.ValueMatchFailure}. *) val match_typed_avalues : - C.eval_ctx -> V.typed_avalue -> V.typed_avalue -> V.typed_avalue + eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end (** See {!InterpreterLoopsMatchCtxs.MakeCheckEquivMatcher} and @@ -252,78 +241,75 @@ module type MatchCheckEquivState = sig a source context with a target context. *) val check_equiv : bool - val ctx : C.eval_ctx - val rid_map : T.RegionId.InjSubst.t ref + val ctx : eval_ctx + val rid_map : RegionId.InjSubst.t ref (** Substitution for the loan and borrow ids - used only if [check_equiv] is true *) - val blid_map : V.BorrowId.InjSubst.t ref + val blid_map : BorrowId.InjSubst.t ref (** Substitution for the borrow ids - used only if [check_equiv] is false *) - val borrow_id_map : V.BorrowId.InjSubst.t ref + val borrow_id_map : BorrowId.InjSubst.t ref (** Substitution for the loans ids - used only if [check_equiv] is false *) - val loan_id_map : V.BorrowId.InjSubst.t ref + val loan_id_map : BorrowId.InjSubst.t ref - val sid_map : V.SymbolicValueId.InjSubst.t ref - val sid_to_value_map : V.typed_value V.SymbolicValueId.Map.t ref - val aid_map : V.AbstractionId.InjSubst.t ref - val lookup_shared_value_in_ctx0 : V.BorrowId.id -> V.typed_value - val lookup_shared_value_in_ctx1 : V.BorrowId.id -> V.typed_value + val sid_map : SymbolicValueId.InjSubst.t ref + val sid_to_value_map : typed_value SymbolicValueId.Map.t ref + val aid_map : AbstractionId.InjSubst.t ref + val lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value + val lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value end module type CheckEquivMatcher = sig include PrimMatcher - val match_aid : V.abstraction_id -> V.abstraction_id -> V.abstraction_id + val match_aid : abstraction_id -> abstraction_id -> abstraction_id val match_aidl : - V.abstraction_id list -> V.abstraction_id list -> V.abstraction_id list + abstraction_id list -> abstraction_id list -> abstraction_id list val match_aids : - V.abstraction_id_set -> V.abstraction_id_set -> V.abstraction_id_set - - val match_rid : V.region_id -> V.region_id -> V.region_id - val match_rids : V.region_id_set -> V.region_id_set -> V.region_id_set - val match_borrow_id : V.borrow_id -> V.borrow_id -> V.borrow_id - - val match_borrow_idl : - V.borrow_id list -> V.borrow_id list -> V.borrow_id list - - val match_borrow_ids : V.borrow_id_set -> V.borrow_id_set -> V.borrow_id_set - val match_loan_id : V.loan_id -> V.loan_id -> V.loan_id - val match_loan_idl : V.loan_id list -> V.loan_id list -> V.loan_id list - val match_loan_ids : V.loan_id_set -> V.loan_id_set -> V.loan_id_set + abstraction_id_set -> abstraction_id_set -> abstraction_id_set + + val match_rid : region_id -> region_id -> region_id + val match_rids : region_id_set -> region_id_set -> region_id_set + val match_borrow_id : borrow_id -> borrow_id -> borrow_id + val match_borrow_idl : borrow_id list -> borrow_id list -> borrow_id list + val match_borrow_ids : borrow_id_set -> borrow_id_set -> borrow_id_set + val match_loan_id : loan_id -> loan_id -> loan_id + val match_loan_idl : loan_id list -> loan_id list -> loan_id list + val match_loan_ids : loan_id_set -> loan_id_set -> loan_id_set end (** See {!InterpreterLoopsMatchCtxs.match_ctxs} *) type ids_maps = { - aid_map : V.AbstractionId.InjSubst.t; - blid_map : V.BorrowId.InjSubst.t; + aid_map : AbstractionId.InjSubst.t; + blid_map : BorrowId.InjSubst.t; (** Substitution for the loan and borrow ids *) - borrow_id_map : V.BorrowId.InjSubst.t; (** Substitution for the borrow ids *) - loan_id_map : V.BorrowId.InjSubst.t; (** Substitution for the loan ids *) - rid_map : T.RegionId.InjSubst.t; - sid_map : V.SymbolicValueId.InjSubst.t; - sid_to_value_map : V.typed_value V.SymbolicValueId.Map.t; + borrow_id_map : BorrowId.InjSubst.t; (** Substitution for the borrow ids *) + loan_id_map : BorrowId.InjSubst.t; (** Substitution for the loan ids *) + rid_map : RegionId.InjSubst.t; + sid_map : SymbolicValueId.InjSubst.t; + sid_to_value_map : typed_value SymbolicValueId.Map.t; } [@@deriving show] type borrow_loan_corresp = { - borrow_to_loan_id_map : V.BorrowId.InjSubst.t; - loan_to_borrow_id_map : V.BorrowId.InjSubst.t; + borrow_to_loan_id_map : BorrowId.InjSubst.t; + loan_to_borrow_id_map : BorrowId.InjSubst.t; } [@@deriving show] (* Very annoying: functors only take modules as inputs... *) module type MatchJoinState = sig (** The current context *) - val ctx : C.eval_ctx + val ctx : eval_ctx (** The current loop *) - val loop_id : V.LoopId.id + val loop_id : LoopId.id (** The abstractions introduced when performing the matches *) - val nabs : V.abs list ref + val nabs : abs list ref end (** Split an environment between the fixed abstractions, values, etc. and @@ -331,36 +317,36 @@ end Returns: (fixed, new abs, new dummies) *) -let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : C.eval_ctx) : - C.env * V.abs list * V.typed_value list = - let is_fresh_did (id : C.DummyVarId.id) : bool = - not (C.DummyVarId.Set.mem id fixed_ids.dids) +let ctx_split_fixed_new (fixed_ids : ids_sets) (ctx : eval_ctx) : + env * abs list * typed_value list = + let is_fresh_did (id : DummyVarId.id) : bool = + not (DummyVarId.Set.mem id fixed_ids.dids) in - let is_fresh_abs_id (id : V.AbstractionId.id) : bool = - not (V.AbstractionId.Set.mem id fixed_ids.aids) + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id fixed_ids.aids) in (* Filter the new abstractions and dummy variables (there shouldn't be any new dummy variable though) in the target context *) - let is_fresh (ee : C.env_elem) : bool = + let is_fresh (ee : env_elem) : bool = match ee with - | C.EBinding (BVar _, _) | C.EFrame -> false - | C.EBinding (BDummy bv, _) -> is_fresh_did bv - | C.EAbs abs -> is_fresh_abs_id abs.abs_id + | EBinding (BVar _, _) | EFrame -> false + | EBinding (BDummy bv, _) -> is_fresh_did bv + | EAbs abs -> is_fresh_abs_id abs.abs_id in let new_eel, filt_env = List.partition is_fresh ctx.env in - let is_abs ee = match ee with C.EAbs _ -> true | _ -> false in + let is_abs ee = match ee with EAbs _ -> true | _ -> false in let new_absl, new_dummyl = List.partition is_abs new_eel in let new_absl = List.map (fun ee -> - match ee with C.EAbs abs -> abs | _ -> raise (Failure "Unreachable")) + match ee with EAbs abs -> abs | _ -> raise (Failure "Unreachable")) new_absl in let new_dummyl = List.map (fun ee -> match ee with - | C.EBinding (BDummy _, v) -> v + | EBinding (BDummy _, v) -> v | _ -> raise (Failure "Unreachable")) new_dummyl in @@ -370,7 +356,7 @@ let ids_sets_empty_borrows_loans (ids : ids_sets) : ids_sets = let { aids; blids = _; borrow_ids = _; loan_ids = _; dids; rids; sids } = ids in - let empty = V.BorrowId.Set.empty in + let empty = BorrowId.Set.empty in let ids = { aids; diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index a35b2716..3cc0a5f0 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -1,14 +1,8 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants module S = SynthesizeSymbolic open Cps open InterpreterUtils @@ -17,7 +11,7 @@ open InterpreterLoopsMatchCtxs open InterpreterLoopsJoinCtxs (** The local logger *) -let log = L.loops_fixed_point_log +let log = Logging.loops_fixed_point_log (** Reorder the loans and borrows in the fresh abstractions. @@ -26,17 +20,17 @@ let log = L.loops_fixed_point_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) - (ctx : C.eval_ctx) : C.eval_ctx = - let reorder_in_fresh_abs (abs : V.abs) : V.abs = +let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) + (ctx : eval_ctx) : eval_ctx = + let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unexpected") in - let aborrows, aloans = List.partition is_borrow abs.V.avalues in + let aborrows, aloans = List.partition is_borrow abs.avalues in (* Reoder the borrows, and the loans. @@ -44,40 +38,40 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) and the borrows to find fixed points is simply to sort them by increasing order of id (taking the smallest id of a set of ids, in case of sets). *) - let get_borrow_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ABorrow (V.AMutBorrow (bid, _) | V.ASharedBorrow bid) -> bid + let get_borrow_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid | _ -> raise (Failure "Unexpected") in - let get_loan_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ALoan (V.AMutLoan (lid, _)) -> lid - | V.ALoan (V.ASharedLoan (lids, _, _)) -> V.BorrowId.Set.min_elt lids + let get_loan_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ALoan (AMutLoan (lid, _)) -> lid + | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids | _ -> raise (Failure "Unexpected") in (* We use ordered maps to reorder the borrows and loans *) - let reorder (get_bid : V.typed_avalue -> V.BorrowId.id) - (values : V.typed_avalue list) : V.typed_avalue list = + let reorder (get_bid : typed_avalue -> BorrowId.id) + (values : typed_avalue list) : typed_avalue list = List.map snd - (V.BorrowId.Map.bindings - (V.BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) + (BorrowId.Map.bindings + (BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) in let aborrows = reorder get_borrow_id aborrows in let aloans = reorder get_loan_id aloans in let avalues = List.append aborrows aloans in - { abs with V.avalues } + { abs with avalues } in - let reorder_in_abs (abs : V.abs) = - if V.AbstractionId.Set.mem abs.abs_id old_abs_ids then abs + let reorder_in_abs (abs : abs) = + if AbstractionId.Set.mem abs.abs_id old_abs_ids then abs else reorder_in_fresh_abs abs in - let env = C.env_map_abs reorder_in_abs ctx.env in + let env = env_map_abs reorder_in_abs ctx.env in - { ctx with C.env } + { ctx with env } -let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = +let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = fun cf ctx0 -> let ctx = ctx0 in (* Compute the set of borrows which appear in the abstractions, so that @@ -85,7 +79,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = *) let absl = List.filter_map - (function C.EBinding _ | C.EFrame -> None | C.EAbs abs -> Some abs) + (function EBinding _ | EFrame -> None | EAbs abs -> Some abs) ctx.env in let absl_ids, absl_id_maps = compute_absl_ids absl in @@ -100,18 +94,18 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = - the region ids found in the value and belonging to the set [rids] have been substituted with [nrid] *) - let mk_value_with_fresh_sids_no_shared_loans (rids : T.RegionId.Set.t) - (nrid : T.RegionId.id) (v : V.typed_value) : V.typed_value = + let mk_value_with_fresh_sids_no_shared_loans (rids : RegionId.Set.t) + (nrid : RegionId.id) (v : typed_value) : typed_value = (* Remove the shared loans *) let v = value_remove_shared_loans v in (* Substitute the symbolic values and the region *) - Subst.typed_value_subst_ids - (fun r -> if T.RegionId.Set.mem r rids then nrid else r) + Substitute.typed_value_subst_ids + (fun r -> if RegionId.Set.mem r rids then nrid else r) (fun x -> x) (fun x -> x) (fun id -> - let nid = C.fresh_symbolic_value_id () in - let sv = V.SymbolicValueId.Map.find id absl_id_maps.sids_to_values in + let nid = fresh_symbolic_value_id () in + let sv = SymbolicValueId.Map.find id absl_id_maps.sids_to_values in sid_subst := (nid, sv) :: !sid_subst; nid) (fun x -> x) @@ -142,13 +136,13 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = abs'2 { SB l0, SL {l2} s2 } ]} *) - let push_abs_for_shared_value (abs : V.abs) (sv : V.typed_value) - (lid : V.BorrowId.id) : unit = + let push_abs_for_shared_value (abs : abs) (sv : typed_value) + (lid : BorrowId.id) : unit = (* Create a fresh borrow (for the reborrow) *) - let nlid = C.fresh_borrow_id () in + let nlid = fresh_borrow_id () in (* We need a fresh region for the new abstraction *) - let nrid = C.fresh_region_id () in + let nrid = fresh_region_id () in (* Prepare the shared value *) let nsv = mk_value_with_fresh_sids_no_shared_loans abs.regions nrid sv in @@ -157,47 +151,47 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = borrow_substs := (lid, nlid) :: !borrow_substs; (* Rem.: the below sanity checks are not really necessary *) - assert (V.AbstractionId.Set.is_empty abs.parents); + assert (AbstractionId.Set.is_empty abs.parents); assert (abs.original_parents = []); - assert (T.RegionId.Set.is_empty abs.ancestors_regions); + assert (RegionId.Set.is_empty abs.ancestors_regions); (* Introduce the new abstraction for the shared values *) - assert (ty_no_regions sv.V.ty); - let rty = sv.V.ty in + assert (ty_no_regions sv.ty); + let rty = sv.ty in (* Create the shared loan child *) let child_rty = rty in let child_av = mk_aignored child_rty in (* Create the shared loan *) - let loan_rty = T.TRef (T.RVar nrid, rty, T.Shared) in + let loan_rty = TRef (RVar nrid, rty, RShared) in let loan_value = - V.ALoan (V.ASharedLoan (V.BorrowId.Set.singleton nlid, nsv, child_av)) + ALoan (ASharedLoan (BorrowId.Set.singleton nlid, nsv, child_av)) in let loan_value = mk_typed_avalue loan_rty loan_value in (* Create the shared borrow *) let borrow_rty = loan_rty in - let borrow_value = V.ABorrow (V.ASharedBorrow lid) in + let borrow_value = ABorrow (ASharedBorrow lid) in let borrow_value = mk_typed_avalue borrow_rty borrow_value in (* Create the abstraction *) let avalues = [ borrow_value; loan_value ] in - let kind = + let kind : abs_kind = match loop_id with - | Some loop_id -> V.Loop (loop_id, None, V.LoopSynthInput) - | None -> V.Identity + | Some loop_id -> Loop (loop_id, None, LoopSynthInput) + | None -> Identity in let can_end = true in let fresh_abs = { - V.abs_id = C.fresh_abstraction_id (); + abs_id = fresh_abstraction_id (); kind; can_end; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton nrid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton nrid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -210,22 +204,22 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = We simply explore the context and call {!push_abs_for_shared_value} when necessary. *) - let collect_shared_values_in_abs (abs : V.abs) : unit = - let collect_shared_value lids (sv : V.typed_value) = + let collect_shared_values_in_abs (abs : abs) : unit = + let collect_shared_value lids (sv : typed_value) = (* Sanity check: we don't support nested borrows for now *) - assert (not (value_has_borrows ctx sv.V.value)); + assert (not (value_has_borrows ctx sv.value)); (* Filter the loan ids whose corresponding borrows appear in abstractions (see the documentation of the function) *) - let lids = V.BorrowId.Set.diff lids abs_borrow_ids in + let lids = BorrowId.Set.diff lids abs_borrow_ids in (* Generate fresh borrows and values *) - V.BorrowId.Set.iter (push_abs_for_shared_value abs sv) lids + BorrowId.Set.iter (push_abs_for_shared_value abs sv) lids in let visit_avalue = object - inherit [_] V.iter_typed_avalue as super + inherit [_] iter_typed_avalue as super method! visit_VSharedLoan env lids sv = collect_shared_value lids sv; @@ -253,7 +247,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = in List.iter (visit_avalue#visit_typed_avalue None) abs.avalues in - C.env_iter_abs collect_shared_values_in_abs ctx.env; + env_iter_abs collect_shared_values_in_abs ctx.env; (* Update the borrow ids in the environment. @@ -287,16 +281,14 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = ]} *) let env = - let bmap = V.BorrowId.Map.of_list !borrow_substs in + let bmap = BorrowId.Map.of_list !borrow_substs in let bsusbt bid = - match V.BorrowId.Map.find_opt bid bmap with - | None -> bid - | Some bid -> bid + match BorrowId.Map.find_opt bid bmap with None -> bid | Some bid -> bid in let visitor = object - inherit [_] C.map_env + inherit [_] map_env method! visit_borrow_id _ bid = bsusbt bid end in @@ -304,7 +296,7 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = in (* Add the abstractions *) - let fresh_absl = List.map (fun abs -> C.EAbs abs) !fresh_absl in + let fresh_absl = List.map (fun abs -> EAbs abs) !fresh_absl in let env = List.append fresh_absl env in let ctx = { ctx with env } in @@ -320,18 +312,18 @@ let prepare_ashared_loans (loop_id : V.LoopId.id option) : cm_fun = (fun e (sid, v) -> let v = mk_typed_value_from_symbolic_value v in let sv = - V.SymbolicValueId.Map.find sid new_ctx_ids_map.sids_to_values + SymbolicValueId.Map.find sid new_ctx_ids_map.sids_to_values in SymbolicAst.IntroSymbolic (ctx, None, sv, VaSingleValue v, e)) e !sid_subst) -let prepare_ashared_loans_no_synth (loop_id : V.LoopId.id) (ctx : C.eval_ctx) : - C.eval_ctx = +let prepare_ashared_loans_no_synth (loop_id : LoopId.id) (ctx : eval_ctx) : + eval_ctx = get_cf_ctx_no_synth (prepare_ashared_loans (Some loop_id)) ctx -let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) - (eval_loop_body : st_cm_fun) (ctx0 : C.eval_ctx) : - C.eval_ctx * ids_sets * V.abs T.RegionGroupId.Map.t = +let compute_loop_entry_fixed_point (config : config) (loop_id : LoopId.id) + (eval_loop_body : st_cm_fun) (ctx0 : eval_ctx) : + eval_ctx * ids_sets * abs RegionGroupId.Map.t = (* The continuation for when we exit the loop - we register the environments upon loop *reentry*, and synthesize nothing by returning [None] @@ -384,7 +376,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Join the contexts at the loop entry - ctx1 is the current joined context (the context at the loop entry, after we called {!prepare_ashared_loans}, if this is the first iteration) *) - let join_ctxs (ctx1 : C.eval_ctx) : C.eval_ctx = + let join_ctxs (ctx1 : eval_ctx) : eval_ctx = (* If this is the first iteration, end the borrows/loans/abs which appear in ctx1 and not in the other contexts, then compute the set of fixed ids. This means those borrows/loans have to end @@ -395,8 +387,8 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) | None -> let old_ids, _ = compute_context_ids ctx1 in let new_ids, _ = compute_contexts_ids !ctxs in - let blids = V.BorrowId.Set.diff old_ids.blids new_ids.blids in - let aids = V.AbstractionId.Set.diff old_ids.aids new_ids.aids in + let blids = BorrowId.Set.diff old_ids.blids new_ids.blids in + let aids = AbstractionId.Set.diff old_ids.aids new_ids.aids in (* End those borrows and abstractions *) let end_borrows_abs blids aids ctx = let ctx = @@ -431,14 +423,14 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Compute the set of fixed ids - for the symbolic ids, we compute the intersection of ids between the original environment and the list of new environments *) - let compute_fixed_ids (ctxl : C.eval_ctx list) : ids_sets = + let compute_fixed_ids (ctxl : eval_ctx list) : ids_sets = let fixed_ids, _ = compute_context_ids ctx0 in let { aids; blids; borrow_ids; loan_ids; dids; rids; sids } = fixed_ids in let sids = ref sids in List.iter (fun ctx -> let fixed_ids, _ = compute_context_ids ctx in - sids := V.SymbolicValueId.Set.inter !sids fixed_ids.sids) + sids := SymbolicValueId.Set.inter !sids fixed_ids.sids) ctxl; let sids = !sids in let fixed_ids = { aids; blids; borrow_ids; loan_ids; dids; rids; sids } in @@ -447,7 +439,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Check if two contexts are equivalent - modulo alpha conversion on the existentially quantified borrows/abstractions/symbolic values. *) - let equiv_ctxs (ctx1 : C.eval_ctx) (ctx2 : C.eval_ctx) : bool = + let equiv_ctxs (ctx1 : eval_ctx) (ctx2 : eval_ctx) : bool = let fixed_ids = compute_fixed_ids [ ctx1; ctx2 ] in let check_equivalent = true in let lookup_shared_value _ = raise (Failure "Unreachable") in @@ -456,8 +448,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) lookup_shared_value ctx1 ctx2) in let max_num_iter = Config.loop_fixed_point_max_num_iters in - let rec compute_fixed_point (ctx : C.eval_ctx) (i0 : int) (i : int) : - C.eval_ctx = + let rec compute_fixed_point (ctx : eval_ctx) (i0 : int) (i : int) : eval_ctx = if i = 0 then raise (Failure @@ -502,17 +493,17 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) *) let fp, rg_to_abs = (* List the loop abstractions in the fixed-point *) - let fp_aids, add_aid, _mem_aid = V.AbstractionId.Set.mk_stateful_set () in + let fp_aids, add_aid, _mem_aid = AbstractionId.Set.mk_stateful_set () in let list_loop_abstractions = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> assert (loop_id' = loop_id); - assert (kind = V.LoopSynthInput); + assert (kind = LoopSynthInput); (* The abstractions introduced so far should be endable *) assert (abs.can_end = true); add_aid abs.abs_id; @@ -529,15 +520,14 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) * * [fp_ended_aids] links region groups to sets of ended abstractions. *) - let fp_ended_aids = ref T.RegionGroupId.Map.empty in - let add_ended_aids (rg_id : T.RegionGroupId.id) - (aids : V.AbstractionId.Set.t) : unit = - match T.RegionGroupId.Map.find_opt rg_id !fp_ended_aids with - | None -> - fp_ended_aids := T.RegionGroupId.Map.add rg_id aids !fp_ended_aids + let fp_ended_aids = ref RegionGroupId.Map.empty in + let add_ended_aids (rg_id : RegionGroupId.id) (aids : AbstractionId.Set.t) : + unit = + match RegionGroupId.Map.find_opt rg_id !fp_ended_aids with + | None -> fp_ended_aids := RegionGroupId.Map.add rg_id aids !fp_ended_aids | Some aids' -> - let aids = V.AbstractionId.Set.union aids aids' in - fp_ended_aids := T.RegionGroupId.Map.add rg_id aids !fp_ended_aids + let aids = AbstractionId.Set.union aids aids' in + fp_ended_aids := RegionGroupId.Map.add rg_id aids !fp_ended_aids in let cf_loop : st_m_fun = fun res ctx -> @@ -566,20 +556,20 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) abstractions should have been introduced in a specific order (and we check that it is indeed the case) *) let abs_id = - V.AbstractionId.of_int (T.RegionGroupId.to_int rg_id) + AbstractionId.of_int (RegionGroupId.to_int rg_id) in (* By default, the [SynthInput] abs can't end *) - let ctx = C.ctx_set_abs_can_end ctx abs_id true in + let ctx = ctx_set_abs_can_end ctx abs_id true in assert ( - let abs = C.ctx_lookup_abs ctx abs_id in - abs.kind = V.SynthInput rg_id); + let abs = ctx_lookup_abs ctx abs_id in + abs.kind = SynthInput rg_id); (* End this abstraction *) let ctx = InterpreterBorrows.end_abstraction_no_synth config abs_id ctx in (* Explore the context, and check which abstractions are not there anymore *) let ids, _ = compute_context_ids ctx in - let ended_ids = V.AbstractionId.Set.diff !fp_aids ids.aids in + let ended_ids = AbstractionId.Set.diff !fp_aids ids.aids in add_ended_aids rg_id ended_ids) ctx.region_groups in @@ -590,27 +580,27 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (* Check that the sets of abstractions we need to end per region group are pairwise * disjoint *) - let aids_union = ref V.AbstractionId.Set.empty in + let aids_union = ref AbstractionId.Set.empty in let _ = - T.RegionGroupId.Map.iter + RegionGroupId.Map.iter (fun _ ids -> - assert (V.AbstractionId.Set.disjoint !aids_union ids); - aids_union := V.AbstractionId.Set.union ids !aids_union) + assert (AbstractionId.Set.disjoint !aids_union ids); + aids_union := AbstractionId.Set.union ids !aids_union) !fp_ended_aids in (* We also check that all the regions need to end - this is not necessary per se, but if it doesn't happen it is bizarre and worth investigating... *) - assert (V.AbstractionId.Set.equal !aids_union !fp_aids); + assert (AbstractionId.Set.equal !aids_union !fp_aids); (* Merge the abstractions which need to be merged, and compute the map from region id to abstraction id *) let fp = ref fp in - let rg_to_abs = ref T.RegionGroupId.Map.empty in + let rg_to_abs = ref RegionGroupId.Map.empty in let _ = - T.RegionGroupId.Map.iter + RegionGroupId.Map.iter (fun rg_id ids -> - let ids = V.AbstractionId.Set.elements ids in + let ids = AbstractionId.Set.elements ids in (* Retrieve the first id of the group *) match ids with | [] -> @@ -623,10 +613,12 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) | id0 :: ids -> let id0 = ref id0 in (* Add the proper region group into the abstraction *) - let abs_kind = V.Loop (loop_id, Some rg_id, V.LoopSynthInput) in - let abs = C.ctx_lookup_abs !fp !id0 in - let abs = { abs with V.kind = abs_kind } in - let fp', _ = C.ctx_subst_abs !fp !id0 abs in + let abs_kind : abs_kind = + Loop (loop_id, Some rg_id, LoopSynthInput) + in + let abs = ctx_lookup_abs !fp !id0 in + let abs = { abs with kind = abs_kind } in + let fp', _ = ctx_subst_abs !fp !id0 abs in fp := fp'; (* Merge all the abstractions into this one *) List.iter @@ -635,10 +627,8 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) log#ldebug (lazy ("compute_loop_entry_fixed_point: merge FP \ - abstraction: " - ^ V.AbstractionId.to_string id - ^ " into " - ^ V.AbstractionId.to_string !id0)); + abstraction: " ^ AbstractionId.to_string id ^ " into " + ^ AbstractionId.to_string !id0)); (* Note that we merge *into* [id0] *) let fp', id0' = merge_into_abstraction loop_id abs_kind false !fp id !id0 @@ -649,8 +639,8 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) with ValueMatchFailure _ -> raise (Failure "Unexpected")) ids; (* Register the mapping *) - let abs = C.ctx_lookup_abs !fp !id0 in - rg_to_abs := T.RegionGroupId.Map.add_strict rg_id abs !rg_to_abs) + let abs = ctx_lookup_abs !fp !id0 in + rg_to_abs := RegionGroupId.Map.add_strict rg_id abs !rg_to_abs) !fp_ended_aids in let rg_to_abs = !rg_to_abs in @@ -674,15 +664,15 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) *) let update_loop_abstractions (remove_rg_id : bool) = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_abs _ abs = match abs.kind with | Loop (loop_id', _, kind) -> assert (loop_id' = loop_id); - assert (kind = V.LoopSynthInput); - let kind = - if remove_rg_id then V.Loop (loop_id, None, V.LoopSynthInput) + assert (kind = LoopSynthInput); + let kind : abs_kind = + if remove_rg_id then Loop (loop_id, None, LoopSynthInput) else abs.kind in { abs with can_end = remove_rg_id; kind } @@ -715,7 +705,7 @@ let compute_loop_entry_fixed_point (config : C.config) (loop_id : V.LoopId.id) (fp, fixed_ids, rg_to_abs) let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) - (src_ctx : C.eval_ctx) (tgt_ctx : C.eval_ctx) : borrow_loan_corresp = + (src_ctx : eval_ctx) (tgt_ctx : eval_ctx) : borrow_loan_corresp = log#ldebug (lazy ("compute_fixed_point_id_correspondance:\n\n- fixed_ids:\n" @@ -741,7 +731,7 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) let check_equiv = false in let fixed_ids = ids_sets_empty_borrows_loans fixed_ids in let open InterpreterBorrowsCore in - let lookup_shared_loan lid ctx : V.typed_value = + let lookup_shared_loan lid ctx : typed_value = match snd (lookup_loan ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v @@ -760,10 +750,10 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) ^ show_ids_maps maps ^ "\n\n")); let src_to_tgt_borrow_map = - V.BorrowId.Map.of_list + BorrowId.Map.of_list (List.map (fun (x, y) -> (y, x)) - (V.BorrowId.InjSubst.bindings maps.borrow_id_map)) + (BorrowId.InjSubst.bindings maps.borrow_id_map)) in (* Sanity check: for every abstraction, the target loans and borrows are mapped @@ -800,12 +790,12 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) let ids, _ = compute_abs_ids abs in (* Map the *loan* ids (we just match the corresponding *loans* ) *) let loan_ids = - V.BorrowId.Set.map - (fun x -> V.BorrowId.InjSubst.find x maps.borrow_id_map) + BorrowId.Set.map + (fun x -> BorrowId.InjSubst.find x maps.borrow_id_map) ids.loan_ids in (* Check that the loan and borrows are related *) - assert (V.BorrowId.Set.equal ids.borrow_ids loan_ids)) + assert (BorrowId.Set.equal ids.borrow_ids loan_ids)) new_absl; (* For every target abstraction (going back to the [list_nth_mut] example, @@ -819,27 +809,27 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) if it actually corresponds to a borrows introduced when decomposing the abstractions to move the shared values out of the source context abstractions. *) - let tgt_borrow_to_loan = ref V.BorrowId.InjSubst.empty in + let tgt_borrow_to_loan = ref BorrowId.InjSubst.empty in let visit_tgt = object - inherit [_] V.iter_abs + inherit [_] iter_abs method! visit_borrow_id _ id = (* Find the target borrow *) - let tgt_borrow_id = V.BorrowId.Map.find id src_to_tgt_borrow_map in + let tgt_borrow_id = BorrowId.Map.find id src_to_tgt_borrow_map in (* Update the map *) tgt_borrow_to_loan := - V.BorrowId.InjSubst.add id tgt_borrow_id !tgt_borrow_to_loan + BorrowId.InjSubst.add id tgt_borrow_id !tgt_borrow_to_loan end in List.iter (visit_tgt#visit_abs ()) new_absl; (* Compute the map from loan to borrows *) let tgt_loan_to_borrow = - V.BorrowId.InjSubst.of_list + BorrowId.InjSubst.of_list (List.map (fun (x, y) -> (y, x)) - (V.BorrowId.InjSubst.bindings !tgt_borrow_to_loan)) + (BorrowId.InjSubst.bindings !tgt_borrow_to_loan)) in (* Return *) @@ -848,11 +838,11 @@ let compute_fixed_point_id_correspondance (fixed_ids : ids_sets) loan_to_borrow_id_map = tgt_loan_to_borrow; } -let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : - V.SymbolicValueId.Set.t * V.symbolic_value list = +let compute_fp_ctx_symbolic_values (ctx : eval_ctx) (fp_ctx : eval_ctx) : + SymbolicValueId.Set.t * symbolic_value list = let old_ids, _ = compute_context_ids ctx in let fp_ids, fp_ids_maps = compute_context_ids fp_ctx in - let fresh_sids = V.SymbolicValueId.Set.diff fp_ids.sids old_ids.sids in + let fresh_sids = SymbolicValueId.Set.diff fp_ids.sids old_ids.sids in (* Compute the set of symbolic values which appear in shared values inside *fixed* abstractions: because we introduce fresh abstractions and reborrows @@ -863,10 +853,10 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : let shared_sids_in_fixed_abs = let fixed_absl = List.filter - (fun (ee : C.env_elem) -> + (fun (ee : env_elem) -> match ee with - | C.EBinding _ | C.EFrame -> false - | EAbs abs -> V.AbstractionId.Set.mem abs.abs_id old_ids.aids) + | EBinding _ | EFrame -> false + | EAbs abs -> AbstractionId.Set.mem abs.abs_id old_ids.aids) ctx.env in @@ -876,17 +866,17 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : shared values. We prefer to be more general, in prevision of later changes. *) - let sids = ref V.SymbolicValueId.Set.empty in + let sids = ref SymbolicValueId.Set.empty in let visitor = object (self) - inherit [_] C.iter_env + inherit [_] iter_env method! visit_ASharedLoan inside_shared _ sv child_av = self#visit_typed_value true sv; self#visit_typed_avalue inside_shared child_av method! visit_symbolic_value_id inside_shared sid = - if inside_shared then sids := V.SymbolicValueId.Set.add sid !sids + if inside_shared then sids := SymbolicValueId.Set.add sid !sids end in visitor#visit_env false fixed_absl; @@ -900,15 +890,14 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : log#ldebug (lazy ("compute_fp_ctx_symbolic_values:" ^ "\n- shared_sids_in_fixed_abs:" - ^ V.SymbolicValueId.Set.show shared_sids_in_fixed_abs + ^ SymbolicValueId.Set.show shared_sids_in_fixed_abs ^ "\n- all_sids_to_values: " - ^ V.SymbolicValueId.Map.show (symbolic_value_to_string ctx) sids_to_values + ^ SymbolicValueId.Map.show (symbolic_value_to_string ctx) sids_to_values ^ "\n")); let sids_to_values = - V.SymbolicValueId.Map.filter - (fun sid _ -> - not (V.SymbolicValueId.Set.mem sid shared_sids_in_fixed_abs)) + SymbolicValueId.Map.filter + (fun sid _ -> not (SymbolicValueId.Set.mem sid shared_sids_in_fixed_abs)) sids_to_values in @@ -919,12 +908,12 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : variable [x] which appears before [y] are listed first, for instance. *) let input_svalues = - let found_sids = ref V.SymbolicValueId.Set.empty in + let found_sids = ref SymbolicValueId.Set.empty in let ordered_sids = ref [] in let visitor = object (self) - inherit [_] C.iter_env + inherit [_] iter_env (** We lookup the shared values *) method! visit_VSharedBorrow env bid = @@ -938,8 +927,8 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : self#visit_typed_value env v method! visit_symbolic_value_id _ id = - if not (V.SymbolicValueId.Set.mem id !found_sids) then ( - found_sids := V.SymbolicValueId.Set.add id !found_sids; + if not (SymbolicValueId.Set.mem id !found_sids) then ( + found_sids := SymbolicValueId.Set.add id !found_sids; ordered_sids := id :: !ordered_sids) end in @@ -947,7 +936,7 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : List.iter (visitor#visit_env_elem ()) (List.rev fp_ctx.env); List.filter_map - (fun id -> V.SymbolicValueId.Map.find_opt id sids_to_values) + (fun id -> SymbolicValueId.Map.find_opt id sids_to_values) (List.rev !ordered_sids) in @@ -958,7 +947,7 @@ let compute_fp_ctx_symbolic_values (ctx : C.eval_ctx) (fp_ctx : C.eval_ctx) : ^ "\n- fixed point:\n" ^ eval_ctx_to_string_no_filter fp_ctx ^ "\n- fresh_sids: " - ^ V.SymbolicValueId.Set.show fresh_sids + ^ SymbolicValueId.Set.show fresh_sids ^ "\n- input_svalues: " ^ Print.list_to_string (symbolic_value_to_string ctx) input_svalues ^ "\n\n")); diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index cb03bc9e..65a76359 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -1,13 +1,5 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Values +open Contexts open InterpreterUtils open InterpreterLoopsCore @@ -56,7 +48,7 @@ open InterpreterLoopsCore we only introduce a fresh abstraction for [l1]. *) -val prepare_ashared_loans : V.loop_id option -> Cps.cm_fun +val prepare_ashared_loans : loop_id option -> Cps.cm_fun (** Compute a fixed-point for the context at the entry of the loop. We also return: @@ -71,11 +63,11 @@ val prepare_ashared_loans : V.loop_id option -> Cps.cm_fun the values which are read or modified (some symbolic values may be ignored). *) val compute_loop_entry_fixed_point : - C.config -> - V.loop_id -> + config -> + loop_id -> Cps.st_cm_fun -> - C.eval_ctx -> - C.eval_ctx * ids_sets * V.abs SymbolicAst.region_group_id_map + eval_ctx -> + eval_ctx * ids_sets * abs SymbolicAst.region_group_id_map (** For the abstractions in the fixed point, compute the correspondance between the borrows ids and the loans ids, if we want to introduce equivalent @@ -154,7 +146,7 @@ val compute_loop_entry_fixed_point : through the loan [l1] is actually the value which has to be given back to [l0]. *) val compute_fixed_point_id_correspondance : - ids_sets -> C.eval_ctx -> C.eval_ctx -> borrow_loan_corresp + ids_sets -> eval_ctx -> eval_ctx -> borrow_loan_corresp (** Compute the set of "quantified" symbolic value ids in a fixed-point context. @@ -163,4 +155,4 @@ val compute_fixed_point_id_correspondance : - the list of input symbolic values *) val compute_fp_ctx_symbolic_values : - C.eval_ctx -> C.eval_ctx -> V.symbolic_value_id_set * V.symbolic_value list + eval_ctx -> eval_ctx -> symbolic_value_id_set * symbolic_value list diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 654ee21b..4cc74aae 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -1,23 +1,15 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic -module UF = UnionFind open InterpreterUtils open InterpreterBorrows open InterpreterLoopsCore open InterpreterLoopsMatchCtxs (** The local logger *) -let log = L.loops_join_ctxs_log +let log = Logging.loops_join_ctxs_log (** Reorder the loans and borrows in the fresh abstractions. @@ -26,17 +18,17 @@ let log = L.loops_join_ctxs_log called typically after we merge abstractions together (see {!collapse_ctx} for instance). *) -let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) - (ctx : C.eval_ctx) : C.eval_ctx = - let reorder_in_fresh_abs (abs : V.abs) : V.abs = +let reorder_loans_borrows_in_fresh_abs (old_abs_ids : AbstractionId.Set.t) + (ctx : eval_ctx) : eval_ctx = + let reorder_in_fresh_abs (abs : abs) : abs = (* Split between the loans and borrows *) - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unexpected") in - let aborrows, aloans = List.partition is_borrow abs.V.avalues in + let aborrows, aloans = List.partition is_borrow abs.avalues in (* Reoder the borrows, and the loans. @@ -44,38 +36,38 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) and the borrows to find fixed points is simply to sort them by increasing order of id (taking the smallest id of a set of ids, in case of sets). *) - let get_borrow_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ABorrow (V.AMutBorrow (bid, _) | V.ASharedBorrow bid) -> bid + let get_borrow_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid | _ -> raise (Failure "Unexpected") in - let get_loan_id (av : V.typed_avalue) : V.BorrowId.id = - match av.V.value with - | V.ALoan (V.AMutLoan (lid, _)) -> lid - | V.ALoan (V.ASharedLoan (lids, _, _)) -> V.BorrowId.Set.min_elt lids + let get_loan_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ALoan (AMutLoan (lid, _)) -> lid + | ALoan (ASharedLoan (lids, _, _)) -> BorrowId.Set.min_elt lids | _ -> raise (Failure "Unexpected") in (* We use ordered maps to reorder the borrows and loans *) - let reorder (get_bid : V.typed_avalue -> V.BorrowId.id) - (values : V.typed_avalue list) : V.typed_avalue list = + let reorder (get_bid : typed_avalue -> BorrowId.id) + (values : typed_avalue list) : typed_avalue list = List.map snd - (V.BorrowId.Map.bindings - (V.BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) + (BorrowId.Map.bindings + (BorrowId.Map.of_list (List.map (fun v -> (get_bid v, v)) values))) in let aborrows = reorder get_borrow_id aborrows in let aloans = reorder get_loan_id aloans in let avalues = List.append aborrows aloans in - { abs with V.avalues } + { abs with avalues } in - let reorder_in_abs (abs : V.abs) = - if V.AbstractionId.Set.mem abs.abs_id old_abs_ids then abs + let reorder_in_abs (abs : abs) = + if AbstractionId.Set.mem abs.abs_id old_abs_ids then abs else reorder_in_fresh_abs abs in - let env = C.env_map_abs reorder_in_abs ctx.env in + let env = env_map_abs reorder_in_abs ctx.env in - { ctx with C.env } + { ctx with env } (** Collapse an environment. @@ -136,23 +128,23 @@ let reorder_loans_borrows_in_fresh_abs (old_abs_ids : V.AbstractionId.Set.t) This can happen when merging environments (note that such environments are not well-formed - they become well formed again after collapsing). *) -let collapse_ctx (loop_id : V.LoopId.id) +let collapse_ctx (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) - (ctx0 : C.eval_ctx) : C.eval_ctx = + (ctx0 : eval_ctx) : eval_ctx = (* Debug *) log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string ctx0 ^ "\n\n")); - let abs_kind = V.Loop (loop_id, None, LoopSynthInput) in + let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in - let is_fresh_abs_id (id : V.AbstractionId.id) : bool = - not (V.AbstractionId.Set.mem id old_ids.aids) + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id old_ids.aids) in - let is_fresh_did (id : C.DummyVarId.id) : bool = - not (C.DummyVarId.Set.mem id old_ids.dids) + let is_fresh_did (id : DummyVarId.id) : bool = + not (DummyVarId.Set.mem id old_ids.dids) in (* Convert the dummy values to abstractions (note that when we convert values to abstractions, the resulting abstraction should be destructured) *) @@ -163,18 +155,18 @@ let collapse_ctx (loop_id : V.LoopId.id) (List.map (fun ee -> match ee with - | C.EAbs _ | C.EFrame | C.EBinding (BVar _, _) -> [ ee ] - | C.EBinding (BDummy id, v) -> + | EAbs _ | EFrame | EBinding (BVar _, _) -> [ ee ] + | EBinding (BDummy id, v) -> if is_fresh_did id then let absl = convert_value_to_abstractions abs_kind can_end destructure_shared_values ctx0 v in - List.map (fun abs -> C.EAbs abs) absl + List.map (fun abs -> EAbs abs) absl else [ ee ]) ctx0.env) in - let ctx = { ctx0 with C.env } in + let ctx = { ctx0 with env } in log#ldebug (lazy ("collapse_ctx: after converting values to abstractions:\n" @@ -188,7 +180,7 @@ let collapse_ctx (loop_id : V.LoopId.id) )); (* Explore all the *new* abstractions, and compute various maps *) - let explore (abs : V.abs) = is_fresh_abs_id abs.abs_id in + let explore (abs : abs) = is_fresh_abs_id abs.abs_id in let ids_maps = compute_abs_borrows_loans_maps (merge_funs = None) explore env in @@ -211,8 +203,9 @@ let collapse_ctx (loop_id : V.LoopId.id) in (* Merge the abstractions together *) - let merged_abs : V.AbstractionId.id UF.elem V.AbstractionId.Map.t = - V.AbstractionId.Map.of_list (List.map (fun id -> (id, UF.make id)) abs_ids) + let merged_abs : AbstractionId.id UnionFind.elem AbstractionId.Map.t = + AbstractionId.Map.of_list + (List.map (fun id -> (id, UnionFind.make id)) abs_ids) in let ctx = ref ctx in @@ -226,26 +219,26 @@ let collapse_ctx (loop_id : V.LoopId.id) *) List.iter (fun abs_id0 -> - let bids = V.AbstractionId.Map.find abs_id0 abs_to_borrows in - let bids = V.BorrowId.Set.elements bids in + let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in + let bids = BorrowId.Set.elements bids in List.iter (fun bid -> - match V.BorrowId.Map.find_opt bid loan_to_abs with + match BorrowId.Map.find_opt bid loan_to_abs with | None -> (* Nothing to do *) () | Some abs_ids1 -> - V.AbstractionId.Set.iter + AbstractionId.Set.iter (fun abs_id1 -> (* We need to merge - unless we have already merged *) (* First, find the representatives for the two abstractions (the representative is the abstraction into which we merged) *) let abs_ref0 = - UF.find (V.AbstractionId.Map.find abs_id0 merged_abs) + UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) in - let abs_id0 = UF.get abs_ref0 in + let abs_id0 = UnionFind.get abs_ref0 in let abs_ref1 = - UF.find (V.AbstractionId.Map.find abs_id1 merged_abs) + UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) in - let abs_id1 = UF.get abs_ref1 in + let abs_id1 = UnionFind.get abs_ref1 in (* If the two ids are the same, it means the abstractions were already merged *) if abs_id0 = abs_id1 then () else ( @@ -255,9 +248,9 @@ let collapse_ctx (loop_id : V.LoopId.id) log#ldebug (lazy ("collapse_ctx: merging abstraction " - ^ V.AbstractionId.to_string abs_id1 + ^ AbstractionId.to_string abs_id1 ^ " into " - ^ V.AbstractionId.to_string abs_id0 + ^ AbstractionId.to_string abs_id0 ^ ":\n\n" ^ eval_ctx_to_string !ctx)); (* Update the environment - pay attention to the order: we @@ -269,8 +262,8 @@ let collapse_ctx (loop_id : V.LoopId.id) ctx := nctx; (* Update the union find *) - let abs_ref_merged = UF.union abs_ref0 abs_ref1 in - UF.set abs_ref_merged abs_id)) + let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in + UnionFind.set abs_ref_merged abs_id)) abs_ids1) bids) abs_ids; @@ -292,8 +285,8 @@ let collapse_ctx (loop_id : V.LoopId.id) (* Return the new context *) ctx -let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) - (ctx : C.eval_ctx) : merge_duplicates_funcs = +let mk_collapse_ctx_merge_duplicate_funs (loop_id : LoopId.id) (ctx : eval_ctx) + : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) let module S : MatchJoinState = struct let ctx = ctx @@ -314,8 +307,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) *) let merge_amut_borrows id ty0 child0 _ty1 child1 = (* Sanity checks *) - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (is_aignored child0.value); + assert (is_aignored child1.value); (* We need to pick a type for the avalue. The types on the left and on the right may use different regions: it doesn't really matter (here, we pick @@ -324,8 +317,8 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) *) let ty = ty0 in let child = child0 in - let value = V.ABorrow (V.AMutBorrow (id, child)) in - { V.value; ty } + let value = ABorrow (AMutBorrow (id, child)) in + { value; ty } in let merge_ashared_borrows id ty0 ty1 = @@ -339,37 +332,37 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in - let value = V.ABorrow (V.ASharedBorrow id) in - { V.value; ty } + let value = ABorrow (ASharedBorrow id) in + { value; ty } in let merge_amut_loans id ty0 child0 _ty1 child1 = (* Sanity checks *) - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (is_aignored child0.value); + assert (is_aignored child1.value); (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in - let value = V.ALoan (V.AMutLoan (id, child)) in - { V.value; ty } + let value = ALoan (AMutLoan (id, child)) in + { value; ty } in - let merge_ashared_loans ids ty0 (sv0 : V.typed_value) child0 _ty1 - (sv1 : V.typed_value) child1 = + let merge_ashared_loans ids ty0 (sv0 : typed_value) child0 _ty1 + (sv1 : typed_value) child1 = (* Sanity checks *) - assert (is_aignored child0.V.value); - assert (is_aignored child1.V.value); + assert (is_aignored child0.value); + assert (is_aignored child1.value); (* Same remarks as for [merge_amut_borrows]. This time we need to also merge the shared values. We rely on the join matcher [JM] to do so. *) - assert (not (value_has_loans_or_borrows ctx sv0.V.value)); - assert (not (value_has_loans_or_borrows ctx sv1.V.value)); + assert (not (value_has_loans_or_borrows ctx sv0.value)); + assert (not (value_has_loans_or_borrows ctx sv1.value)); let ty = ty0 in let child = child0 in let sv = M.match_typed_values ctx sv0 sv1 in - let value = V.ALoan (V.ASharedLoan (ids, sv, child)) in - { V.value; ty } + let value = ALoan (ASharedLoan (ids, sv, child)) in + { value; ty } in { merge_amut_borrows; @@ -378,9 +371,9 @@ let mk_collapse_ctx_merge_duplicate_funs (loop_id : V.LoopId.id) merge_ashared_loans; } -let merge_into_abstraction (loop_id : V.LoopId.id) (abs_kind : V.abs_kind) - (can_end : bool) (ctx : C.eval_ctx) (aid0 : V.AbstractionId.id) - (aid1 : V.AbstractionId.id) : C.eval_ctx * V.AbstractionId.id = +let merge_into_abstraction (loop_id : LoopId.id) (abs_kind : abs_kind) + (can_end : bool) (ctx : eval_ctx) (aid0 : AbstractionId.id) + (aid1 : AbstractionId.id) : eval_ctx * AbstractionId.id = let merge_funs = mk_collapse_ctx_merge_duplicate_funs loop_id ctx in merge_into_abstraction abs_kind can_end (Some merge_funs) ctx aid0 aid1 @@ -391,14 +384,14 @@ let merge_into_abstraction (loop_id : V.LoopId.id) (abs_kind : V.abs_kind) We do this because when we join environments, we may introduce duplicated loans and borrows. See the explanations for {!join_ctxs}. *) -let collapse_ctx_with_merge (loop_id : V.LoopId.id) (old_ids : ids_sets) - (ctx : C.eval_ctx) : C.eval_ctx = +let collapse_ctx_with_merge (loop_id : LoopId.id) (old_ids : ids_sets) + (ctx : eval_ctx) : eval_ctx = let merge_funs = mk_collapse_ctx_merge_duplicate_funs loop_id ctx in try collapse_ctx loop_id (Some merge_funs) old_ids ctx with ValueMatchFailure _ -> raise (Failure "Unexpected") -let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) - (ctx1 : C.eval_ctx) : ctx_or_update = +let join_ctxs (loop_id : LoopId.id) (fixed_ids : ids_sets) (ctx0 : eval_ctx) + (ctx1 : eval_ctx) : ctx_or_update = (* Debug *) log#ldebug (lazy @@ -422,7 +415,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) let nabs = ref [] in (* Explore the environments. *) - let join_suffixes (env0 : C.env) (env1 : C.env) : C.env = + let join_suffixes (env0 : env) (env1 : env) : env = (* Debug *) log#ldebug (lazy @@ -434,15 +427,15 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ^ "\n\n")); (* Sanity check: there are no values/abstractions which should be in the prefix *) - let check_valid (ee : C.env_elem) : unit = + let check_valid (ee : env_elem) : unit = match ee with - | C.EBinding (C.BVar _, _) -> + | EBinding (BVar _, _) -> (* Variables are necessarily in the prefix *) raise (Failure "Unreachable") - | EBinding (C.BDummy did, _) -> - assert (not (C.DummyVarId.Set.mem did fixed_ids.dids)) + | EBinding (BDummy did, _) -> + assert (not (DummyVarId.Set.mem did fixed_ids.dids)) | EAbs abs -> - assert (not (V.AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) + assert (not (AbstractionId.Set.mem abs.abs_id fixed_ids.aids)) | EFrame -> (* This should have been eliminated *) raise (Failure "Unreachable") @@ -451,7 +444,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) List.iter check_valid env1; (* Concatenate the suffixes and append the abstractions introduced while joining the prefixes *) - let absl = List.map (fun abs -> C.EAbs abs) (List.rev !nabs) in + let absl = List.map (fun abs -> EAbs abs) (List.rev !nabs) in List.concat [ env0; env1; absl ] in @@ -464,10 +457,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) let module JM = MakeJoinMatcher (S) in let module M = MakeMatcher (JM) in (* Rem.: this function raises exceptions *) - let rec join_prefixes (env0 : C.env) (env1 : C.env) : C.env = + let rec join_prefixes (env0 : env) (env1 : env) : env = match (env0, env1) with - | ( (C.EBinding (C.BDummy b0, v0) as var0) :: env0', - (C.EBinding (C.BDummy b1, v1) as var1) :: env1' ) -> + | ( (EBinding (BDummy b0, v0) as var0) :: env0', + (EBinding (BDummy b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy @@ -481,18 +474,18 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Two cases: the dummy value is an old value, in which case the bindings must be the same and we must join their values. Otherwise, it means we are not in the prefix anymore *) - if C.DummyVarId.Set.mem b0 fixed_ids.dids then ( + if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Still in the prefix: match the values *) assert (b0 = b1); let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.EBinding (C.BDummy b, v) in + let var = EBinding (BDummy b, v) in (* Continue *) var :: join_prefixes env0' env1') else (* Not in the prefix anymore *) join_suffixes env0 env1 - | ( (C.EBinding (C.BVar b0, v0) as var0) :: env0', - (C.EBinding (C.BVar b1, v1) as var1) :: env1' ) -> + | ( (EBinding (BVar b0, v0) as var0) :: env0', + (EBinding (BVar b1, v1) as var1) :: env1' ) -> (* Debug *) log#ldebug (lazy @@ -509,10 +502,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Match the values *) let b = b0 in let v = M.match_typed_values ctx v0 v1 in - let var = C.EBinding (C.BVar b, v) in + let var = EBinding (BVar b, v) in (* Continue *) var :: join_prefixes env0' env1' - | (C.EAbs abs0 as abs) :: env0', C.EAbs abs1 :: env1' -> + | (EAbs abs0 as abs) :: env0', EAbs abs1 :: env1' -> (* Debug *) log#ldebug (lazy @@ -521,7 +514,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ^ "\n\n- abs1:\n" ^ abs_to_string ctx abs1 ^ "\n\n")); (* Same as for the dummy values: there are two cases *) - if V.AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( + if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( (* Still in the prefix: the abstractions must be the same *) assert (abs0 = abs1); (* Continue *) @@ -537,21 +530,20 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) (* Remove the frame delimiter (the first element of an environment is a frame delimiter) *) let env0, env1 = match (env0, env1) with - | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) + | EFrame :: env0, EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in log#ldebug (lazy - ("- env0:\n" ^ C.show_env env0 ^ "\n\n- env1:\n" ^ C.show_env env1 - ^ "\n\n")); + ("- env0:\n" ^ show_env env0 ^ "\n\n- env1:\n" ^ show_env env1 ^ "\n\n")); - let env = List.rev (C.EFrame :: join_prefixes env0 env1) in + let env = List.rev (EFrame :: join_prefixes env0 env1) in (* Construct the joined context - of course, the type, fun, etc. contexts * should be the same in the two contexts *) let { - C.type_context; + type_context; fun_context; global_context; trait_decls_context; @@ -567,7 +559,7 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) ctx0 in let { - C.type_context = _; + type_context = _; fun_context = _; global_context = _; trait_decls_context = _; @@ -582,10 +574,10 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) } = ctx1 in - let ended_regions = T.RegionId.Set.union ended_regions0 ended_regions1 in + let ended_regions = RegionId.Set.union ended_regions0 ended_regions1 in Ok { - C.type_context; + type_context; fun_context; global_context; trait_decls_context; @@ -601,16 +593,16 @@ let join_ctxs (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) with ValueMatchFailure e -> Error e (** Destructure all the new abstractions *) -let destructure_new_abs (loop_id : V.LoopId.id) - (old_abs_ids : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : C.eval_ctx = - let abs_kind = V.Loop (loop_id, None, V.LoopSynthInput) in +let destructure_new_abs (loop_id : LoopId.id) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = + let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in - let is_fresh_abs_id (id : V.AbstractionId.id) : bool = - not (V.AbstractionId.Set.mem id old_abs_ids) + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id old_abs_ids) in let env = - C.env_map_abs + env_map_abs (fun abs -> if is_fresh_abs_id abs.abs_id then let abs = @@ -628,23 +620,22 @@ let destructure_new_abs (loop_id : V.LoopId.id) abstractions in contexts which are later joined: we have to make sure two contexts we join don't have non-fixed abstractions with the same ids. *) -let refresh_abs (old_abs : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : - C.eval_ctx = +let refresh_abs (old_abs : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = let ids, _ = compute_context_ids ctx in - let abs_to_refresh = V.AbstractionId.Set.diff ids.aids old_abs in + let abs_to_refresh = AbstractionId.Set.diff ids.aids old_abs in let aids_subst = List.map - (fun id -> (id, C.fresh_abstraction_id ())) - (V.AbstractionId.Set.elements abs_to_refresh) + (fun id -> (id, fresh_abstraction_id ())) + (AbstractionId.Set.elements abs_to_refresh) in - let aids_subst = V.AbstractionId.Map.of_list aids_subst in + let aids_subst = AbstractionId.Map.of_list aids_subst in let subst id = - match V.AbstractionId.Map.find_opt id aids_subst with + match AbstractionId.Map.find_opt id aids_subst with | None -> id | Some id -> id in let env = - Subst.env_subst_ids + Substitute.env_subst_ids (fun x -> x) (fun x -> x) (fun x -> x) @@ -652,11 +643,11 @@ let refresh_abs (old_abs : V.AbstractionId.Set.t) (ctx : C.eval_ctx) : (fun x -> x) subst ctx.env in - { ctx with C.env } + { ctx with env } -let loop_join_origin_with_continue_ctxs (config : C.config) - (loop_id : V.LoopId.id) (fixed_ids : ids_sets) (old_ctx : C.eval_ctx) - (ctxl : C.eval_ctx list) : (C.eval_ctx * C.eval_ctx list) * C.eval_ctx = +let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) + (fixed_ids : ids_sets) (old_ctx : eval_ctx) (ctxl : eval_ctx list) : + (eval_ctx * eval_ctx list) * eval_ctx = (* # Join with the new contexts, one by one For every context, we repeteadly attempt to join it with the current @@ -666,7 +657,7 @@ let loop_join_origin_with_continue_ctxs (config : C.config) in the one we are trying to add to the join. *) let joined_ctx = ref old_ctx in - let rec join_one_aux (ctx : C.eval_ctx) : C.eval_ctx = + let rec join_one_aux (ctx : eval_ctx) : eval_ctx = match join_ctxs loop_id fixed_ids !joined_ctx ctx with | Ok nctx -> joined_ctx := nctx; @@ -683,7 +674,7 @@ let loop_join_origin_with_continue_ctxs (config : C.config) in join_one_aux ctx in - let join_one (ctx : C.eval_ctx) : C.eval_ctx = + let join_one (ctx : eval_ctx) : eval_ctx = log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: initial ctx:\n" diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index ae655fb8..bb9f14ed 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -1,13 +1,5 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Values +open Contexts open InterpreterUtils open InterpreterLoopsCore @@ -24,13 +16,13 @@ open InterpreterLoopsCore - [aid1] *) val merge_into_abstraction : - V.loop_id -> - V.abs_kind -> + loop_id -> + abs_kind -> bool -> - C.eval_ctx -> - V.abstraction_id -> - V.abstraction_id -> - C.eval_ctx * V.abstraction_id + eval_ctx -> + abstraction_id -> + abstraction_id -> + eval_ctx * abstraction_id (** Join two contexts. @@ -92,8 +84,7 @@ val merge_into_abstraction : - [ctx0] - [ctx1] *) -val join_ctxs : - V.loop_id -> ids_sets -> C.eval_ctx -> C.eval_ctx -> ctx_or_update +val join_ctxs : loop_id -> ids_sets -> eval_ctx -> eval_ctx -> ctx_or_update (** Join the context at the entry of the loop with the contexts upon reentry (upon reaching the [Continue] statement - the goal is to compute a fixed @@ -112,9 +103,9 @@ val join_ctxs : - [ctxl] *) val loop_join_origin_with_continue_ctxs : - C.config -> - V.loop_id -> + config -> + loop_id -> ids_sets -> - C.eval_ctx -> - C.eval_ctx list -> - (C.eval_ctx * C.eval_ctx list) * C.eval_ctx + eval_ctx -> + eval_ctx list -> + (eval_ctx * eval_ctx list) * eval_ctx diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 7741abbc..74f9ba2c 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -4,35 +4,29 @@ to check if two contexts are equivalent (modulo conversion). *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Contexts open TypesUtils open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic open Cps open InterpreterUtils open InterpreterBorrows open InterpreterLoopsCore +module S = SynthesizeSymbolic (** The local logger *) -let log = L.loops_match_ctxs_log +let log = Logging.loops_match_ctxs_log let compute_abs_borrows_loans_maps (no_duplicates : bool) - (explore : V.abs -> bool) (env : C.env) : abs_borrows_loans_maps = + (explore : abs -> bool) (env : env) : abs_borrows_loans_maps = let abs_ids = ref [] in - let abs_to_borrows = ref V.AbstractionId.Map.empty in - let abs_to_loans = ref V.AbstractionId.Map.empty in - let abs_to_borrows_loans = ref V.AbstractionId.Map.empty in - let borrow_to_abs = ref V.BorrowId.Map.empty in - let loan_to_abs = ref V.BorrowId.Map.empty in - let borrow_loan_to_abs = ref V.BorrowId.Map.empty in + let abs_to_borrows = ref AbstractionId.Map.empty in + let abs_to_loans = ref AbstractionId.Map.empty in + let abs_to_borrows_loans = ref AbstractionId.Map.empty in + let borrow_to_abs = ref BorrowId.Map.empty in + let loan_to_abs = ref BorrowId.Map.empty in + let borrow_loan_to_abs = ref BorrowId.Map.empty in let module R (Id0 : Identifiers.Id) (Id1 : Identifiers.Id) = struct (* @@ -65,8 +59,8 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) Some (Id1.Set.add id1 ids)) !map end in - let module RAbsBorrow = R (V.AbstractionId) (V.BorrowId) in - let module RBorrowAbs = R (V.BorrowId) (V.AbstractionId) in + let module RAbsBorrow = R (AbstractionId) (BorrowId) in + let module RBorrowAbs = R (BorrowId) (AbstractionId) in let register_borrow_id abs_id bid = RAbsBorrow.register_mapping false no_duplicates abs_to_borrows abs_id bid; RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id bid; @@ -85,7 +79,7 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) let explore_abs = object (self : 'self) - inherit [_] V.iter_typed_avalue as super + inherit [_] iter_typed_avalue as super (** Make sure we don't register the ignored ids *) method! visit_aloan_content abs_id lc = @@ -119,14 +113,14 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) end in - C.env_iter_abs + env_iter_abs (fun abs -> let abs_id = abs.abs_id in if explore abs then ( abs_to_borrows := - V.AbstractionId.Map.add abs_id V.BorrowId.Set.empty !abs_to_borrows; + AbstractionId.Map.add abs_id BorrowId.Set.empty !abs_to_borrows; abs_to_loans := - V.AbstractionId.Map.add abs_id V.BorrowId.Set.empty !abs_to_loans; + AbstractionId.Map.add abs_id BorrowId.Set.empty !abs_to_loans; abs_ids := abs.abs_id :: !abs_ids; List.iter (explore_abs#visit_typed_avalue abs.abs_id) abs.avalues) else ()) @@ -148,9 +142,8 @@ let compute_abs_borrows_loans_maps (no_duplicates : bool) TODO: probably don't need to take [match_regions] as input anymore. *) -let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) - (match_regions : T.region -> T.region -> T.region) (ty0 : T.ty) (ty1 : T.ty) - : T.ty = +let rec match_types (match_distinct_types : ty -> ty -> ty) + (match_regions : region -> region -> region) (ty0 : ty) (ty1 : ty) : ty = let match_rec = match_types match_distinct_types match_regions in match (ty0, ty1) with | TAdt (id0, generics0), TAdt (id1, generics1) -> @@ -170,7 +163,7 @@ let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) (fun (ty0, ty1) -> match_rec ty0 ty1) (List.combine generics0.types generics1.types) in - let generics = { T.regions; types; const_generics; trait_refs } in + let generics = { regions; types; const_generics; trait_refs } in TAdt (id, generics) | TVar vid0, TVar vid1 -> assert (vid0 = vid1); @@ -189,27 +182,27 @@ let rec match_types (match_distinct_types : T.ty -> T.ty -> T.ty) | _ -> match_distinct_types ty0 ty1 module MakeMatcher (M : PrimMatcher) : Matcher = struct - let rec match_typed_values (ctx : C.eval_ctx) (v0 : V.typed_value) - (v1 : V.typed_value) : V.typed_value = + let rec match_typed_values (ctx : eval_ctx) (v0 : typed_value) + (v1 : typed_value) : typed_value = let match_rec = match_typed_values ctx in - let ty = M.match_etys v0.V.ty v1.V.ty in - match (v0.V.value, v1.V.value) with - | V.VLiteral lv0, V.VLiteral lv1 -> + let ty = M.match_etys v0.ty v1.ty in + match (v0.value, v1.value) with + | VLiteral lv0, VLiteral lv1 -> if lv0 = lv1 then v1 else M.match_distinct_literals ty lv0 lv1 - | V.VAdt av0, V.VAdt av1 -> + | VAdt av0, VAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in let field_values = List.map (fun (f0, f1) -> match_rec f0 f1) fields in - let value : V.value = - V.VAdt { variant_id = av0.variant_id; field_values } + let value : value = + VAdt { variant_id = av0.variant_id; field_values } in - { V.value; ty = v1.V.ty } + { value; ty = v1.ty } else ( (* For now, we don't merge ADTs which contain borrows *) - assert (not (value_has_borrows ctx v0.V.value)); - assert (not (value_has_borrows ctx v1.V.value)); + assert (not (value_has_borrows ctx v0.value)); + assert (not (value_has_borrows ctx v1.value)); (* Merge *) M.match_distinct_adts ty av0 av1) | VBottom, VBottom -> v0 @@ -218,10 +211,10 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (bc0, bc1) with | VSharedBorrow bid0, VSharedBorrow bid1 -> let bid = M.match_shared_borrows match_rec ty bid0 bid1 in - V.VSharedBorrow bid + VSharedBorrow bid | VMutBorrow (bid0, bv0), VMutBorrow (bid1, bv1) -> let bv = match_rec bv0 bv1 in - assert (not (value_has_borrows ctx bv.V.value)); + assert (not (value_has_borrows ctx bv.value)); let bid, bv = M.match_mut_borrows ty bid0 bv0 bid1 bv1 bv in VMutBorrow (bid, bv) | VReservedMutBorrow _, _ @@ -234,7 +227,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct just before function calls which activate them *) raise (Failure "Unexpected") in - { V.value = VBorrow bc; ty } + { value = VBorrow bc; ty } | VLoan lc0, VLoan lc1 -> (* TODO: maybe we should enforce that the ids are always exactly the same - without matching *) @@ -242,24 +235,24 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (lc0, lc1) with | VSharedLoan (ids0, sv0), VSharedLoan (ids1, sv1) -> let sv = match_rec sv0 sv1 in - assert (not (value_has_borrows ctx sv.V.value)); + assert (not (value_has_borrows ctx sv.value)); let ids, sv = M.match_shared_loans ty ids0 ids1 sv in - V.VSharedLoan (ids, sv) + VSharedLoan (ids, sv) | VMutLoan id0, VMutLoan id1 -> let id = M.match_mut_loans ty id0 id1 in VMutLoan id | VSharedLoan _, VMutLoan _ | VMutLoan _, VSharedLoan _ -> raise (Failure "Unreachable") in - { V.value = VLoan lc; ty = v1.V.ty } + { value = VLoan lc; ty = v1.ty } | VSymbolic sv0, VSymbolic sv1 -> (* For now, we force all the symbolic values containing borrows to be eagerly expanded, and we don't support nested borrows *) - assert (not (value_has_borrows ctx v0.V.value)); - assert (not (value_has_borrows ctx v1.V.value)); + assert (not (value_has_borrows ctx v0.value)); + assert (not (value_has_borrows ctx v1.value)); (* Match *) let sv = M.match_symbolic_values sv0 sv1 in - { v1 with V.value = VSymbolic sv } + { v1 with value = VSymbolic sv } | VLoan lc, _ -> ( match lc with | VSharedLoan (ids, _) -> raise (ValueMatchFailure (LoansInLeft ids)) @@ -281,8 +274,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct ^ typed_value_to_string ctx v1)); raise (Failure "Unexpected match case") - and match_typed_avalues (ctx : C.eval_ctx) (v0 : V.typed_avalue) - (v1 : V.typed_avalue) : V.typed_avalue = + and match_typed_avalues (ctx : eval_ctx) (v0 : typed_avalue) + (v1 : typed_avalue) : typed_avalue = log#ldebug (lazy ("match_typed_avalues:\n- value0: " @@ -292,20 +285,20 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let match_rec = match_typed_values ctx in let match_arec = match_typed_avalues ctx in - let ty = M.match_rtys v0.V.ty v1.V.ty in - match (v0.V.value, v1.V.value) with - | V.AAdt av0, V.AAdt av1 -> + let ty = M.match_rtys v0.ty v1.ty in + match (v0.value, v1.value) with + | AAdt av0, AAdt av1 -> if av0.variant_id = av1.variant_id then let fields = List.combine av0.field_values av1.field_values in let field_values = List.map (fun (f0, f1) -> match_arec f0 f1) fields in - let value : V.avalue = - V.AAdt { variant_id = av0.variant_id; field_values } + let value : avalue = + AAdt { variant_id = av0.variant_id; field_values } in - { V.value; ty } + { value; ty } else (* Merge *) - M.match_distinct_aadts v0.V.ty av0 v1.V.ty av1 ty + M.match_distinct_aadts v0.ty av0 v1.ty av1 ty | ABottom, ABottom -> mk_abottom ty | AIgnored, AIgnored -> mk_aignored ty | ABorrow bc0, ABorrow bc1 -> ( @@ -313,7 +306,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct match (bc0, bc1) with | ASharedBorrow bid0, ASharedBorrow bid1 -> log#ldebug (lazy "match_typed_avalues: shared borrows"); - M.match_ashared_borrows v0.V.ty bid0 v1.V.ty bid1 ty + M.match_ashared_borrows v0.ty bid0 v1.ty bid1 ty | AMutBorrow (bid0, av0), AMutBorrow (bid1, av1) -> log#ldebug (lazy "match_typed_avalues: mut borrows"); log#ldebug @@ -322,7 +315,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut borrows: matched children values"); - M.match_amut_borrows v0.V.ty bid0 av0 v1.V.ty bid1 av1 ty av + M.match_amut_borrows v0.ty bid0 av0 v1.ty bid1 av1 ty av | AIgnoredMutBorrow _, AIgnoredMutBorrow _ -> (* The abstractions are destructured: we shouldn't get there *) raise (Failure "Unexpected") @@ -355,9 +348,8 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in - assert (not (value_has_borrows ctx sv.V.value)); - M.match_ashared_loans v0.V.ty ids0 sv0 av0 v1.V.ty ids1 sv1 av1 ty - sv av + assert (not (value_has_borrows ctx sv.value)); + M.match_ashared_loans v0.ty ids0 sv0 av0 v1.ty ids1 sv1 av1 ty sv av | AMutLoan (id0, av0), AMutLoan (id1, av1) -> log#ldebug (lazy "match_typed_avalues: mut loans"); log#ldebug @@ -365,7 +357,7 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut loans: matched children values"); - M.match_amut_loans v0.V.ty id0 av0 v1.V.ty id1 av1 ty av + M.match_amut_loans v0.ty id0 av0 v1.ty id1 av1 ty av | AIgnoredMutLoan _, AIgnoredMutLoan _ | AIgnoredSharedLoan _, AIgnoredSharedLoan _ -> (* Those should have been filtered when destructuring the abstractions - @@ -381,9 +373,9 @@ end module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (** Small utility *) - let push_abs (abs : V.abs) : unit = S.nabs := abs :: !S.nabs + let push_abs (abs : abs) : unit = S.nabs := abs :: !S.nabs - let push_absl (absl : V.abs list) : unit = List.iter push_abs absl + let push_absl (absl : abs list) : unit = List.iter push_abs absl let match_etys ty0 ty1 = assert (ty0 = ty1); @@ -395,24 +387,24 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct assert (ty0 = ty1); ty0 - let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : - V.typed_value = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty + let match_distinct_literals (ty : ety) (_ : literal) (_ : literal) : + typed_value = + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin ty - let match_distinct_adts (ty : T.ety) (adt0 : V.adt_value) (adt1 : V.adt_value) - : V.typed_value = + let match_distinct_adts (ty : ety) (adt0 : adt_value) (adt1 : adt_value) : + typed_value = (* Check that the ADTs don't contain borrows - this is redundant with checks performed by the caller, but we prefer to be safe with regards to future updates *) - let check_no_borrows (v : V.typed_value) = - assert (not (value_has_borrows S.ctx v.V.value)) + let check_no_borrows (v : typed_value) = + assert (not (value_has_borrows S.ctx v.value)) in List.iter check_no_borrows adt0.field_values; List.iter check_no_borrows adt1.field_values; (* Check if there are loans: we request to end them *) - let check_loans (left : bool) (fields : V.typed_value list) : unit = + let check_loans (left : bool) (fields : typed_value list) : unit = match InterpreterBorrowsCore.get_first_loan_in_values fields with | Some (VSharedLoan (ids, _)) -> if left then raise (ValueMatchFailure (LoansInLeft ids)) @@ -426,10 +418,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct check_loans false adt1.field_values; (* No borrows, no loans: we can introduce a symbolic value *) - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin ty - let match_shared_borrows _ (ty : T.ety) (bid0 : V.borrow_id) - (bid1 : V.borrow_id) : V.borrow_id = + let match_shared_borrows _ (ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : + borrow_id = if bid0 = bid1 then bid0 else (* We replace bid0 and bid1 with a fresh borrow id, and introduce @@ -438,42 +430,42 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct { SB bid0, SB bid1, SL {bid2} } ]} *) - let rid = C.fresh_region_id () in - let bid2 = C.fresh_borrow_id () in + let rid = fresh_region_id () in + let bid2 = fresh_borrow_id () in (* Generate a fresh symbolic value for the shared value *) let _, bv_ty, kind = ty_as_ref ty in let sv = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin bv_ty in - let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) - let mk_aborrow (bid : V.borrow_id) : V.typed_avalue = - let value = V.ABorrow (V.ASharedBorrow bid) in - { V.value; ty = borrow_ty } + let mk_aborrow (bid : borrow_id) : typed_avalue = + let value = ABorrow (ASharedBorrow bid) in + { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in let loan = - V.ASharedLoan (V.BorrowId.Set.singleton bid2, sv, mk_aignored bv_ty) + ASharedLoan (BorrowId.Set.singleton bid2, sv, mk_aignored bv_ty) in (* Note that an aloan has a borrow type *) - let loan = { V.value = V.ALoan loan; ty = borrow_ty } in + let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in let avalues = List.append borrows [ loan ] in (* Generate the abstraction *) let abs = { - V.abs_id = C.fresh_abstraction_id (); - kind = V.Loop (S.loop_id, None, LoopSynthInput); + abs_id = fresh_abstraction_id (); + kind = Loop (S.loop_id, None, LoopSynthInput); can_end = true; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton rid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton rid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -482,9 +474,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) bid2 - let match_mut_borrows (ty : T.ety) (bid0 : V.borrow_id) (bv0 : V.typed_value) - (bid1 : V.borrow_id) (bv1 : V.typed_value) (bv : V.typed_value) : - V.borrow_id * V.typed_value = + let match_mut_borrows (ty : ety) (bid0 : borrow_id) (bv0 : typed_value) + (bid1 : borrow_id) (bv1 : typed_value) (bv : typed_value) : + borrow_id * typed_value = if bid0 = bid1 then ( (* If the merged value is not the same as the original value, we introduce an abstraction: @@ -533,29 +525,29 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. *) - assert (not (value_has_borrows S.ctx bv.V.value)); + assert (not (value_has_borrows S.ctx bv.value)); if bv0 = bv1 then ( assert (bv0 = bv); (bid0, bv)) else - let rid = C.fresh_region_id () in - let nbid = C.fresh_borrow_id () in + let rid = fresh_region_id () in + let nbid = fresh_borrow_id () in - let kind = T.Mut in - let bv_ty = bv.V.ty in + let kind = RMut in + let bv_ty = bv.ty in assert (ty_no_regions bv_ty); - let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in let borrow_av = let ty = borrow_ty in - let value = V.ABorrow (V.AMutBorrow (bid0, mk_aignored bv_ty)) in + let value = ABorrow (AMutBorrow (bid0, mk_aignored bv_ty)) in mk_typed_avalue ty value in let loan_av = let ty = borrow_ty in - let value = V.ALoan (V.AMutLoan (nbid, mk_aignored bv_ty)) in + let value = ALoan (AMutLoan (nbid, mk_aignored bv_ty)) in mk_typed_avalue ty value in @@ -564,13 +556,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the abstraction *) let abs = { - V.abs_id = C.fresh_abstraction_id (); - kind = V.Loop (S.loop_id, None, LoopSynthInput); + abs_id = fresh_abstraction_id (); + kind = Loop (S.loop_id, None, LoopSynthInput); can_end = true; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton rid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton rid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -585,42 +577,42 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct { MB bid0, MB bid1, ML bid2 } ]} *) - let rid = C.fresh_region_id () in - let bid2 = C.fresh_borrow_id () in + let rid = fresh_region_id () in + let bid2 = fresh_borrow_id () in (* Generate a fresh symbolic value for the borrowed value *) let _, bv_ty, kind = ty_as_ref ty in let sv = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin bv_ty + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin bv_ty in - let borrow_ty = mk_ref_ty (T.RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) - let mk_aborrow (bid : V.borrow_id) (bv : V.typed_value) : V.typed_avalue = - let bv_ty = bv.V.ty in + let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = + let bv_ty = bv.ty in assert (ty_no_regions bv_ty); - let value = V.ABorrow (V.AMutBorrow (bid, mk_aignored bv_ty)) in - { V.value; ty = borrow_ty } + let value = ABorrow (AMutBorrow (bid, mk_aignored bv_ty)) in + { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in - let loan = V.AMutLoan (bid2, mk_aignored bv_ty) in + let loan = AMutLoan (bid2, mk_aignored bv_ty) in (* Note that an aloan has a borrow type *) - let loan = { V.value = V.ALoan loan; ty = borrow_ty } in + let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in let avalues = List.append borrows [ loan ] in (* Generate the abstraction *) let abs = { - V.abs_id = C.fresh_abstraction_id (); - kind = V.Loop (S.loop_id, None, LoopSynthInput); + abs_id = fresh_abstraction_id (); + kind = Loop (S.loop_id, None, LoopSynthInput); can_end = true; - parents = V.AbstractionId.Set.empty; + parents = AbstractionId.Set.empty; original_parents = []; - regions = T.RegionId.Set.singleton rid; - ancestors_regions = T.RegionId.Set.empty; + regions = RegionId.Set.singleton rid; + ancestors_regions = RegionId.Set.empty; avalues; } in @@ -629,20 +621,19 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return the new borrow *) (bid2, sv) - let match_shared_loans (_ : T.ety) (ids0 : V.loan_id_set) - (ids1 : V.loan_id_set) (sv : V.typed_value) : - V.loan_id_set * V.typed_value = + let match_shared_loans (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) + (sv : typed_value) : loan_id_set * typed_value = (* Check if the ids are the same - Rem.: we forbid the sets of loans to be different. However, if we dive inside data-structures (by using a shared borrow) the shared values might themselves contain shared loans, which need to be matched. For this reason, we destructure the shared values (see {!destructure_abs}). *) - let extra_ids_left = V.BorrowId.Set.diff ids0 ids1 in - let extra_ids_right = V.BorrowId.Set.diff ids1 ids0 in - if not (V.BorrowId.Set.is_empty extra_ids_left) then + let extra_ids_left = BorrowId.Set.diff ids0 ids1 in + let extra_ids_right = BorrowId.Set.diff ids1 ids0 in + if not (BorrowId.Set.is_empty extra_ids_left) then raise (ValueMatchFailure (LoansInLeft extra_ids_left)); - if not (V.BorrowId.Set.is_empty extra_ids_right) then + if not (BorrowId.Set.is_empty extra_ids_right) then raise (ValueMatchFailure (LoansInRight extra_ids_right)); (* This should always be true if we get here *) @@ -652,16 +643,15 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Return *) (ids, sv) - let match_mut_loans (_ : T.ety) (id0 : V.loan_id) (id1 : V.loan_id) : - V.loan_id = + let match_mut_loans (_ : ety) (id0 : loan_id) (id1 : loan_id) : loan_id = if id0 = id1 then id0 else (* We forbid this case for now: if we get there, we force to end both borrows *) raise (ValueMatchFailure (LoanInLeft id0)) - let match_symbolic_values (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : - V.symbolic_value = + let match_symbolic_values (sv0 : symbolic_value) (sv1 : symbolic_value) : + symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in if id0 = id1 then ( @@ -674,17 +664,17 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct borrows *) assert (not (ty_has_borrows S.ctx.type_context.type_infos sv0.sv_ty)); (* We simply introduce a fresh symbolic value *) - mk_fresh_symbolic_value V.LoopJoin sv0.sv_ty) + mk_fresh_symbolic_value LoopJoin sv0.sv_ty) - let match_symbolic_with_other (left : bool) (sv : V.symbolic_value) - (v : V.typed_value) : V.typed_value = + let match_symbolic_with_other (left : bool) (sv : symbolic_value) + (v : typed_value) : typed_value = (* Check that: - there are no borrows in the symbolic value - there are no borrows in the "regular" value If there are loans in the regular value, raise an exception. *) assert (not (ty_has_borrows S.ctx.type_context.type_infos sv.sv_ty)); - assert (not (value_has_borrows S.ctx v.V.value)); + assert (not (value_has_borrows S.ctx v.value)); let value_is_left = not left in (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () @@ -695,10 +685,9 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct if value_is_left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id))); (* Return a fresh symbolic value *) - mk_fresh_symbolic_typed_value V.LoopJoin sv.sv_ty + mk_fresh_symbolic_typed_value LoopJoin sv.sv_ty - let match_bottom_with_other (left : bool) (v : V.typed_value) : V.typed_value - = + let match_bottom_with_other (left : bool) (v : typed_value) : typed_value = (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. *) @@ -719,7 +708,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct else raise (ValueMatchFailure (LoanInRight id))) | None -> (* Convert the value to an abstraction *) - let abs_kind = V.Loop (S.loop_id, None, LoopSynthInput) in + let abs_kind : abs_kind = Loop (S.loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in let absl = @@ -728,7 +717,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct in push_absl absl; (* Return [Bottom] *) - mk_bottom v.V.ty + mk_bottom v.ty (* As explained in comments: we don't use the join matcher to join avalues, only concrete values *) @@ -785,12 +774,12 @@ struct (match_el msg m (Id.Set.elements ks0) (Id.Set.elements ks1)) end - module GetSetRid = MkGetSetM (T.RegionId) + module GetSetRid = MkGetSetM (RegionId) let match_rid = GetSetRid.match_e "match_rid: " S.rid_map let match_rids = GetSetRid.match_es "match_rids: " S.rid_map - module GetSetBid = MkGetSetM (V.BorrowId) + module GetSetBid = MkGetSetM (BorrowId) let match_blid msg = GetSetBid.match_e msg S.blid_map let match_blidl msg = GetSetBid.match_el msg S.blid_map @@ -820,8 +809,8 @@ struct if S.check_equiv then match_blids "match_loan_ids: " else GetSetBid.match_es "match_loan_ids: " S.loan_id_map - module GetSetSid = MkGetSetM (V.SymbolicValueId) - module GetSetAid = MkGetSetM (V.AbstractionId) + module GetSetSid = MkGetSetM (SymbolicValueId) + module GetSetAid = MkGetSetM (AbstractionId) let match_aid = GetSetAid.match_e "match_aid: " S.aid_map let match_aidl = GetSetAid.match_el "match_aidl: " S.aid_map @@ -835,7 +824,7 @@ struct let match_distinct_types _ _ = raise (Distinct "match_rtys") in let match_regions r0 r1 = match (r0, r1) with - | T.RStatic, T.RStatic -> r1 + | RStatic, RStatic -> r1 | RVar rid0, RVar rid1 -> let rid = match_rid rid0 rid1 in RVar rid @@ -843,21 +832,21 @@ struct in match_types match_distinct_types match_regions ty0 ty1 - let match_distinct_literals (ty : T.ety) (_ : V.literal) (_ : V.literal) : - V.typed_value = - mk_fresh_symbolic_typed_value_from_no_regions_ty V.LoopJoin ty + let match_distinct_literals (ty : ety) (_ : literal) (_ : literal) : + typed_value = + mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin ty - let match_distinct_adts (_ty : T.ety) (_adt0 : V.adt_value) - (_adt1 : V.adt_value) : V.typed_value = + let match_distinct_adts (_ty : ety) (_adt0 : adt_value) (_adt1 : adt_value) : + typed_value = raise (Distinct "match_distinct_adts") let match_shared_borrows - (match_typed_values : V.typed_value -> V.typed_value -> V.typed_value) - (_ty : T.ety) (bid0 : V.borrow_id) (bid1 : V.borrow_id) : V.borrow_id = + (match_typed_values : typed_value -> typed_value -> typed_value) + (_ty : ety) (bid0 : borrow_id) (bid1 : borrow_id) : borrow_id = log#ldebug (lazy ("MakeCheckEquivMatcher: match_shared_borrows: " ^ "bid0: " - ^ V.BorrowId.to_string bid0 ^ ", bid1: " ^ V.BorrowId.to_string bid1)); + ^ BorrowId.to_string bid0 ^ ", bid1: " ^ BorrowId.to_string bid1)); let bid = match_borrow_id bid0 bid1 in (* If we don't check for equivalence (i.e., we apply a fixed-point), @@ -881,33 +870,31 @@ struct in bid - let match_mut_borrows (_ty : T.ety) (bid0 : V.borrow_id) - (_bv0 : V.typed_value) (bid1 : V.borrow_id) (_bv1 : V.typed_value) - (bv : V.typed_value) : V.borrow_id * V.typed_value = + let match_mut_borrows (_ty : ety) (bid0 : borrow_id) (_bv0 : typed_value) + (bid1 : borrow_id) (_bv1 : typed_value) (bv : typed_value) : + borrow_id * typed_value = let bid = match_borrow_id bid0 bid1 in (bid, bv) - let match_shared_loans (_ : T.ety) (ids0 : V.loan_id_set) - (ids1 : V.loan_id_set) (sv : V.typed_value) : - V.loan_id_set * V.typed_value = + let match_shared_loans (_ : ety) (ids0 : loan_id_set) (ids1 : loan_id_set) + (sv : typed_value) : loan_id_set * typed_value = let ids = match_loan_ids ids0 ids1 in (ids, sv) - let match_mut_loans (_ : T.ety) (bid0 : V.loan_id) (bid1 : V.loan_id) : - V.loan_id = + let match_mut_loans (_ : ety) (bid0 : loan_id) (bid1 : loan_id) : loan_id = match_loan_id bid0 bid1 - let match_symbolic_values (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : - V.symbolic_value = + let match_symbolic_values (sv0 : symbolic_value) (sv1 : symbolic_value) : + symbolic_value = let id0 = sv0.sv_id in let id1 = sv1.sv_id in log#ldebug (lazy ("MakeCheckEquivMatcher: match_symbolic_values: " ^ "sv0: " - ^ V.SymbolicValueId.to_string id0 + ^ SymbolicValueId.to_string id0 ^ ", sv1: " - ^ V.SymbolicValueId.to_string id1)); + ^ SymbolicValueId.to_string id1)); (* If we don't check for equivalence, we also update the map from sids to values *) @@ -916,81 +903,80 @@ struct let sv_id = GetSetSid.match_e "match_symbolic_values: ids: " S.sid_map id0 id1 in - let sv_ty = match_rtys sv0.V.sv_ty sv1.V.sv_ty in + let sv_ty = match_rtys sv0.sv_ty sv1.sv_ty in let sv_kind = - if sv0.V.sv_kind = sv1.V.sv_kind then sv0.V.sv_kind + if sv0.sv_kind = sv1.sv_kind then sv0.sv_kind else raise (Distinct "match_symbolic_values: sv_kind") in - let sv = { V.sv_id; sv_ty; sv_kind } in + let sv = { sv_id; sv_ty; sv_kind } in sv else ( (* Check: fixed values are fixed *) - assert (id0 = id1 || not (V.SymbolicValueId.InjSubst.mem id0 !S.sid_map)); + assert (id0 = id1 || not (SymbolicValueId.InjSubst.mem id0 !S.sid_map)); (* Update the symbolic value mapping *) let sv1 = mk_typed_value_from_symbolic_value sv1 in (* Update the symbolic value mapping *) S.sid_to_value_map := - V.SymbolicValueId.Map.add_strict id0 sv1 !S.sid_to_value_map; + SymbolicValueId.Map.add_strict id0 sv1 !S.sid_to_value_map; (* Return - the returned value is not used: we can return whatever we want *) sv0) - let match_symbolic_with_other (left : bool) (sv : V.symbolic_value) - (v : V.typed_value) : V.typed_value = + let match_symbolic_with_other (left : bool) (sv : symbolic_value) + (v : typed_value) : typed_value = if S.check_equiv then raise (Distinct "match_symbolic_with_other") else ( assert left; let id = sv.sv_id in (* Check: fixed values are fixed *) - assert (not (V.SymbolicValueId.InjSubst.mem id !S.sid_map)); + assert (not (SymbolicValueId.InjSubst.mem id !S.sid_map)); (* Update the binding for the target symbolic value *) S.sid_to_value_map := - V.SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; + SymbolicValueId.Map.add_strict id v !S.sid_to_value_map; (* Return - the returned value is not used, so we can return whatever we want *) v) - let match_bottom_with_other (left : bool) (v : V.typed_value) : V.typed_value - = + let match_bottom_with_other (left : bool) (v : typed_value) : typed_value = (* It can happen that some variables get initialized in some branches and not in some others, which causes problems when matching. *) (* TODO: the returned value is not used, while it should: in generality it should be ok to match a fixed-point with the environment we get at a continue, where the fixed point contains some bottom values. *) - if left && not (value_has_loans_or_borrows S.ctx v.V.value) then - mk_bottom v.V.ty + if left && not (value_has_loans_or_borrows S.ctx v.value) then + mk_bottom v.ty else raise (Distinct "match_bottom_with_other") let match_distinct_aadts _ _ _ _ _ = raise (Distinct "match_distinct_adts") let match_ashared_borrows _ty0 bid0 _ty1 bid1 ty = let bid = match_borrow_id bid0 bid1 in - let value = V.ABorrow (V.ASharedBorrow bid) in - { V.value; ty } + let value = ABorrow (ASharedBorrow bid) in + { value; ty } let match_amut_borrows _ty0 bid0 _av0 _ty1 bid1 _av1 ty av = let bid = match_borrow_id bid0 bid1 in - let value = V.ABorrow (V.AMutBorrow (bid, av)) in - { V.value; ty } + let value = ABorrow (AMutBorrow (bid, av)) in + { value; ty } let match_ashared_loans _ty0 ids0 _v0 _av0 _ty1 ids1 _v1 _av1 ty v av = let bids = match_loan_ids ids0 ids1 in - let value = V.ALoan (V.ASharedLoan (bids, v, av)) in - { V.value; ty } + let value = ALoan (ASharedLoan (bids, v, av)) in + { value; ty } let match_amut_loans _ty0 id0 _av0 _ty1 id1 _av1 ty av = log#ldebug (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " - ^ V.BorrowId.to_string id0 ^ "\n- id1: " ^ V.BorrowId.to_string id1 - ^ "\n- ty: " ^ PA.ty_to_string S.ctx ty ^ "\n- av: " + ^ BorrowId.to_string id0 ^ "\n- id1: " ^ BorrowId.to_string id1 + ^ "\n- ty: " ^ ty_to_string S.ctx ty ^ "\n- av: " ^ typed_avalue_to_string S.ctx av)); let id = match_loan_id id0 id1 in - let value = V.ALoan (V.AMutLoan (id, av)) in - { V.value; ty } + let value = ALoan (AMutLoan (id, av)) in + { value; ty } let match_avalues v0 v1 = log#ldebug @@ -1003,9 +989,9 @@ struct end let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) - (lookup_shared_value_in_ctx0 : V.BorrowId.id -> V.typed_value) - (lookup_shared_value_in_ctx1 : V.BorrowId.id -> V.typed_value) - (ctx0 : C.eval_ctx) (ctx1 : C.eval_ctx) : ids_maps option = + (lookup_shared_value_in_ctx0 : BorrowId.id -> typed_value) + (lookup_shared_value_in_ctx1 : BorrowId.id -> typed_value) (ctx0 : eval_ctx) + (ctx1 : eval_ctx) : ids_maps option = log#ldebug (lazy ("match_ctxs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids @@ -1022,35 +1008,35 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) (Id.InjSubst.of_list (List.map (fun x -> (x, x)) (Id.Set.elements ids))) end in let rid_map = - let module IdMap = IdMap (T.RegionId) in + let module IdMap = IdMap (RegionId) in IdMap.mk_map_ref fixed_ids.rids in let blid_map = - let module IdMap = IdMap (V.BorrowId) in + let module IdMap = IdMap (BorrowId) in IdMap.mk_map_ref fixed_ids.blids in let borrow_id_map = - let module IdMap = IdMap (V.BorrowId) in + let module IdMap = IdMap (BorrowId) in IdMap.mk_map_ref fixed_ids.borrow_ids in let loan_id_map = - let module IdMap = IdMap (V.BorrowId) in + let module IdMap = IdMap (BorrowId) in IdMap.mk_map_ref fixed_ids.loan_ids in let aid_map = - let module IdMap = IdMap (V.AbstractionId) in + let module IdMap = IdMap (AbstractionId) in IdMap.mk_map_ref fixed_ids.aids in let sid_map = - let module IdMap = IdMap (V.SymbolicValueId) in + let module IdMap = IdMap (SymbolicValueId) in IdMap.mk_map_ref fixed_ids.sids in (* In case we don't try to check equivalence but want to compute a mapping from a source context to a target context, we use a map from symbolic value ids to values (rather than to ids). *) - let sid_to_value_map : V.typed_value V.SymbolicValueId.Map.t ref = - ref V.SymbolicValueId.Map.empty + let sid_to_value_map : typed_value SymbolicValueId.Map.t ref = + ref SymbolicValueId.Map.empty in let module S : MatchCheckEquivState = struct @@ -1074,12 +1060,12 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) (* Small utility: check that ids are fixed/mapped to themselves *) let ids_are_fixed (ids : ids_sets) : bool = let { aids; blids = _; borrow_ids; loan_ids; dids; rids; sids } = ids in - V.AbstractionId.Set.subset aids fixed_ids.aids - && V.BorrowId.Set.subset borrow_ids fixed_ids.borrow_ids - && V.BorrowId.Set.subset loan_ids fixed_ids.loan_ids - && C.DummyVarId.Set.subset dids fixed_ids.dids - && T.RegionId.Set.subset rids fixed_ids.rids - && V.SymbolicValueId.Set.subset sids fixed_ids.sids + AbstractionId.Set.subset aids fixed_ids.aids + && BorrowId.Set.subset borrow_ids fixed_ids.borrow_ids + && BorrowId.Set.subset loan_ids fixed_ids.loan_ids + && DummyVarId.Set.subset dids fixed_ids.dids + && RegionId.Set.subset rids fixed_ids.rids + && SymbolicValueId.Set.subset sids fixed_ids.sids in (* We need to pick a context for some functions like [match_typed_values]: @@ -1091,9 +1077,9 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) let ctx = ctx0 in (* Rem.: this function raises exceptions of type [Distinct] *) - let match_abstractions (abs0 : V.abs) (abs1 : V.abs) : unit = + let match_abstractions (abs0 : abs) (abs1 : abs) : unit = let { - V.abs_id = abs_id0; + abs_id = abs_id0; kind = kind0; can_end = can_end0; parents = parents0; @@ -1106,7 +1092,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) in let { - V.abs_id = abs_id1; + abs_id = abs_id1; kind = kind1; can_end = can_end1; parents = parents1; @@ -1137,18 +1123,18 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) in (* Rem.: this function raises exceptions of type [Distinct] *) - let rec match_envs (env0 : C.env) (env1 : C.env) : unit = + let rec match_envs (env0 : env) (env1 : env) : unit = log#ldebug (lazy ("match_ctxs: match_envs:\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- rid_map: " - ^ T.RegionId.InjSubst.show_t !rid_map + ^ RegionId.InjSubst.show_t !rid_map ^ "\n- blid_map: " - ^ V.BorrowId.InjSubst.show_t !blid_map + ^ BorrowId.InjSubst.show_t !blid_map ^ "\n- sid_map: " - ^ V.SymbolicValueId.InjSubst.show_t !sid_map + ^ SymbolicValueId.InjSubst.show_t !sid_map ^ "\n- aid_map: " - ^ V.AbstractionId.InjSubst.show_t !aid_map + ^ AbstractionId.InjSubst.show_t !aid_map ^ "\n\n- ctx0:\n" ^ eval_ctx_to_string_no_filter { ctx0 with env = List.rev env0 } ^ "\n\n- ctx1:\n" @@ -1156,11 +1142,10 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) ^ "\n\n")); match (env0, env1) with - | ( C.EBinding (C.BDummy b0, v0) :: env0', - C.EBinding (C.BDummy b1, v1) :: env1' ) -> + | EBinding (BDummy b0, v0) :: env0', EBinding (BDummy b1, v1) :: env1' -> (* Sanity check: if the dummy value is an old value, the bindings must be the same and their values equal (and the borrows/loans/symbolic *) - if C.DummyVarId.Set.mem b0 fixed_ids.dids then ( + if DummyVarId.Set.mem b0 fixed_ids.dids then ( (* Fixed values: the values must be equal *) assert (b0 = b1); assert (v0 = v1); @@ -1171,17 +1156,16 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) are the identity actually) *) let _ = M.match_typed_values ctx v0 v1 in match_envs env0' env1' - | C.EBinding (C.BVar b0, v0) :: env0', C.EBinding (C.BVar b1, v1) :: env1' - -> + | EBinding (BVar b0, v0) :: env0', EBinding (BVar b1, v1) :: env1' -> assert (b0 = b1); (* Match the values *) let _ = M.match_typed_values ctx v0 v1 in (* Continue *) match_envs env0' env1' - | C.EAbs abs0 :: env0', C.EAbs abs1 :: env1' -> + | EAbs abs0 :: env0', EAbs abs1 :: env1' -> log#ldebug (lazy "match_ctxs: match_envs: matching abs"); (* Same as for the dummy values: there are two cases *) - if V.AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( + if AbstractionId.Set.mem abs0.abs_id fixed_ids.aids then ( log#ldebug (lazy "match_ctxs: match_envs: matching abs: fixed abs"); (* Still in the prefix: the abstractions must be the same *) assert (abs0 = abs1); @@ -1214,7 +1198,7 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) let env1 = List.rev ctx1.env in let env0, env1 = match (env0, env1) with - | C.EFrame :: env0, C.EFrame :: env1 -> (env0, env1) + | EFrame :: env0, EFrame :: env1 -> (env0, env1) | _ -> raise (Failure "Unreachable") in @@ -1235,18 +1219,18 @@ let match_ctxs (check_equiv : bool) (fixed_ids : ids_sets) log#ldebug (lazy ("match_ctxs: distinct: " ^ msg)); None -let ctxs_are_equivalent (fixed_ids : ids_sets) (ctx0 : C.eval_ctx) - (ctx1 : C.eval_ctx) : bool = +let ctxs_are_equivalent (fixed_ids : ids_sets) (ctx0 : eval_ctx) + (ctx1 : eval_ctx) : bool = let check_equivalent = true in let lookup_shared_value _ = raise (Failure "Unreachable") in Option.is_some (match_ctxs check_equivalent fixed_ids lookup_shared_value lookup_shared_value ctx0 ctx1) -let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) +let match_ctx_with_target (config : config) (loop_id : LoopId.id) (is_loop_entry : bool) (fp_bl_maps : borrow_loan_corresp) - (fp_input_svalues : V.SymbolicValueId.id list) (fixed_ids : ids_sets) - (src_ctx : C.eval_ctx) : st_cm_fun = + (fp_input_svalues : SymbolicValueId.id list) (fixed_ids : ids_sets) + (src_ctx : eval_ctx) : st_cm_fun = fun cf tgt_ctx -> (* Debug *) log#ldebug @@ -1277,7 +1261,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) ^ env_to_string tgt_ctx filt_tgt_env)); (* Remove the abstractions *) - let filter (ee : C.env_elem) : bool = + let filter (ee : env_elem) : bool = match ee with EBinding _ -> true | EAbs _ | EFrame -> false in let filt_src_env = List.filter filter filt_src_env in @@ -1307,11 +1291,11 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) List.iter (fun (var0, var1) -> match (var0, var1) with - | C.EBinding (C.BDummy b0, v0), C.EBinding (C.BDummy b1, v1) -> + | EBinding (BDummy b0, v0), EBinding (BDummy b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () - | C.EBinding (C.BVar b0, v0), C.EBinding (C.BVar b1, v1) -> + | EBinding (BVar b0, v0), EBinding (BVar b1, v1) -> assert (b0 = b1); let _ = M.match_typed_values ctx v0 v1 in () @@ -1364,7 +1348,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) let check_equiv = false in let fixed_ids = ids_sets_empty_borrows_loans fixed_ids in let open InterpreterBorrowsCore in - let lookup_shared_loan lid ctx : V.typed_value = + let lookup_shared_loan lid ctx : typed_value = match snd (lookup_loan ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v | Abstract (ASharedLoan (_, v, _)) -> v @@ -1378,10 +1362,10 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) filt_src_ctx filt_tgt_ctx) in let tgt_to_src_borrow_map = - V.BorrowId.Map.of_list + BorrowId.Map.of_list (List.map (fun (x, y) -> (y, x)) - (V.BorrowId.InjSubst.bindings src_to_tgt_maps.borrow_id_map)) + (BorrowId.InjSubst.bindings src_to_tgt_maps.borrow_id_map)) in (* Debug *) @@ -1395,7 +1379,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) ^ eval_ctx_to_string_no_filter filt_src_ctx ^ "\n\n- new_absl:\n" ^ eval_ctx_to_string - { src_ctx with C.env = List.map (fun abs -> C.EAbs abs) new_absl } + { src_ctx with env = List.map (fun abs -> EAbs abs) new_absl } ^ "\n\n- fixed_ids:\n" ^ show_ids_sets fixed_ids ^ "\n\n- fp_bl_maps:\n" ^ show_borrow_loan_corresp fp_bl_maps ^ "\n\n- src_to_tgt_maps: " @@ -1452,26 +1436,26 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (* First, compute the set of borrows which appear in the fresh abstractions of the fixed-point: we want to introduce fresh ids only for those. *) let new_absl_ids, _ = compute_absl_ids new_absl in - let src_fresh_borrows_map = ref V.BorrowId.Map.empty in + let src_fresh_borrows_map = ref BorrowId.Map.empty in let visit_tgt = object - inherit [_] C.map_eval_ctx + inherit [_] map_eval_ctx method! visit_borrow_id _ id = (* Map the borrow, if it needs to be mapped *) if (* We map the borrows for which we computed a mapping *) - V.BorrowId.InjSubst.Set.mem id - (V.BorrowId.InjSubst.elements src_to_tgt_maps.borrow_id_map) + BorrowId.InjSubst.Set.mem id + (BorrowId.InjSubst.elements src_to_tgt_maps.borrow_id_map) (* And which have corresponding loans in the fresh fixed-point abstractions *) - && V.BorrowId.Set.mem - (V.BorrowId.Map.find id tgt_to_src_borrow_map) + && BorrowId.Set.mem + (BorrowId.Map.find id tgt_to_src_borrow_map) new_absl_ids.loan_ids then ( - let src_id = V.BorrowId.Map.find id tgt_to_src_borrow_map in - let nid = C.fresh_borrow_id () in + let src_id = BorrowId.Map.find id tgt_to_src_borrow_map in + let nid = fresh_borrow_id () in src_fresh_borrows_map := - V.BorrowId.Map.add src_id nid !src_fresh_borrows_map; + BorrowId.Map.add src_id nid !src_fresh_borrows_map; nid) else id end @@ -1482,7 +1466,7 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: \ src_fresh_borrows_map:\n" - ^ V.BorrowId.Map.show V.BorrowId.to_string !src_fresh_borrows_map + ^ BorrowId.Map.show BorrowId.to_string !src_fresh_borrows_map ^ "\n")); (* Rem.: we don't update the symbolic values. It is not necessary @@ -1507,48 +1491,44 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) abs@2 { MB l5, ML l6 } ]} *) - let region_id_map = ref T.RegionId.Map.empty in + let region_id_map = ref RegionId.Map.empty in let get_rid rid = - match T.RegionId.Map.find_opt rid !region_id_map with + match RegionId.Map.find_opt rid !region_id_map with | Some rid -> rid | None -> - let nid = C.fresh_region_id () in - region_id_map := T.RegionId.Map.add rid nid !region_id_map; + let nid = fresh_region_id () in + region_id_map := RegionId.Map.add rid nid !region_id_map; nid in let visit_src = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super method! visit_borrow_id _ bid = log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: \ - visit_borrow_id: " ^ V.BorrowId.to_string bid ^ "\n")); + visit_borrow_id: " ^ BorrowId.to_string bid ^ "\n")); (* Lookup the id of the loan corresponding to this borrow *) let src_lid = - V.BorrowId.InjSubst.find bid fp_bl_maps.borrow_to_loan_id_map + BorrowId.InjSubst.find bid fp_bl_maps.borrow_to_loan_id_map in log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: looked up \ - src_lid: " - ^ V.BorrowId.to_string src_lid - ^ "\n")); + src_lid: " ^ BorrowId.to_string src_lid ^ "\n")); (* Lookup the tgt borrow id to which this borrow was mapped *) let tgt_bid = - V.BorrowId.InjSubst.find src_lid src_to_tgt_maps.borrow_id_map + BorrowId.InjSubst.find src_lid src_to_tgt_maps.borrow_id_map in log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: looked up \ - tgt_bid: " - ^ V.BorrowId.to_string tgt_bid - ^ "\n")); + tgt_bid: " ^ BorrowId.to_string tgt_bid ^ "\n")); tgt_bid @@ -1556,39 +1536,39 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) log#ldebug (lazy ("match_ctx_with_target: cf_introduce_loop_fp_abs: \ - visit_loan_id: " ^ V.BorrowId.to_string id ^ "\n")); + visit_loan_id: " ^ BorrowId.to_string id ^ "\n")); (* Map the borrow - rem.: we mapped the borrows *in the values*, meaning we know how to map the *corresponding loans in the abstractions* *) - match V.BorrowId.Map.find_opt id !src_fresh_borrows_map with + match BorrowId.Map.find_opt id !src_fresh_borrows_map with | None -> (* No mapping: this means that the borrow was mapped when we matched values (it doesn't come from a fresh abstraction) and because of this, it should actually be mapped to itself *) assert ( - V.BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id); + BorrowId.InjSubst.find id src_to_tgt_maps.borrow_id_map = id); id | Some id -> id - method! visit_symbolic_value_id _ _ = C.fresh_symbolic_value_id () - method! visit_abstraction_id _ _ = C.fresh_abstraction_id () + method! visit_symbolic_value_id _ _ = fresh_symbolic_value_id () + method! visit_abstraction_id _ _ = fresh_abstraction_id () method! visit_region_id _ id = get_rid id (** We also need to change the abstraction kind *) method! visit_abs env abs = match abs.kind with - | V.Loop (loop_id', rg_id, kind) -> + | Loop (loop_id', rg_id, kind) -> assert (loop_id' = loop_id); - assert (kind = V.LoopSynthInput); + assert (kind = LoopSynthInput); let can_end = false in - let kind = V.Loop (loop_id, rg_id, V.LoopCall) in + let kind : abs_kind = Loop (loop_id, rg_id, LoopCall) in let abs = { abs with kind; can_end } in super#visit_abs env abs | _ -> super#visit_abs env abs end in let new_absl = List.map (visit_src#visit_abs ()) new_absl in - let new_absl = List.map (fun abs -> C.EAbs abs) new_absl in + let new_absl = List.map (fun abs -> EAbs abs) new_absl in (* Add the abstractions from the target context to the source context *) let nenv = List.append new_absl tgt_ctx.env in @@ -1605,19 +1585,17 @@ let match_ctx_with_target (config : C.config) (loop_id : V.LoopId.id) (* End all the borrows which appear in the *new* abstractions *) let new_borrows = - V.BorrowId.Set.of_list - (List.map snd (V.BorrowId.Map.bindings !src_fresh_borrows_map)) + BorrowId.Set.of_list + (List.map snd (BorrowId.Map.bindings !src_fresh_borrows_map)) in let cc = InterpreterBorrows.end_borrows config new_borrows in (* Compute the loop input values *) let input_values = - V.SymbolicValueId.Map.of_list + SymbolicValueId.Map.of_list (List.map (fun sid -> - ( sid, - V.SymbolicValueId.Map.find sid src_to_tgt_maps.sid_to_value_map - )) + (sid, SymbolicValueId.Map.find sid src_to_tgt_maps.sid_to_value_map)) fp_input_svalues) in diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index 20b997ce..bf29af79 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -4,15 +4,8 @@ to check if two contexts are equivalent (modulo conversion). *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module Inv = Invariants -module S = SynthesizeSymbolic +open Values +open Contexts open Cps open InterpreterUtils open InterpreterLoopsCore @@ -26,7 +19,7 @@ open InterpreterLoopsCore - [env] *) val compute_abs_borrows_loans_maps : - bool -> (V.abs -> bool) -> C.env -> abs_borrows_loans_maps + bool -> (abs -> bool) -> env -> abs_borrows_loans_maps (** Generic functor to implement matching functions between values, environments, etc. @@ -100,10 +93,10 @@ module MakeCheckEquivMatcher : functor (_ : MatchCheckEquivState) -> val match_ctxs : bool -> ids_sets -> - (V.loan_id -> V.typed_value) -> - (V.loan_id -> V.typed_value) -> - C.eval_ctx -> - C.eval_ctx -> + (loan_id -> typed_value) -> + (loan_id -> typed_value) -> + eval_ctx -> + eval_ctx -> ids_maps option (** Compute whether two contexts are equivalent modulo an identifier substitution. @@ -142,7 +135,7 @@ val match_ctxs : - [ctx0] - [ctx1] *) -val ctxs_are_equivalent : ids_sets -> C.eval_ctx -> C.eval_ctx -> bool +val ctxs_are_equivalent : ids_sets -> eval_ctx -> eval_ctx -> bool (** Match a context with a target context. @@ -291,11 +284,11 @@ val ctxs_are_equivalent : ids_sets -> C.eval_ctx -> C.eval_ctx -> bool - [src_ctx] *) val match_ctx_with_target : - C.config -> - V.loop_id -> + config -> + loop_id -> bool -> borrow_loan_corresp -> - V.symbolic_value_id list -> + symbolic_value_id list -> ids_sets -> - C.eval_ctx -> + eval_ctx -> st_cm_fun diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 9158f2c1..729a3577 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -1,10 +1,7 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Types +open Values +open Expressions +open Contexts open Cps open ValuesUtils open InterpreterUtils @@ -14,7 +11,7 @@ open InterpreterExpansion module Synth = SynthesizeSymbolic (** The local logger *) -let log = L.paths_log +let log = Logging.paths_log (** Paths *) @@ -25,26 +22,26 @@ let log = L.paths_log TODO: compare with borrow_lres? *) type path_fail_kind = - | FailSharedLoan of V.BorrowId.Set.t + | FailSharedLoan of BorrowId.Set.t (** Failure because we couldn't go inside a shared loan *) - | FailMutLoan of V.BorrowId.id + | FailMutLoan of BorrowId.id (** Failure because we couldn't go inside a mutable loan *) - | FailReservedMutBorrow of V.BorrowId.id + | FailReservedMutBorrow of BorrowId.id (** Failure because we couldn't go inside a reserved mutable borrow (which should get activated) *) - | FailSymbolic of int * V.symbolic_value + | FailSymbolic of int * symbolic_value (** Failure because we need to enter a symbolic value (and thus need to expand it). We return the number of elements which remained in the path when we reached the error - this allows to retrieve the path prefix, which is useful for the synthesis. *) - | FailBottom of int * E.projection_elem * T.ety + | FailBottom of int * projection_elem * ety (** Failure because we need to enter an any value - we can expand Bottom values if they are left values. We return the number of elements which remained in the path when we reached the error - this allows to properly update the Bottom value, if needs be. *) - | FailBorrow of V.borrow_content + | FailBorrow of borrow_content (** We got stuck because we couldn't enter a borrow *) [@@deriving show] @@ -56,7 +53,7 @@ type path_fail_kind = type 'a path_access_result = ('a, path_fail_kind) result (** The result of reading from/writing to a place *) -type updated_read_value = { read : V.typed_value; updated : V.typed_value } +type updated_read_value = { read : typed_value; updated : typed_value } type projection_access = { enter_shared_loans : bool; @@ -71,10 +68,10 @@ type projection_access = { TODO: use exceptions? *) -let rec access_projection (access : projection_access) (ctx : C.eval_ctx) +let rec access_projection (access : projection_access) (ctx : eval_ctx) (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.projection) - (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = + (update : typed_value -> typed_value) (p : projection) (v : typed_value) : + (eval_ctx * updated_read_value) path_access_result = (* For looking up/updating shared loans *) let ek : exploration_kind = { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } @@ -86,8 +83,8 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) if nv.ty <> v.ty then ( log#lerror (lazy - ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " - ^ T.show_ety v.ty)); + ("Not the same type:\n- nv.ty: " ^ show_ety nv.ty ^ "\n- v.ty: " + ^ show_ety v.ty)); raise (Failure "Assertion failed: new value doesn't have the same type as its \ @@ -106,30 +103,30 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) assert (opt_variant_id = adt.variant_id) | _ -> raise (Failure "Unreachable")); (* Actually project *) - let fv = T.FieldId.nth adt.field_values field_id in + let fv = FieldId.nth adt.field_values field_id in match access_projection access ctx update p' fv with | Error err -> Error err | Ok (ctx, res) -> (* Update the field value *) let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated + FieldId.update_nth adt.field_values field_id res.updated in - let nadt = V.VAdt { adt with field_values = nvalues } in + let nadt = VAdt { adt with field_values = nvalues } in let updated = { v with value = nadt } in Ok (ctx, { res with updated })) (* Tuples *) | Field (ProjTuple arity, field_id), VAdt adt, TAdt (TTuple, _) -> ( assert (arity = List.length adt.field_values); - let fv = T.FieldId.nth adt.field_values field_id in + let fv = FieldId.nth adt.field_values field_id in (* Project *) match access_projection access ctx update p' fv with | Error err -> Error err | Ok (ctx, res) -> (* Update the field value *) let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated + FieldId.update_nth adt.field_values field_id res.updated in - let ntuple = V.VAdt { adt with field_values = nvalues } in + let ntuple = VAdt { adt with field_values = nvalues } in let updated = { v with value = ntuple } in Ok (ctx, { res with updated }) (* If we reach Bottom, it may mean we need to expand an uninitialized @@ -244,9 +241,9 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) else Error (FailSharedLoan bids)) | (_, (VLiteral _ | VAdt _ | VBottom | VBorrow _), _) as r -> let pe, v, ty = r in - let pe = "- pe: " ^ E.show_projection_elem pe in - let v = "- v:\n" ^ V.show_value v in - let ty = "- ty:\n" ^ T.show_ety ty in + let pe = "- pe: " ^ show_projection_elem pe in + let v = "- v:\n" ^ show_value v in + let ty = "- ty:\n" ^ show_ety ty in log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); raise (Failure "Inconsistent projection")) @@ -258,16 +255,16 @@ let rec access_projection (access : projection_access) (ctx : C.eval_ctx) *) let access_place (access : projection_access) (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) - : (C.eval_ctx * V.typed_value) path_access_result = + (update : typed_value -> typed_value) (p : place) (ctx : eval_ctx) : + (eval_ctx * typed_value) path_access_result = (* Lookup the variable's value *) - let value = C.ctx_lookup_var_value ctx p.var_id in + let value = ctx_lookup_var_value ctx p.var_id in (* Apply the projection *) match access_projection access ctx update p.projection value with | Error err -> Error err | Ok (ctx, res) -> (* Update the value *) - let ctx = C.ctx_update_var_value ctx p.var_id res.updated in + let ctx = ctx_update_var_value ctx p.var_id res.updated in (* Return *) Ok (ctx, res.read) @@ -303,8 +300,8 @@ let access_kind_to_projection_access (access : access_kind) : projection_access Note that we only access the value at the place, and do not check that the value is "well-formed" (for instance that it doesn't contain bottoms). *) -let try_read_place (access : access_kind) (p : E.place) (ctx : C.eval_ctx) : - V.typed_value path_access_result = +let try_read_place (access : access_kind) (p : place) (ctx : eval_ctx) : + typed_value path_access_result = let access = access_kind_to_projection_access access in (* The update function is the identity *) let update v = v in @@ -318,22 +315,21 @@ let try_read_place (access : access_kind) (p : E.place) (ctx : C.eval_ctx) : if ctx1 <> ctx then ( let msg = "Unexpected environment update:\nNew environment:\n" - ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" - ^ C.show_env ctx.env + ^ show_env ctx1.env ^ "\n\nOld environment:\n" ^ show_env ctx.env in log#serror msg; raise (Failure "Unexpected environment update")); Ok read_value -let read_place (access : access_kind) (p : E.place) (ctx : C.eval_ctx) : - V.typed_value = +let read_place (access : access_kind) (p : place) (ctx : eval_ctx) : typed_value + = match try_read_place access p ctx with | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) | Ok v -> v (** Attempt to update the value at a given place *) -let try_write_place (access : access_kind) (p : E.place) (nv : V.typed_value) - (ctx : C.eval_ctx) : C.eval_ctx path_access_result = +let try_write_place (access : access_kind) (p : place) (nv : typed_value) + (ctx : eval_ctx) : eval_ctx path_access_result = let access = access_kind_to_projection_access access in (* The update function substitutes the value with the new value *) let update _ = nv in @@ -343,42 +339,42 @@ let try_write_place (access : access_kind) (p : E.place) (nv : V.typed_value) (* We ignore the read value *) Ok ctx -let write_place (access : access_kind) (p : E.place) (nv : V.typed_value) - (ctx : C.eval_ctx) : C.eval_ctx = +let write_place (access : access_kind) (p : place) (nv : typed_value) + (ctx : eval_ctx) : eval_ctx = match try_write_place access p nv ctx with | Error e -> raise (Failure ("Unreachable: " ^ show_path_fail_kind e)) | Ok ctx -> ctx -let compute_expanded_bottom_adt_value (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.generic_args) : V.typed_value = +let compute_expanded_bottom_adt_value (ctx : eval_ctx) (def_id : TypeDeclId.id) + (opt_variant_id : VariantId.id option) (generics : generic_args) : + typed_value = assert (TypesUtils.generic_args_only_erased_regions generics); (* Lookup the definition and check if it is an enumeration - it should be an enumeration if and only if the projection element is a field projection with *some* variant id. Retrieve the list of fields at the same time. *) - let def = C.ctx_lookup_type_decl ctx def_id in - assert (List.length generics.regions = List.length def.T.generics.regions); + let def = ctx_lookup_type_decl ctx def_id in + assert (List.length generics.regions = List.length def.generics.regions); (* Compute the field types *) let field_types = - Assoc.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id generics + AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def opt_variant_id + generics in (* Initialize the expanded value *) let fields = List.map mk_bottom field_types in - let av = V.VAdt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.TAdt (TAdtId def_id, generics) in - { V.value = av; V.ty } + let av = VAdt { variant_id = opt_variant_id; field_values = fields } in + let ty = TAdt (TAdtId def_id, generics) in + { value = av; ty } -let compute_expanded_bottom_tuple_value (field_types : T.ety list) : - V.typed_value = +let compute_expanded_bottom_tuple_value (field_types : ety list) : typed_value = (* Generate the field values *) let fields = List.map mk_bottom field_types in - let v = V.VAdt { variant_id = None; field_values = fields } in + let v = VAdt { variant_id = None; field_values = fields } in let generics = TypesUtils.mk_generic_args [] field_types [] [] in - let ty = T.TAdt (TTuple, generics) in - { V.value = v; V.ty } + let ty = TAdt (TTuple, generics) in + { value = v; ty } -(** Auxiliary helper to expand {!V.Bottom} values. +(** Auxiliary helper to expand {!Bottom} values. During compilation, rustc desaggregates the ADT initializations. The consequence is that the following rust code: @@ -394,19 +390,19 @@ let compute_expanded_bottom_tuple_value (field_types : T.ety list) : ]} The consequence is that we may sometimes need to write fields to values - which are currently {!V.Bottom}. When doing this, we first expand the value + which are currently {!Bottom}. When doing this, we first expand the value to, say, [Cons Bottom Bottom] (note that field projection contains information about which variant we should project to, which is why we *can* set the variant index when writing one of its fields). *) -let expand_bottom_value_from_projection (access : access_kind) (p : E.place) - (remaining_pes : int) (pe : E.projection_elem) (ty : T.ety) - (ctx : C.eval_ctx) : C.eval_ctx = +let expand_bottom_value_from_projection (access : access_kind) (p : place) + (remaining_pes : int) (pe : projection_elem) (ty : ety) (ctx : eval_ctx) : + eval_ctx = (* Debugging *) log#ldebug (lazy ("expand_bottom_value_from_projection:\n" ^ "pe: " - ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); + ^ show_projection_elem pe ^ "\n" ^ "ty: " ^ show_ety ty)); (* Prepare the update: we need to take the proper prefix of the place during whose evaluation we got stuck *) let projection' = @@ -416,41 +412,40 @@ let expand_bottom_value_from_projection (access : access_kind) (p : E.place) in let p' = { p with projection = projection' } in (* Compute the expanded value. - The type of the {!V.Bottom} value should be a tuple or an ADT. + The type of the {!Bottom} value should be a tuple or an AD Note that the projection element we got stuck at should be a - field projection, and gives the variant id if the {!V.Bottom} value + field projection, and gives the variant id if the {!Bottom} value is an enumeration value. Also, the expanded value should be the proper ADT variant or a tuple - with the proper arity, with all the fields initialized to {!V.Bottom} + with the proper arity, with all the fields initialized to {!Bottom} *) let nv = match (pe, ty) with (* "Regular" ADTs *) | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.TAdt (TAdtId def_id', generics) ) -> + TAdt (TAdtId def_id', generics) ) -> assert (def_id = def_id'); compute_expanded_bottom_adt_value ctx def_id opt_variant_id generics (* Tuples *) | ( Field (ProjTuple arity, _), - T.TAdt - ( TTuple, - { T.regions = []; types; const_generics = []; trait_refs = [] } ) ) - -> + TAdt + (TTuple, { regions = []; types; const_generics = []; trait_refs = [] }) + ) -> assert (arity = List.length types); (* Generate the field values *) compute_expanded_bottom_tuple_value types | _ -> raise (Failure - ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty)) + ("Unreachable: " ^ show_projection_elem pe ^ ", " ^ show_ety ty)) in (* Update the context by inserting the expanded value at the proper place *) match try_write_place access p' nv ctx with | Ok ctx -> ctx | Error _ -> raise (Failure "Unreachable") -let rec update_ctx_along_read_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = +let rec update_ctx_along_read_place (config : config) (access : access_kind) + (p : place) : cm_fun = fun cf ctx -> (* Attempt to read the place: if it fails, update the environment and retry *) match try_read_place access p ctx with @@ -471,14 +466,14 @@ let rec update_ctx_along_read_place (config : C.config) (access : access_kind) expand_symbolic_value_no_branching config sp (Some (Synth.mk_mplace prefix ctx)) | FailBottom (_, _, _) -> - (* We can't expand {!V.Bottom} values while reading them *) + (* We can't expand {!Bottom} values while reading them *) raise (Failure "Found [Bottom] while reading a place") | FailBorrow _ -> raise (Failure "Could not read a borrow") in comp cc (update_ctx_along_read_place config access p) cf ctx -let rec update_ctx_along_write_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = +let rec update_ctx_along_write_place (config : config) (access : access_kind) + (p : place) : cm_fun = fun cf ctx -> (* Attempt to *read* (yes, *read*: we check the access to the place, and write to it later) the place: if it fails, update the environment and retry *) @@ -496,7 +491,7 @@ let rec update_ctx_along_write_place (config : C.config) (access : access_kind) expand_symbolic_value_no_branching config sp (Some (Synth.mk_mplace p ctx)) | FailBottom (remaining_pes, pe, ty) -> - (* Expand the {!V.Bottom} value *) + (* Expand the {!Bottom} value *) fun cf ctx -> let ctx = expand_bottom_value_from_projection access p remaining_pes pe ty @@ -511,8 +506,8 @@ let rec update_ctx_along_write_place (config : C.config) (access : access_kind) (** Small utility used to break control-flow *) exception UpdateCtx of cm_fun -let rec end_loans_at_place (config : C.config) (access : access_kind) - (p : E.place) : cm_fun = +let rec end_loans_at_place (config : config) (access : access_kind) (p : place) + : cm_fun = fun cf ctx -> (* Iterator to explore a value and update the context whenever we find * loans. @@ -521,7 +516,7 @@ let rec end_loans_at_place (config : C.config) (access : access_kind) * *) let obj = object - inherit [_] V.iter_typed_value as super + inherit [_] iter_typed_value as super method! visit_borrow_content env bc = match bc with @@ -566,20 +561,20 @@ let rec end_loans_at_place (config : C.config) (access : access_kind) * a recursive call to reinspect the value *) comp cc (end_loans_at_place config access p) cf ctx -let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = +let drop_outer_loans_at_lplace (config : config) (p : place) : cm_fun = fun cf ctx -> (* Move the current value in the place outside of this place and into * a dummy variable *) let access = Write in let v = read_place access p ctx in - let ctx = write_place access p (mk_bottom v.V.ty) ctx in - let dummy_id = C.fresh_dummy_var_id () in - let ctx = C.ctx_push_dummy_var ctx dummy_id v in + let ctx = write_place access p (mk_bottom v.ty) ctx in + let dummy_id = fresh_dummy_var_id () in + let ctx = ctx_push_dummy_var ctx dummy_id v in (* Auxiliary function *) let rec drop : cm_fun = fun cf ctx -> (* Read the value *) - let v = C.ctx_lookup_dummy_var ctx dummy_id in + let v = ctx_lookup_dummy_var ctx dummy_id in (* Check if there are loans or borrows to end *) let with_borrows = false in match get_first_outer_loan_or_borrow_in_value with_borrows v with @@ -603,7 +598,7 @@ let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = let cc = comp cc (fun cf ctx -> (* Pop *) - let ctx, v = C.ctx_remove_dummy_var ctx dummy_id in + let ctx, v = ctx_remove_dummy_var ctx dummy_id in (* Reinsert *) let ctx = write_place access p v ctx in (* Sanity check *) @@ -614,8 +609,8 @@ let drop_outer_loans_at_lplace (config : C.config) (p : E.place) : cm_fun = (* Continue *) cc cf ctx -let prepare_lplace (config : C.config) (p : E.place) - (cf : V.typed_value -> m_fun) : m_fun = +let prepare_lplace (config : config) (p : place) (cf : typed_value -> m_fun) : + m_fun = fun ctx -> log#ldebug (lazy diff --git a/compiler/InterpreterPaths.mli b/compiler/InterpreterPaths.mli index a493ad69..3e29b810 100644 --- a/compiler/InterpreterPaths.mli +++ b/compiler/InterpreterPaths.mli @@ -1,13 +1,8 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module L = Logging +open Types +open Values +open Expressions +open Contexts open Cps -open InterpreterExpansion -module Synth = SynthesizeSymbolic type access_kind = Read | Write | Move @@ -18,13 +13,13 @@ type access_kind = Read | Write | Move updates the environment (by ending borrows, expanding symbolic values, etc.) until it manages to fully access the provided place. *) -val update_ctx_along_read_place : C.config -> access_kind -> E.place -> cm_fun +val update_ctx_along_read_place : config -> access_kind -> place -> cm_fun (** Update the environment to be able to write to a place. See {!update_ctx_along_read_place}. *) -val update_ctx_along_write_place : C.config -> access_kind -> E.place -> cm_fun +val update_ctx_along_write_place : config -> access_kind -> place -> cm_fun (** Read the value at a given place. @@ -34,7 +29,7 @@ val update_ctx_along_write_place : C.config -> access_kind -> E.place -> cm_fun Note that we only access the value at the place, and do not check that the value is "well-formed" (for instance that it doesn't contain bottoms). *) -val read_place : access_kind -> E.place -> C.eval_ctx -> V.typed_value +val read_place : access_kind -> place -> eval_ctx -> typed_value (** Update the value at a given place. @@ -45,26 +40,25 @@ val read_place : access_kind -> E.place -> C.eval_ctx -> V.typed_value the overwritten value contains borrows, loans, etc. and will simply overwrite it. *) -val write_place : - access_kind -> E.place -> V.typed_value -> C.eval_ctx -> C.eval_ctx +val write_place : access_kind -> place -> typed_value -> eval_ctx -> eval_ctx (** Compute an expanded tuple ⊥ value. [compute_expanded_bottom_tuple_value [ty0, ..., tyn]] returns [(⊥:ty0, ..., ⊥:tyn)] *) -val compute_expanded_bottom_tuple_value : T.ety list -> V.typed_value +val compute_expanded_bottom_tuple_value : ety list -> typed_value (** Compute an expanded ADT ⊥ value. The types in the generics should use erased regions. *) val compute_expanded_bottom_adt_value : - C.eval_ctx -> - T.TypeDeclId.id -> - T.VariantId.id option -> - T.generic_args -> - V.typed_value + eval_ctx -> + TypeDeclId.id -> + VariantId.id option -> + generic_args -> + typed_value (** Drop (end) outer loans at a given place, which should be seen as an l-value (we will write to it later, but need to drop the loans before writing). @@ -79,7 +73,7 @@ val compute_expanded_bottom_adt_value : that the place is *inside* a borrow, if we end the borrow, we won't be able to reinsert the value back). *) -val drop_outer_loans_at_lplace : C.config -> E.place -> cm_fun +val drop_outer_loans_at_lplace : config -> place -> cm_fun (** End the loans at a given place: read the value, if it contains a loan, end this loan, repeat. @@ -90,7 +84,7 @@ val drop_outer_loans_at_lplace : C.config -> E.place -> cm_fun when moving values, we can't move a value which contains loans and thus need to end them, etc. *) -val end_loans_at_place : C.config -> access_kind -> E.place -> cm_fun +val end_loans_at_place : config -> access_kind -> place -> cm_fun (** Small utility. @@ -101,4 +95,4 @@ val end_loans_at_place : C.config -> access_kind -> E.place -> cm_fun place. This value should not contain any outer loan (and we check it is the case). Note that this value is very likely to contain ⊥ subvalues. *) -val prepare_lplace : C.config -> E.place -> (V.typed_value -> m_fun) -> m_fun +val prepare_lplace : config -> place -> (typed_value -> m_fun) -> m_fun diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index 8a4b0b4c..4dc53586 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -1,22 +1,19 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts +open Types +open Values +open Contexts module Subst = Substitute module Assoc = AssociatedTypes -module L = Logging open TypesUtils open InterpreterUtils open InterpreterBorrowsCore (** The local logger *) -let log = L.projectors_log +let log = Logging.projectors_log (** [ty] shouldn't contain erased regions *) -let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.Set.t) (v : V.typed_value) (ty : T.rty) : - V.abstract_shared_borrows = +let rec apply_proj_borrows_on_shared_borrow (ctx : eval_ctx) + (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) + (v : typed_value) (ty : rty) : abstract_shared_borrows = (* Sanity check - TODO: move those elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Subst.erase_regions ty in @@ -48,14 +45,14 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) let bid, asb = (* Not in the set: dive *) match (bc, kind) with - | VMutBorrow (bid, bv), Mut -> + | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let asb = apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions bv ref_ty in (bid, asb) - | VSharedBorrow bid, Shared -> + | VSharedBorrow bid, RShared -> (* Lookup the shared value *) let ek = ek_all in let sv = lookup_loan ek bid ctx in @@ -79,33 +76,32 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) * we never project over static regions) *) if region_in_set r regions then let bid' = fresh_reborrow bid in - V.AsbBorrow bid' :: asb + AsbBorrow bid' :: asb else asb in asb | VLoan _, _ -> raise (Failure "Unreachable") | VSymbolic s, _ -> (* Check that the projection doesn't contain ended regions *) - assert ( - not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); - [ V.AsbProjReborrows (s, ty) ] + assert (not (projections_intersect s.sv_ty ctx.ended_regions ty regions)); + [ AsbProjReborrows (s, ty) ] | _ -> raise (Failure "Unreachable") -let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) - (v : V.typed_value) (ty : T.rty) : V.typed_avalue = +let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : eval_ctx) + (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t) + (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) : + typed_avalue = (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) let ety = Substitute.erase_regions ty in - assert (ty_is_rty ty && ety = v.V.ty); + assert (ty_is_rty ty && ety = v.ty); (* Project - if there are no regions from the abstraction in the type, return [_] *) - if not (ty_has_regions_in_set regions ty) then { V.value = V.AIgnored; ty } + if not (ty_has_regions_in_set regions ty) then { value = AIgnored; ty } else - let value : V.avalue = + let value : avalue = match (v.value, ty) with - | VLiteral _, T.TLiteral _ -> V.AIgnored - | VAdt adt, T.TAdt (id, generics) -> + | VLiteral _, TLiteral _ -> AIgnored + | VAdt adt, TAdt (id, generics) -> (* Retrieve the types of the fields *) let field_types = Assoc.ctx_adt_value_get_inst_norm_field_rtypes ctx adt id generics @@ -119,7 +115,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) regions ancestors_regions fv fty) fields_types in - V.AAdt { variant_id = adt.variant_id; field_values = proj_fields } + AAdt { variant_id = adt.variant_id; field_values = proj_fields } | VBottom, _ -> raise (Failure "Unreachable") | VBorrow bc, TRef (r, ref_ty, kind) -> if @@ -130,14 +126,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) (* In the set *) let bc = match (bc, kind) with - | VMutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let bv = apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions bv ref_ty in - V.AMutBorrow (bid, bv) - | VSharedBorrow bid, T.Shared -> + AMutBorrow (bid, bv) + | VSharedBorrow bid, RShared -> (* Rem.: we don't need to also apply the projection on the borrowed value, because for as long as the abstraction lives then the shared borrow lives, which means that the @@ -149,7 +145,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) need to lookup the shared value and project it (see the other branch of the [if then else]). *) - V.ASharedBorrow bid + ASharedBorrow bid | VReservedMutBorrow _, _ -> raise (Failure @@ -157,14 +153,14 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) borrow") | _ -> raise (Failure "Unreachable") in - V.ABorrow bc + ABorrow bc else (* Not in the set: ignore the borrow, but project the borrowed value (maybe some borrows *inside* the borrowed value are in the region set) *) let bc = match (bc, kind) with - | VMutBorrow (bid, bv), T.Mut -> + | VMutBorrow (bid, bv), RMut -> (* Apply the projection on the borrowed value *) let bv = apply_proj_borrows check_symbolic_no_ended ctx @@ -176,8 +172,8 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) if region_in_set r ancestors_regions then Some bid else None in (* Return *) - V.AIgnoredMutBorrow (opt_bid, bv) - | VSharedBorrow bid, T.Shared -> + AIgnoredMutBorrow (opt_bid, bv) + | VSharedBorrow bid, RShared -> (* Lookup the shared value *) let ek = ek_all in let sv = lookup_loan ek bid ctx in @@ -189,7 +185,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) regions sv ref_ty | _ -> raise (Failure "Unexpected") in - V.AProjSharedBorrow asb + AProjSharedBorrow asb | VReservedMutBorrow _, _ -> raise (Failure @@ -197,7 +193,7 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) borrow") | _ -> raise (Failure "Unreachable") in - V.ABorrow bc + ABorrow bc | VLoan _, _ -> raise (Failure "Unreachable") | VSymbolic s, _ -> (* Check that the projection doesn't contain already ended regions, @@ -209,48 +205,48 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) let rset2 = regions in log#ldebug (lazy - ("projections_intersect:" ^ "\n- ty1: " - ^ PA.ty_to_string ctx ty1 ^ "\n- rset1: " - ^ T.RegionId.Set.to_string None rset1 - ^ "\n- ty2: " ^ PA.ty_to_string ctx ty2 ^ "\n- rset2: " - ^ T.RegionId.Set.to_string None rset2 + ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1 + ^ "\n- rset1: " + ^ RegionId.Set.to_string None rset1 + ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: " + ^ RegionId.Set.to_string None rset2 ^ "\n")); assert (not (projections_intersect ty1 rset1 ty2 rset2))); - V.ASymbolic (AProjBorrows (s, ty)) + ASymbolic (AProjBorrows (s, ty)) | _ -> log#lerror (lazy ("apply_proj_borrows: unexpected inputs:\n- input value: " ^ typed_value_to_string ctx v - ^ "\n- proj rty: " ^ PA.ty_to_string ctx ty)); + ^ "\n- proj rty: " ^ ty_to_string ctx ty)); raise (Failure "Unreachable") in { value; ty } -let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = - let ty = Subst.erase_regions sv.V.sv_ty in +let symbolic_expansion_non_borrow_to_value (sv : symbolic_value) + (see : symbolic_expansion) : typed_value = + let ty = Subst.erase_regions sv.sv_ty in let value = match see with - | SeLiteral cv -> V.VLiteral cv + | SeLiteral cv -> VLiteral cv | SeAdt (variant_id, field_values) -> let field_values = List.map mk_typed_value_from_symbolic_value field_values in - V.VAdt { V.variant_id; V.field_values } + VAdt { variant_id; field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic reference expansion") in - { V.value; V.ty } + { value; ty } -let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) - (see : V.symbolic_expansion) : V.typed_value = +let symbolic_expansion_non_shared_borrow_to_value (sv : symbolic_value) + (see : symbolic_expansion) : typed_value = match see with | SeMutRef (bid, bv) -> - let ty = Subst.erase_regions sv.V.sv_ty in + let ty = Subst.erase_regions sv.sv_ty in let bv = mk_typed_value_from_symbolic_value bv in - let value = V.VBorrow (VMutBorrow (bid, bv)) in - { V.value; ty } + let value = VBorrow (VMutBorrow (bid, bv)) in + { value; ty } | SeSharedRef (_, _) -> raise (Failure "Unexpected symbolic shared reference expansion") | _ -> symbolic_expansion_non_borrow_to_value sv see @@ -259,34 +255,34 @@ let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) TODO: detailed comments. See [apply_proj_borrows] *) -let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) - (ancestors_regions : T.RegionId.Set.t) (see : V.symbolic_expansion) - (original_sv_ty : T.rty) : V.typed_avalue = +let apply_proj_loans_on_symbolic_expansion (regions : RegionId.Set.t) + (ancestors_regions : RegionId.Set.t) (see : symbolic_expansion) + (original_sv_ty : rty) : typed_avalue = (* Sanity check: if we have a proj_loans over a symbolic value, it should * contain regions which we will project *) assert (ty_has_regions_in_set regions original_sv_ty); (* Match *) - let (value, ty) : V.avalue * T.ty = + let (value, ty) : avalue * ty = match (see, original_sv_ty) with - | SeLiteral _, T.TLiteral _ -> (V.AIgnored, original_sv_ty) - | SeAdt (variant_id, field_values), T.TAdt (_id, _generics) -> + | SeLiteral _, TLiteral _ -> (AIgnored, original_sv_ty) + | SeAdt (variant_id, field_values), TAdt (_id, _generics) -> (* Project over the field values *) let field_values = List.map (mk_aproj_loans_value_from_symbolic_value regions) field_values in - (V.AAdt { V.variant_id; field_values }, original_sv_ty) - | SeMutRef (bid, spc), TRef (r, ref_ty, T.Mut) -> + (AAdt { variant_id; field_values }, original_sv_ty) + | SeMutRef (bid, spc), TRef (r, ref_ty, RMut) -> (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); + assert (spc.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that * we never project over static regions) *) if region_in_set r regions then (* In the set: keep *) - (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) + (ALoan (AMutLoan (bid, child_av)), ref_ty) else (* Not in the set: ignore *) (* If the borrow id is in the ancestor's regions, we still need @@ -294,10 +290,10 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) let opt_bid = if region_in_set r ancestors_regions then Some bid else None in - (V.ALoan (V.AIgnoredMutLoan (opt_bid, child_av)), ref_ty) - | SeSharedRef (bids, spc), TRef (r, ref_ty, T.Shared) -> + (ALoan (AIgnoredMutLoan (opt_bid, child_av)), ref_ty) + | SeSharedRef (bids, spc), TRef (r, ref_ty, RShared) -> (* Sanity check *) - assert (spc.V.sv_ty = ref_ty); + assert (spc.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in (* Check if the region is in the set of projected regions (note that @@ -305,13 +301,13 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) if region_in_set r regions then (* In the set: keep *) let shared_value = mk_typed_value_from_symbolic_value spc in - (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) + (ALoan (ASharedLoan (bids, shared_value, child_av)), ref_ty) else (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) + (ALoan (AIgnoredSharedLoan child_av), ref_ty) | _ -> raise (Failure "Unreachable") in - { V.value; V.ty } + { value; ty } (** Auxiliary function. See [give_back_value]. @@ -335,8 +331,8 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.Set.t) borrows - easy - and mutable borrows - in this case, we reborrow the whole borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]). *) -let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) - (ctx : C.eval_ctx) : C.eval_ctx = +let apply_reborrows (reborrows : (BorrowId.id * BorrowId.id) list) + (ctx : eval_ctx) : eval_ctx = (* This is a bit brutal, but whenever we insert a reborrow, we remove * it from the list. This allows us to check that all the reborrows were * applied before returning. @@ -345,7 +341,7 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* Check if a value is a mutable borrow, and return its identifier if it is the case *) - let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = + let get_borrow_in_mut_borrow (v : typed_value) : BorrowId.id option = match v.value with | VBorrow lc -> ( match lc with @@ -358,12 +354,12 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) let insert_reborrows bids = (* Find the reborrows to apply *) let insert, reborrows' = - List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows + List.partition (fun (bid, _) -> BorrowId.Set.mem bid bids) !reborrows in reborrows := reborrows'; let insert = List.map snd insert in (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + List.fold_left (fun bids bid -> BorrowId.Set.add bid bids) bids insert in (* Get the list of reborrows for a given borrow id *) @@ -378,8 +374,8 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) let borrows_to_set bids = List.fold_left - (fun bids bid -> V.BorrowId.Set.add bid bids) - V.BorrowId.Set.empty bids + (fun bids bid -> BorrowId.Set.add bid bids) + BorrowId.Set.empty bids in (* Insert reborrows for a given borrow id into a given set of borrows *) @@ -387,12 +383,12 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* Find the reborrows to apply *) let insert = get_reborrows_for_bid bid in (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + List.fold_left (fun bids bid -> BorrowId.Set.add bid bids) bids insert in let obj = object - inherit [_] C.map_eval_ctx as super + inherit [_] map_eval_ctx as super (** We may need to reborrow mutable borrows. Note that this doesn't happen for aborrows *) @@ -407,9 +403,9 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) else (* There are reborrows: insert a shared loan *) let insert = borrows_to_set insert in - let value = V.VLoan (VSharedLoan (insert, nbc)) in + let value = VLoan (VSharedLoan (insert, nbc)) in let ty = v.ty in - { V.value; ty } + { value; ty } | _ -> super#visit_typed_value env v (** We reimplement {!visit_loan_content} (rather than one of the sub- @@ -471,33 +467,33 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) (* Return *) ctx -let prepare_reborrows (config : C.config) (allow_reborrows : bool) : - (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = - let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in +let prepare_reborrows (config : config) (allow_reborrows : bool) : + (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) = + let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) - let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = + let fresh_reborrow (bid : BorrowId.id) : BorrowId.id = if allow_reborrows then ( - let bid' = C.fresh_borrow_id () in + let bid' = fresh_borrow_id () in reborrows := (bid, bid') :: !reborrows; bid') else raise (Failure "Unexpected reborrow") in (* The function to apply the reborrows in a context *) - let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = - match config.C.mode with - | C.ConcreteMode -> + let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx = + match config.mode with + | ConcreteMode -> assert (!reborrows = []); ctx - | C.SymbolicMode -> + | SymbolicMode -> (* Apply the reborrows *) apply_reborrows !reborrows ctx in (fresh_reborrow, apply_registered_reborrows) (** [ty] shouldn't have erased regions *) -let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) - (regions : T.RegionId.Set.t) (ancestors_regions : T.RegionId.Set.t) - (v : V.typed_value) (ty : T.rty) : C.eval_ctx * V.typed_avalue = +let apply_proj_borrows_on_input_value (config : config) (ctx : eval_ctx) + (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t) + (v : typed_value) (ty : rty) : eval_ctx * typed_avalue = assert (ty_is_rty ty); let check_symbolic_no_ended = true in let allow_reborrows = true in diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 7cee9ee7..583c6907 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -1,16 +1,12 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module L = Logging -open InterpreterBorrowsCore +open Types +open Values +open Contexts (** Auxiliary function. Apply a proj_borrows on a shared borrow. Note that when projecting over shared values, we generate - {!type:V.abstract_shared_borrows}, not {!type:V.avalue}s. + {!type:abstract_shared_borrows}, not {!type:avalue}s. Parameters: [regions] @@ -19,15 +15,11 @@ open InterpreterBorrowsCore [original_sv_ty]: shouldn't have erased regions *) val apply_proj_loans_on_symbolic_expansion : - T.RegionId.Set.t -> - T.RegionId.Set.t -> - V.symbolic_expansion -> - T.rty -> - V.typed_avalue + RegionId.Set.t -> RegionId.Set.t -> symbolic_expansion -> rty -> typed_avalue (** Convert a symbolic expansion *which is not a borrow* to a value *) val symbolic_expansion_non_borrow_to_value : - V.symbolic_value -> V.symbolic_expansion -> V.typed_value + symbolic_value -> symbolic_expansion -> typed_value (** Convert a symbolic expansion *which is not a shared borrow* to a value. @@ -36,7 +28,7 @@ val symbolic_expansion_non_borrow_to_value : during a symbolic expansion. *) val symbolic_expansion_non_shared_borrow_to_value : - V.symbolic_value -> V.symbolic_expansion -> V.typed_value + symbolic_value -> symbolic_expansion -> typed_value (** Auxiliary function to prepare reborrowing operations (used when applying projectors). @@ -51,9 +43,7 @@ val symbolic_expansion_non_shared_borrow_to_value : - [allow_reborrows] *) val prepare_reborrows : - C.config -> - bool -> - (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) + config -> bool -> (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) (** Apply (and reduce) a projector over borrows to an avalue. We use this for instance to spread the borrows present in the inputs @@ -107,13 +97,13 @@ val prepare_reborrows : *) val apply_proj_borrows : bool -> - C.eval_ctx -> - (V.BorrowId.id -> V.BorrowId.id) -> - T.RegionId.Set.t -> - T.RegionId.Set.t -> - V.typed_value -> - T.rty -> - V.typed_avalue + eval_ctx -> + (BorrowId.id -> BorrowId.id) -> + RegionId.Set.t -> + RegionId.Set.t -> + typed_value -> + rty -> + typed_avalue (** Parameters: - [config] @@ -125,10 +115,10 @@ val apply_proj_borrows : erased regions) *) val apply_proj_borrows_on_input_value : - C.config -> - C.eval_ctx -> - T.RegionId.Set.t -> - T.RegionId.Set.t -> - V.typed_value -> - T.rty -> - C.eval_ctx * V.typed_avalue + config -> + eval_ctx -> + RegionId.Set.t -> + RegionId.Set.t -> + typed_value -> + rty -> + eval_ctx * typed_avalue diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index b78c2691..88130f21 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1,28 +1,25 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types open TypesUtils +open PrimitiveValues +open Values open ValuesUtils -module Inv = Invariants -module S = SynthesizeSymbolic +open Expressions +open Contexts +open LlbcAst open Cps open InterpreterUtils open InterpreterProjectors open InterpreterExpansion open InterpreterPaths open InterpreterExpressions -module PCtx = Print.EvalCtxLlbcAst +module Subst = Substitute +module S = SynthesizeSymbolic (** The local logger *) let log = L.statements_log (** Drop a value at a given place - TODO: factorize this with [assign_to_place] *) -let drop_value (config : C.config) (p : E.place) : cm_fun = +let drop_value (config : config) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -36,12 +33,12 @@ let drop_value (config : C.config) (p : E.place) : cm_fun = (* Prepare the place (by ending the outer loans *at* the place). *) let cc = comp cc (prepare_lplace config p) in (* Replace the value with {!Bottom} *) - let replace cf (v : V.typed_value) ctx = + let replace cf (v : typed_value) ctx = (* Move the value at destination (that we will overwrite) to a dummy variable * to preserve the borrows it may contain *) let mv = InterpreterPaths.read_place access p ctx in - let dummy_id = C.fresh_dummy_var_id () in - let ctx = C.ctx_push_dummy_var ctx dummy_id mv in + let dummy_id = fresh_dummy_var_id () in + let ctx = ctx_push_dummy_var ctx dummy_id mv in (* Update the destination to ⊥ *) let nv = { v with value = VBottom } in let ctx = write_place access p nv ctx in @@ -55,40 +52,39 @@ let drop_value (config : C.config) (p : E.place) : cm_fun = comp cc replace cf ctx (** Push a dummy variable to the environment *) -let push_dummy_var (vid : C.DummyVarId.id) (v : V.typed_value) : cm_fun = +let push_dummy_var (vid : DummyVarId.id) (v : typed_value) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_dummy_var ctx vid v in + let ctx = ctx_push_dummy_var ctx vid v in cf ctx (** Remove a dummy variable from the environment *) -let remove_dummy_var (vid : C.DummyVarId.id) (cf : V.typed_value -> m_fun) : - m_fun = +let remove_dummy_var (vid : DummyVarId.id) (cf : typed_value -> m_fun) : m_fun = fun ctx -> - let ctx, v = C.ctx_remove_dummy_var ctx vid in + let ctx, v = ctx_remove_dummy_var ctx vid in cf v ctx (** Push an uninitialized variable to the environment *) -let push_uninitialized_var (var : A.var) : cm_fun = +let push_uninitialized_var (var : var) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_uninitialized_var ctx var in + let ctx = ctx_push_uninitialized_var ctx var in cf ctx (** Push a list of uninitialized variables to the environment *) -let push_uninitialized_vars (vars : A.var list) : cm_fun = +let push_uninitialized_vars (vars : var list) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_uninitialized_vars ctx vars in + let ctx = ctx_push_uninitialized_vars ctx vars in cf ctx (** Push a variable to the environment *) -let push_var (var : A.var) (v : V.typed_value) : cm_fun = +let push_var (var : var) (v : typed_value) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_var ctx var v in + let ctx = ctx_push_var ctx var v in cf ctx (** Push a list of variables to the environment *) -let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = +let push_vars (vars : (var * typed_value) list) : cm_fun = fun cf ctx -> - let ctx = C.ctx_push_vars ctx vars in + let ctx = ctx_push_vars ctx vars in cf ctx (** Assign a value to a given place. @@ -98,8 +94,7 @@ let push_vars (vars : (A.var * V.typed_value) list) : cm_fun = dummy variable and putting in its destination (after having checked that preparing the destination didn't introduce ⊥). *) -let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : - cm_fun = +let assign_to_place (config : config) (rv : typed_value) (p : place) : cm_fun = fun cf ctx -> log#ldebug (lazy @@ -108,20 +103,20 @@ let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : ^ "\n- p: " ^ place_to_string ctx p ^ "\n- Initial context:\n" ^ eval_ctx_to_string ctx)); (* Push the rvalue to a dummy variable, for bookkeeping *) - let rvalue_vid = C.fresh_dummy_var_id () in + let rvalue_vid = fresh_dummy_var_id () in let cc = push_dummy_var rvalue_vid rv in (* Prepare the destination *) let cc = comp cc (prepare_lplace config p) in (* Retrieve the rvalue from the dummy variable *) let cc = comp cc (fun cf _lv -> remove_dummy_var rvalue_vid cf) in (* Update the destination *) - let move_dest cf (rv : V.typed_value) : m_fun = + let move_dest cf (rv : typed_value) : m_fun = fun ctx -> (* Move the value at destination (that we will overwrite) to a dummy variable * to preserve the borrows *) let mv = InterpreterPaths.read_place Write p ctx in - let dest_vid = C.fresh_dummy_var_id () in - let ctx = C.ctx_push_dummy_var ctx dest_vid mv in + let dest_vid = fresh_dummy_var_id () in + let ctx = ctx_push_dummy_var ctx dest_vid mv in (* Write to the destination *) (* Checks - maybe the bookkeeping updated the rvalue and introduced bottoms *) assert (not (bottom_in_value ctx.ended_regions rv)); @@ -141,12 +136,12 @@ let assign_to_place (config : C.config) (rv : V.typed_value) (p : E.place) : comp cc move_dest cf ctx (** Evaluate an assertion, when the scrutinee is not symbolic *) -let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : +let eval_assertion_concrete (config : config) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* There won't be any symbolic expansions: fully evaluate the operand *) let eval_op = eval_operand config assertion.cond in - let eval_assert cf (v : V.typed_value) : m_fun = + let eval_assert cf (v : typed_value) : m_fun = fun ctx -> match v.value with | VLiteral (VBool b) -> @@ -165,12 +160,12 @@ let eval_assertion_concrete (config : C.config) (assertion : A.assertion) : a call to [assert ...] then continue in the success branch (and thus expand the boolean to [true]). *) -let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = +let eval_assertion (config : config) (assertion : assertion) : st_cm_fun = fun cf ctx -> (* Evaluate the operand *) let eval_op = eval_operand config assertion.cond in (* Evaluate the assertion *) - let eval_assert cf (v : V.typed_value) : m_fun = + let eval_assert cf (v : typed_value) : m_fun = fun ctx -> assert (v.ty = TLiteral TBool); (* We make a choice here: we could completely decouple the concrete and @@ -210,26 +205,26 @@ let eval_assertion (config : C.config) (assertion : A.assertion) : st_cm_fun = - either the discriminant is already the proper one (in which case we don't do anything) - or it is not the proper one (because the variant is not the proper - one, or the value is actually {!V.Bottom} - this happens when + one, or the value is actually {!Bottom} - this happens when initializing ADT values), in which case we replace the value with - a variant with all its fields set to {!V.Bottom}. + a variant with all its fields set to {!Bottom}. For instance, something like: [Cons Bottom Bottom]. *) -let set_discriminant (config : C.config) (p : E.place) - (variant_id : T.VariantId.id) : st_cm_fun = +let set_discriminant (config : config) (p : place) (variant_id : VariantId.id) : + st_cm_fun = fun cf ctx -> log#ldebug (lazy ("set_discriminant:" ^ "\n- p: " ^ place_to_string ctx p ^ "\n- variant id: " - ^ T.VariantId.to_string variant_id + ^ VariantId.to_string variant_id ^ "\n- initial context:\n" ^ eval_ctx_to_string ctx)); (* Access the value *) let access = Write in let cc = update_ctx_along_read_place config access p in let cc = comp cc (prepare_lplace config p) in (* Update the value *) - let update_value cf (v : V.typed_value) : m_fun = + let update_value cf (v : typed_value) : m_fun = fun ctx -> match (v.ty, v.value) with | TAdt ((TAdtId _ as type_id), generics), VAdt av -> ( @@ -281,7 +276,7 @@ let set_discriminant (config : C.config) (p : E.place) comp cc update_value cf ctx (** Push a frame delimiter in the context's environment *) -let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = +let ctx_push_frame (ctx : eval_ctx) : eval_ctx = { ctx with env = EFrame :: ctx.env } (** Push a frame delimiter in the context's environment *) @@ -290,8 +285,8 @@ let push_frame : cm_fun = fun cf ctx -> cf (ctx_push_frame ctx) (** Small helper: compute the type of the return value for a specific instantiation of an assumed function. *) -let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) - (generics : T.generic_args) : T.ety = +let get_assumed_function_return_type (ctx : eval_ctx) (fid : assumed_fun_id) + (generics : generic_args) : ety = assert (generics.trait_refs = []); (* [Box::free] has a special treatment *) match fid with @@ -305,7 +300,7 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) let sg = Assumed.get_assumed_fun_sig fid in (* Instantiate the return type *) (* There shouldn't be any reference to Self *) - let tr_self : T.trait_instance_id = T.UnknownTrait __FUNCTION__ in + let tr_self : trait_instance_id = UnknownTrait __FUNCTION__ in let generics = Subst.generic_args_erase_regions generics in let { Subst.r_subst = _; ty_subst; cg_subst; tr_subst; tr_self } = Subst.make_subst_from_generics sg.generics generics tr_self @@ -314,41 +309,41 @@ let get_assumed_function_return_type (ctx : C.eval_ctx) (fid : A.assumed_fun_id) Subst.erase_regions_substitute_types ty_subst cg_subst tr_subst tr_self sg.output in - Assoc.ctx_normalize_erase_ty ctx ty + AssociatedTypes.ctx_normalize_erase_ty ctx ty -let move_return_value (config : C.config) (pop_return_value : bool) - (cf : V.typed_value option -> m_fun) : m_fun = +let move_return_value (config : config) (pop_return_value : bool) + (cf : typed_value option -> m_fun) : m_fun = fun ctx -> if pop_return_value then - let ret_vid = E.VarId.zero in - let cc = eval_operand config (E.Move (mk_place_from_var_id ret_vid)) in + let ret_vid = VarId.zero in + let cc = eval_operand config (Move (mk_place_from_var_id ret_vid)) in cc (fun v ctx -> cf (Some v) ctx) ctx else cf None ctx -let pop_frame (config : C.config) (pop_return_value : bool) - (cf : V.typed_value option -> m_fun) : m_fun = +let pop_frame (config : config) (pop_return_value : bool) + (cf : typed_value option -> m_fun) : m_fun = fun ctx -> (* Debug *) log#ldebug (lazy ("pop_frame:\n" ^ eval_ctx_to_string ctx)); (* List the local variables, but the return variable *) - let ret_vid = E.VarId.zero in + let ret_vid = VarId.zero in let rec list_locals env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.EAbs _ :: env -> list_locals env - | C.EBinding (BDummy _, _) :: env -> list_locals env - | C.EBinding (BVar var, _) :: env -> + | EAbs _ :: env -> list_locals env + | EBinding (BDummy _, _) :: env -> list_locals env + | EBinding (BVar var, _) :: env -> let locals = list_locals env in if var.index <> ret_vid then var.index :: locals else locals - | C.EFrame :: _ -> [] + | EFrame :: _ -> [] in - let locals : E.VarId.id list = list_locals ctx.env in + let locals : VarId.id list = list_locals ctx.env in (* Debug *) log#ldebug (lazy ("pop_frame: locals in which to drop the outer loans: [" - ^ String.concat "," (List.map E.VarId.to_string locals) + ^ String.concat "," (List.map VarId.to_string locals) ^ "]")); (* Move the return value out of the return variable *) @@ -363,7 +358,7 @@ let pop_frame (config : C.config) (pop_return_value : bool) in (* Drop the outer *loans* we find in the local variables *) - let cf_drop_loans_in_locals cf (ret_value : V.typed_value option) : m_fun = + let cf_drop_loans_in_locals cf (ret_value : typed_value option) : m_fun = (* Drop the loans *) let locals = List.rev locals in let cf_drop = @@ -391,13 +386,13 @@ let pop_frame (config : C.config) (pop_return_value : bool) let rec pop env = match env with | [] -> raise (Failure "Inconsistent environment") - | C.EAbs abs :: env -> C.EAbs abs :: pop env - | C.EBinding (_, v) :: env -> - let vid = C.fresh_dummy_var_id () in - C.EBinding (C.BDummy vid, v) :: pop env - | C.EFrame :: env -> (* Stop here *) env + | EAbs abs :: env -> EAbs abs :: pop env + | EBinding (_, v) :: env -> + let vid = fresh_dummy_var_id () in + EBinding (BDummy vid, v) :: pop env + | EFrame :: env -> (* Stop here *) env in - let cf_pop cf (ret_value : V.typed_value option) : m_fun = + let cf_pop cf (ret_value : typed_value option) : m_fun = fun ctx -> let env = pop ctx.env in let ctx = { ctx with env } in @@ -407,7 +402,7 @@ let pop_frame (config : C.config) (pop_return_value : bool) comp cc cf_pop cf ctx (** Pop the current frame and assign the returned value to its destination. *) -let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = +let pop_frame_assign (config : config) (dest : place) : cm_fun = let cf_pop = pop_frame config true in let cf_assign cf ret_value : m_fun = assign_to_place config (Option.get ret_value) dest cf @@ -415,8 +410,7 @@ let pop_frame_assign (config : C.config) (dest : E.place) : cm_fun = comp cf_pop cf_assign (** Auxiliary function - see {!eval_assumed_function_call} *) -let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : - cm_fun = +let eval_box_new_concrete (config : config) (generics : generic_args) : cm_fun = fun cf ctx -> (* Check and retrieve the arguments *) match @@ -427,27 +421,27 @@ let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : [], EBinding (BVar input_var, input_value) :: EBinding (_ret_var, _) - :: C.EFrame :: _ ) -> + :: EFrame :: _ ) -> (* Required type checking *) - assert (input_value.V.ty = boxed_ty); + assert (input_value.ty = boxed_ty); (* Move the input value *) let cf_move = - eval_operand config (E.Move (mk_place_from_var_id input_var.C.index)) + eval_operand config (Move (mk_place_from_var_id input_var.index)) in (* Create the new box *) - let cf_create cf (moved_input_value : V.typed_value) : m_fun = + let cf_create cf (moved_input_value : typed_value) : m_fun = (* Create the box value *) let generics = TypesUtils.mk_generic_args_from_types [ boxed_ty ] in - let box_ty = T.TAdt (T.TAssumed T.TBox, generics) in + let box_ty = TAdt (TAssumed TBox, generics) in let box_v = - V.VAdt { variant_id = None; field_values = [ moved_input_value ] } + VAdt { variant_id = None; field_values = [ moved_input_value ] } in let box_v = mk_typed_value box_ty box_v in (* Move this value to the return variable *) - let dest = mk_place_from_var_id E.VarId.zero in + let dest = mk_place_from_var_id VarId.zero in let cf_assign = assign_to_place config box_v dest in (* Continue *) @@ -477,14 +471,14 @@ let eval_box_new_concrete (config : C.config) (generics : T.generic_args) : It thus updates the box value (by calling {!drop_value}) and updates the destination (by setting it to [()]). *) -let eval_box_free (config : C.config) (generics : T.generic_args) - (args : E.operand list) (dest : E.place) : cm_fun = +let eval_box_free (config : config) (generics : generic_args) + (args : operand list) (dest : place) : cm_fun = fun cf ctx -> match (generics.regions, generics.types, generics.const_generics, args) with - | [], [ boxed_ty ], [], [ E.Move input_box_place ] -> + | [], [ boxed_ty ], [], [ Move input_box_place ] -> (* Required type checking *) let input_box = InterpreterPaths.read_place Write input_box_place ctx in - (let input_ty = ty_get_box input_box.V.ty in + (let input_ty = ty_get_box input_box.ty in assert (input_ty = boxed_ty)); (* Drop the value *) @@ -498,8 +492,8 @@ let eval_box_free (config : C.config) (generics : T.generic_args) | _ -> raise (Failure "Inconsistent state") (** Evaluate a non-local function call in concrete mode *) -let eval_assumed_function_call_concrete (config : C.config) - (fid : A.assumed_fun_id) (call : A.call) : cm_fun = +let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) + (call : call) : cm_fun = let generics = call.func.generics in let args = call.args in let dest = call.dest in @@ -528,22 +522,22 @@ let eval_assumed_function_call_concrete (config : C.config) * below, without having to introduce an intermediary function call, * but it made it less clear where the computed values came from, * so we reversed the modifications. *) - let cf_eval_call cf (args_vl : V.typed_value list) : m_fun = + let cf_eval_call cf (args_vl : typed_value list) : m_fun = fun ctx -> (* Push the stack frame: we initialize the frame with the return variable, and one variable per input argument *) let cc = push_frame in (* Create and push the return variable *) - let ret_vid = E.VarId.zero in + let ret_vid = VarId.zero in let ret_ty = get_assumed_function_return_type ctx fid generics in let ret_var = mk_var ret_vid (Some "@return") ret_ty in let cc = comp cc (push_uninitialized_var ret_var) in (* Create and push the input variables *) let input_vars = - E.VarId.mapi_from1 - (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) + VarId.mapi_from1 + (fun id (v : typed_value) -> (mk_var id None v.ty, v)) args_vl in let cc = comp cc (push_vars input_vars) in @@ -557,8 +551,7 @@ let eval_assumed_function_call_concrete (config : C.config) | BoxFree -> (* Should have been treated above *) raise (Failure "Unreachable") | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared - | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut - | SliceLen -> + | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut -> raise (Failure "Unimplemented") in @@ -582,49 +575,48 @@ let eval_assumed_function_call_concrete (config : C.config) which can end or not. *) let create_empty_abstractions_from_abs_region_groups - (kind : T.RegionGroupId.id -> V.abs_kind) (rgl : A.abs_region_group list) - (region_can_end : T.RegionGroupId.id -> bool) : V.abs list = + (kind : RegionGroupId.id -> abs_kind) (rgl : abs_region_group list) + (region_can_end : RegionGroupId.id -> bool) : abs list = (* We use a reference to progressively create a map from abstraction ids * to set of ancestor regions. Note that {!abs_to_ancestors_regions} [abs_id] * returns the union of: * - the regions of the ancestors of abs_id * - the regions of abs_id *) - let abs_to_ancestors_regions : T.RegionId.Set.t V.AbstractionId.Map.t ref = - ref V.AbstractionId.Map.empty + let abs_to_ancestors_regions : RegionId.Set.t AbstractionId.Map.t ref = + ref AbstractionId.Map.empty in (* Auxiliary function to create one abstraction *) - let create_abs (rg_id : T.RegionGroupId.id) (rg : A.abs_region_group) : V.abs - = - let abs_id = rg.T.id in + let create_abs (rg_id : RegionGroupId.id) (rg : abs_region_group) : abs = + let abs_id = rg.id in let original_parents = rg.parents in let parents = List.fold_left - (fun s pid -> V.AbstractionId.Set.add pid s) - V.AbstractionId.Set.empty rg.parents + (fun s pid -> AbstractionId.Set.add pid s) + AbstractionId.Set.empty rg.parents in let regions = List.fold_left - (fun s rid -> T.RegionId.Set.add rid s) - T.RegionId.Set.empty rg.regions + (fun s rid -> RegionId.Set.add rid s) + RegionId.Set.empty rg.regions in let ancestors_regions = List.fold_left (fun acc parent_id -> - T.RegionId.Set.union acc - (V.AbstractionId.Map.find parent_id !abs_to_ancestors_regions)) - T.RegionId.Set.empty rg.parents + RegionId.Set.union acc + (AbstractionId.Map.find parent_id !abs_to_ancestors_regions)) + RegionId.Set.empty rg.parents in let ancestors_regions_union_current_regions = - T.RegionId.Set.union ancestors_regions regions + RegionId.Set.union ancestors_regions regions in let can_end = region_can_end rg_id in abs_to_ancestors_regions := - V.AbstractionId.Map.add abs_id ancestors_regions_union_current_regions + AbstractionId.Map.add abs_id ancestors_regions_union_current_regions !abs_to_ancestors_regions; (* Create the abstraction *) { - V.abs_id; + abs_id; kind = kind rg_id; can_end; parents; @@ -635,14 +627,13 @@ let create_empty_abstractions_from_abs_region_groups } in (* Apply *) - T.RegionGroupId.mapi create_abs rgl + RegionGroupId.mapi create_abs rgl let create_push_abstractions_from_abs_region_groups - (kind : T.RegionGroupId.id -> V.abs_kind) (rgl : A.abs_region_group list) - (region_can_end : T.RegionGroupId.id -> bool) - (compute_abs_avalues : - V.abs -> C.eval_ctx -> C.eval_ctx * V.typed_avalue list) - (ctx : C.eval_ctx) : C.eval_ctx = + (kind : RegionGroupId.id -> abs_kind) (rgl : abs_region_group list) + (region_can_end : RegionGroupId.id -> bool) + (compute_abs_avalues : abs -> eval_ctx -> eval_ctx * typed_avalue list) + (ctx : eval_ctx) : eval_ctx = (* Initialize the abstractions as empty (i.e., with no avalues) abstractions *) let empty_absl = create_empty_abstractions_from_abs_region_groups kind rgl region_can_end @@ -650,7 +641,7 @@ let create_push_abstractions_from_abs_region_groups (* Compute and add the avalues to the abstractions, the insert the abstractions * in the context. *) - let insert_abs (ctx : C.eval_ctx) (abs : V.abs) : C.eval_ctx = + let insert_abs (ctx : eval_ctx) (abs : abs) : eval_ctx = (* Compute the values to insert in the abstraction *) let ctx, avalues = compute_abs_avalues abs ctx in (* Add the avalues to the abstraction *) @@ -663,7 +654,7 @@ let create_push_abstractions_from_abs_region_groups List.fold_left insert_abs ctx empty_absl (** Evaluate a statement *) -let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = +let rec eval_statement (config : config) (st : statement) : st_cm_fun = fun cf ctx -> (* Debugging *) log#ldebug @@ -676,23 +667,23 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config in (* Sanity check *) - let cc = comp cc Inv.cf_check_invariants in + let cc = comp cc Invariants.cf_check_invariants in (* Evaluate *) let cf_eval_st cf : m_fun = fun ctx -> match st.content with - | A.Assign (p, rvalue) -> ( + | Assign (p, rvalue) -> ( (* We handle global assignments separately *) match rvalue with - | E.Global gid -> + | Global gid -> (* Evaluate the global *) eval_global config p gid cf ctx | _ -> (* Evaluate the rvalue *) let cf_eval_rvalue = eval_rvalue_not_global config rvalue in (* Assign *) - let cf_assign cf (res : (V.typed_value, eval_error) result) ctx = + let cf_assign cf (res : (typed_value, eval_error) result) ctx = log#ldebug (lazy ("about to assign to place: " ^ place_to_string ctx p @@ -706,11 +697,10 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = * also it can lead to issues - for instance, if we borrow a * reserved borrow, we later can't translate it to pure values...) *) match rvalue with - | E.Global _ -> raise (Failure "Unreachable") - | E.Use _ - | E.RvRef (_, (E.Shared | E.Mut | E.TwoPhaseMut | E.Shallow)) - | E.UnaryOp _ | E.BinaryOp _ | E.Discriminant _ - | E.Aggregate _ -> + | Global _ -> raise (Failure "Unreachable") + | Use _ + | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) + | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> let rp = rvalue_get_place rvalue in let rp = match rp with @@ -723,18 +713,18 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx) - | A.FakeRead p -> eval_fake_read config p (cf Unit) ctx - | A.SetDiscriminant (p, variant_id) -> + | FakeRead p -> eval_fake_read config p (cf Unit) ctx + | SetDiscriminant (p, variant_id) -> set_discriminant config p variant_id cf ctx - | A.Drop p -> drop_value config p (cf Unit) ctx - | A.Assert assertion -> eval_assertion config assertion cf ctx - | A.Call call -> eval_function_call config call cf ctx - | A.Panic -> cf Panic ctx - | A.Return -> cf Return ctx - | A.Break i -> cf (Break i) ctx - | A.Continue i -> cf (Continue i) ctx - | A.Nop -> cf Unit ctx - | A.Sequence (st1, st2) -> + | Drop p -> drop_value config p (cf Unit) ctx + | Assert assertion -> eval_assertion config assertion cf ctx + | Call call -> eval_function_call config call cf ctx + | Panic -> cf Panic ctx + | Return -> cf Return ctx + | Break i -> cf (Break i) ctx + | Continue i -> cf (Continue i) ctx + | Nop -> cf Unit ctx + | Sequence (st1, st2) -> (* Evaluate the first statement *) let cf_st1 = eval_statement config st1 in (* Evaluate the sequence *) @@ -749,37 +739,36 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = in (* Compose and apply *) comp cf_st1 cf_st2 cf ctx - | A.Loop loop_body -> + | Loop loop_body -> InterpreterLoops.eval_loop config (eval_statement config loop_body) cf ctx - | A.Switch switch -> eval_switch config switch cf ctx + | Switch switch -> eval_switch config switch cf ctx in (* Compose and apply *) comp cc cf_eval_st cf ctx -and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) - : st_cm_fun = +and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) : + st_cm_fun = fun cf ctx -> - let global = C.ctx_lookup_global_decl ctx gid in + let global = ctx_lookup_global_decl ctx gid in match config.mode with | ConcreteMode -> (* Treat the evaluation of the global as a call to the global body (without arguments) *) let func = { - E.func = FunId (FRegular global.body_id); - generics = TypesUtils.mk_empty_generic_args; + func = FunId (FRegular global.body); + generics = TypesUtils.empty_generic_args; trait_and_method_generic_args = None; } in - let call = { A.func; args = []; dest } in - (eval_transparent_function_call_concrete config global.body_id call) - cf ctx + let call = { func; args = []; dest } in + (eval_transparent_function_call_concrete config global.body call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be * defined as equal to the value of the global (see {!S.synthesize_global_eval}). *) assert (ty_no_regions global.ty); - let sval = mk_fresh_symbolic_value V.Global global.ty in + let sval = mk_fresh_symbolic_value Global global.ty in let cc = assign_to_place config (mk_typed_value_from_symbolic_value sval) dest in @@ -787,7 +776,7 @@ and eval_global (config : C.config) (dest : E.place) (gid : LA.GlobalDeclId.id) S.synthesize_global_eval gid sval e (** Evaluate a switch *) -and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = +and eval_switch (config : config) (switch : switch) : st_cm_fun = fun cf ctx -> (* We evaluate the operand in two steps: * first we prepare it, then we check if its value is concrete or @@ -801,14 +790,14 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = let cf_match : st_cm_fun = fun cf ctx -> match switch with - | A.If (op, st1, st2) -> + | If (op, st1, st2) -> (* Evaluate the operand *) let cf_eval_op = eval_operand config op in (* Switch on the value *) - let cf_if (cf : st_m_fun) (op_v : V.typed_value) : m_fun = + let cf_if (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> match op_v.value with - | V.VLiteral (PV.VBool b) -> + | VLiteral (VBool b) -> (* Evaluate the if and the branch body *) let cf_branch cf : m_fun = (* Branch *) @@ -829,18 +818,18 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = in (* Compose *) comp cf_eval_op cf_if cf ctx - | A.SwitchInt (op, int_ty, stgts, otherwise) -> + | SwitchInt (op, int_ty, stgts, otherwise) -> (* Evaluate the operand *) let cf_eval_op = eval_operand config op in (* Switch on the value *) - let cf_switch (cf : st_m_fun) (op_v : V.typed_value) : m_fun = + let cf_switch (cf : st_m_fun) (op_v : typed_value) : m_fun = fun ctx -> match op_v.value with - | V.VLiteral (PV.VScalar sv) -> + | VLiteral (VScalar sv) -> (* Evaluate the branch *) let cf_eval_branch cf = (* Sanity check *) - assert (sv.PV.int_ty = int_ty); + assert (sv.int_ty = int_ty); (* Find the branch *) match List.find_opt (fun (svl, _) -> List.mem sv svl) stgts with | None -> eval_statement config otherwise cf @@ -876,7 +865,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = in (* Compose *) comp cf_eval_op cf_switch cf ctx - | A.Match (p, stgts, otherwise) -> + | Match (p, stgts, otherwise) -> (* Access the place *) let access = Read in let expand_prim_copy = false in @@ -884,7 +873,7 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = access_rplace_reorganize_and_read config expand_prim_copy access p cf in (* Match on the value *) - let cf_match (cf : st_m_fun) (p_v : V.typed_value) : m_fun = + let cf_match (cf : st_m_fun) (p_v : typed_value) : m_fun = fun ctx -> (* The value may be shared: we need to ignore the shared loans to read the value itself *) @@ -915,18 +904,17 @@ and eval_switch (config : C.config) (switch : A.switch) : st_cm_fun = cf_match cf ctx (** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = +and eval_function_call (config : config) (call : call) : st_cm_fun = (* There are several cases: - this is a local function, in which case we execute its body - this is an assumed function, in which case there is a special treatment - this is a trait method *) match config.mode with - | C.ConcreteMode -> eval_function_call_concrete config call - | C.SymbolicMode -> eval_function_call_symbolic config call + | ConcreteMode -> eval_function_call_concrete config call + | SymbolicMode -> eval_function_call_symbolic config call -and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun - = +and eval_function_call_concrete (config : config) (call : call) : st_cm_fun = fun cf ctx -> match call.func.func with | FunId (FRegular fid) -> @@ -939,25 +927,24 @@ and eval_function_call_concrete (config : C.config) (call : A.call) : st_cm_fun eval_assumed_function_call_concrete config fid call (cf Unit) ctx | TraitMethod _ -> raise (Failure "Unimplemented") -and eval_function_call_symbolic (config : C.config) (call : A.call) : st_cm_fun - = +and eval_function_call_symbolic (config : config) (call : call) : st_cm_fun = match call.func.func with | FunId (FRegular _) | TraitMethod _ -> eval_transparent_function_call_symbolic config call | FunId (FAssumed fid) -> eval_assumed_function_call_symbolic config fid call (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_transparent_function_call_concrete (config : C.config) - (fid : A.FunDeclId.id) (call : A.call) : st_cm_fun = +and eval_transparent_function_call_concrete (config : config) + (fid : FunDeclId.id) (call : call) : st_cm_fun = let generics = call.func.generics in - let args = call.A.args in - let dest = call.A.dest in + let args = call.args in + let dest = call.dest in (* Sanity check: we don't fully handle the const generic vars environment in concrete mode yet *) assert (generics.const_generics = []); fun cf ctx -> (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_decl ctx fid in + let def = ctx_lookup_fun_decl ctx fid in (* We can evaluate the function call only if it is not opaque *) let body = match def.body with @@ -965,20 +952,20 @@ and eval_transparent_function_call_concrete (config : C.config) raise (Failure ("Can't evaluate a call to an opaque function: " - ^ Print.name_to_string def.name)) + ^ name_to_string ctx def.name)) | Some body -> body in (* TODO: we need to normalize the types if we want to correctly support traits *) assert (generics.trait_refs = []); (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in + let tr_self = UnknownTrait __FUNCTION__ in let subst = - Subst.make_subst_from_generics def.A.signature.generics generics tr_self + Subst.make_subst_from_generics def.signature.generics generics tr_self in let locals, body_st = Subst.fun_body_substitute_in_body subst body in (* Evaluate the input operands *) - assert (List.length args = body.A.arg_count); + assert (List.length args = body.arg_count); let cc = eval_operands config args in (* Push a frame delimiter - we use {!comp_transmit} to transmit the result @@ -994,7 +981,7 @@ and eval_transparent_function_call_concrete (config : C.config) | _ -> raise (Failure "Unreachable") in let input_locals, locals = - Collections.List.split_at locals body.A.arg_count + Collections.List.split_at locals body.arg_count in let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) in @@ -1032,8 +1019,8 @@ and eval_transparent_function_call_concrete (config : C.config) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) - : st_cm_fun = +and eval_transparent_function_call_symbolic (config : config) (call : call) : + st_cm_fun = fun cf ctx -> (* Instantiate the signature and introduce fresh abstractions and region ids while doing so. @@ -1105,21 +1092,21 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) let func, generics, def, inst_sg = match call.func.func with | FunId (FRegular fid) -> - let def = C.ctx_lookup_fun_decl ctx fid in + let def = ctx_lookup_fun_decl ctx fid in log#ldebug (lazy ("fun call:\n- call: " ^ call_to_string ctx call ^ "\n- call.generics:\n" - ^ PA.generic_args_to_string ctx call.func.generics + ^ generic_args_to_string ctx call.func.generics ^ "\n- def.signature:\n" - ^ fun_sig_to_string ctx def.A.signature)); - let tr_self = T.UnknownTrait __FUNCTION__ in + ^ fun_sig_to_string ctx def.signature)); + let tr_self = UnknownTrait __FUNCTION__ in let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FRegular fid) ctx.fun_context.regions_hierarchies in let inst_sg = - instantiate_fun_sig ctx call.func.generics tr_self def.A.signature + instantiate_fun_sig ctx call.func.generics tr_self def.signature regions_hierarchy in (call.func.func, call.func.generics, def, inst_sg) @@ -1131,9 +1118,9 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("trait method call:\n- call: " ^ call_to_string ctx call ^ "\n- method name: " ^ method_name ^ "\n- call.generics:\n" - ^ PA.generic_args_to_string ctx call.func.generics + ^ generic_args_to_string ctx call.func.generics ^ "\n- trait and method generics:\n" - ^ PA.generic_args_to_string ctx + ^ generic_args_to_string ctx (Option.get call.func.trait_and_method_generic_args))); (* When instantiating, we need to group the generics for the trait ref and the method *) @@ -1144,7 +1131,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) match trait_ref.trait_id with | TraitImpl impl_id -> ( (* Lookup the trait impl *) - let trait_impl = C.ctx_lookup_trait_impl ctx impl_id in + let trait_impl = ctx_lookup_trait_impl ctx impl_id in log#ldebug (lazy ("trait impl: " ^ trait_impl_to_string ctx trait_impl)); (* First look in the required methods *) @@ -1156,17 +1143,17 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) match method_id with | Some (_, id) -> (* This is a required method *) - let method_def = C.ctx_lookup_fun_decl ctx id in + let method_def = ctx_lookup_fun_decl ctx id in (* Instantiate *) - let tr_self = T.TraitRef trait_ref in - let fid : A.fun_id = FRegular id in + let tr_self = TraitRef trait_ref in + let fid : fun_id = FRegular id in let regions_hierarchy = LlbcAstUtils.FunIdMap.find fid ctx.fun_context.regions_hierarchies in let inst_sg = - instantiate_fun_sig ctx generics tr_self - method_def.A.signature regions_hierarchy + instantiate_fun_sig ctx generics tr_self method_def.signature + regions_hierarchy in (* Also update the function identifier: we want to forget the fact that we called a trait method, and treat it as @@ -1174,14 +1161,14 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) which implements the method. In order to do this properly, we also need to update the generics. *) - let func = E.FunId fid in + let func = FunId fid in (func, generics, method_def, inst_sg) | None -> (* If not found, lookup the methods provided by the trait *declaration* (remember: for now, we forbid overriding provided methods) *) assert (trait_impl.provided_methods = []); let trait_decl = - C.ctx_lookup_trait_decl ctx + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in let _, method_id = @@ -1190,7 +1177,7 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) trait_decl.provided_methods in let method_id = Option.get method_id in - let method_def = C.ctx_lookup_fun_decl ctx method_id in + let method_def = ctx_lookup_fun_decl ctx method_id in (* For the instantiation we have to do something peculiar because the method was defined for the trait declaration. We have to group: @@ -1216,24 +1203,24 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (lazy ("provided method call:" ^ "\n- method name: " ^ method_name ^ "\n- all_generics:\n" - ^ PA.generic_args_to_string ctx all_generics + ^ generic_args_to_string ctx all_generics ^ "\n- parent params info: " - ^ Print.option_to_string A.show_params_info + ^ Print.option_to_string show_params_info method_def.signature.parent_params_info)); let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FRegular method_id) ctx.fun_context.regions_hierarchies in - let tr_self = T.TraitRef trait_ref in + let tr_self = TraitRef trait_ref in let inst_sg = instantiate_fun_sig ctx all_generics tr_self - method_def.A.signature regions_hierarchy + method_def.signature regions_hierarchy in (call.func.func, call.func.generics, method_def, inst_sg)) | _ -> (* We are using a local clause - we lookup the trait decl *) let trait_decl = - C.ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id in (* Lookup the method decl in the required *and* the provided methods *) let _, method_id = @@ -1247,22 +1234,22 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) (fun (s, _) -> s = method_name) (List.append trait_decl.required_methods provided) in - let method_def = C.ctx_lookup_fun_decl ctx method_id in + let method_def = ctx_lookup_fun_decl ctx method_id in log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); (* Instantiate *) let regions_hierarchy = LlbcAstUtils.FunIdMap.find (FRegular method_id) ctx.fun_context.regions_hierarchies in - let tr_self = T.TraitRef trait_ref in + let tr_self = TraitRef trait_ref in let inst_sg = - instantiate_fun_sig ctx generics tr_self method_def.A.signature + instantiate_fun_sig ctx generics tr_self method_def.signature regions_hierarchy in (call.func.func, call.func.generics, method_def, inst_sg)) in (* Sanity check *) - assert (List.length call.args = List.length def.A.signature.inputs); + assert (List.length call.args = List.length def.signature.inputs); (* Evaluate the function call *) eval_function_call_symbolic_from_inst_sig config func inst_sg generics call.args call.dest cf ctx @@ -1278,10 +1265,9 @@ and eval_transparent_function_call_symbolic (config : C.config) (call : A.call) overriding them. We treat them as regular method, which take an additional trait ref as input. *) -and eval_function_call_symbolic_from_inst_sig (config : C.config) - (fid : A.fun_id_or_trait_method_ref) (inst_sg : A.inst_fun_sig) - (generics : T.generic_args) (args : E.operand list) (dest : E.place) : - st_cm_fun = +and eval_function_call_symbolic_from_inst_sig (config : config) + (fid : fun_id_or_trait_method_ref) (inst_sg : inst_fun_sig) + (generics : generic_args) (args : operand list) (dest : place) : st_cm_fun = fun cf ctx -> log#ldebug (lazy @@ -1290,14 +1276,14 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) ^ "\n- inst_sg:\n" ^ inst_fun_sig_to_string ctx inst_sg ^ "\n- call.generics:\n" - ^ PA.generic_args_to_string ctx generics + ^ generic_args_to_string ctx generics ^ "\n- args:\n" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "\n- dest:\n" ^ place_to_string ctx dest)); (* Generate a fresh symbolic value for the return value *) - let ret_sv_ty = inst_sg.A.output in - let ret_spc = mk_fresh_symbolic_value V.FunCallRet ret_sv_ty in + let ret_sv_ty = inst_sg.output in + let ret_spc = mk_fresh_symbolic_value FunCallRet ret_sv_ty in let ret_value = mk_typed_value_from_symbolic_value ret_spc in let ret_av regions = mk_aproj_loans_value_from_symbolic_value regions ret_spc @@ -1309,16 +1295,16 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) let cc = eval_operands config args in (* Generate the abstractions and insert them in the context *) - let abs_ids = List.map (fun rg -> rg.T.id) inst_sg.regions_hierarchy in - let cf_call cf (args : V.typed_value list) : m_fun = + let abs_ids = List.map (fun rg -> rg.id) inst_sg.regions_hierarchy in + let cf_call cf (args : typed_value list) : m_fun = fun ctx -> - let args_with_rtypes = List.combine args inst_sg.A.inputs in + let args_with_rtypes = List.combine args inst_sg.inputs in (* Check the type of the input arguments *) assert ( List.for_all - (fun ((arg, rty) : V.typed_value * T.rty) -> - arg.V.ty = Subst.erase_regions rty) + (fun ((arg, rty) : typed_value * rty) -> + arg.ty = Subst.erase_regions rty) args_with_rtypes); (* Check that the input arguments don't contain symbolic values that can't * be fed to functions (i.e., symbolic values output from function return @@ -1334,8 +1320,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) * First, we define the function which, given an initialized, empty * abstraction, computes the avalues which should be inserted inside. *) - let compute_abs_avalues (abs : V.abs) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_avalue list = + let compute_abs_avalues (abs : abs) (ctx : eval_ctx) : + eval_ctx * typed_avalue list = (* Project over the input values *) let ctx, args_projs = List.fold_left_map @@ -1348,12 +1334,12 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (ctx, List.append args_projs [ ret_av abs.regions ]) in (* Actually initialize and insert the abstractions *) - let call_id = C.fresh_fun_call_id () in + let call_id = fresh_fun_call_id () in let region_can_end _ = true in let ctx = create_push_abstractions_from_abs_region_groups - (fun rg_id -> V.FunCall (call_id, rg_id)) - inst_sg.A.regions_hierarchy region_can_end compute_abs_avalues ctx + (fun rg_id -> FunCall (call_id, rg_id)) + inst_sg.regions_hierarchy region_can_end compute_abs_avalues ctx in (* Apply the continuation *) @@ -1381,9 +1367,9 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) List.partition (fun abs_id -> (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in + let abs = ctx_lookup_abs ctx abs_id in (* Check if it has parents *) - V.AbstractionId.Set.is_empty abs.parents + AbstractionId.Set.is_empty abs.parents (* Check if it contains non-ignored loans *) && Option.is_none (InterpreterBorrowsCore @@ -1395,7 +1381,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (* Update the reference to the list of asbtraction ids, for the recursive calls *) abs_ids := with_loans_abs; (* End the abstractions which can be ended *) - let no_loans_abs = V.AbstractionId.Set.of_list no_loans_abs in + let no_loans_abs = AbstractionId.Set.of_list no_loans_abs in let cc = InterpreterBorrows.end_abstractions config no_loans_abs in (* Recursive call *) let cc = comp cc end_abs_with_no_loans in @@ -1422,8 +1408,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) cc (cf Unit) ctx (** Evaluate a non-local function call in symbolic mode *) -and eval_assumed_function_call_symbolic (config : C.config) - (fid : A.assumed_fun_id) (call : A.call) : st_cm_fun = +and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) + (call : call) : st_cm_fun = fun cf ctx -> let generics = call.func.generics in let args = call.args in @@ -1461,7 +1447,7 @@ and eval_assumed_function_call_symbolic (config : C.config) ctx.fun_context.regions_hierarchies in (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in + let tr_self = UnknownTrait __FUNCTION__ in instantiate_fun_sig ctx generics tr_self (Assumed.get_assumed_fun_sig fid) regions_hierarchy @@ -1472,7 +1458,7 @@ and eval_assumed_function_call_symbolic (config : C.config) inst_sig generics args dest cf ctx (** Evaluate a statement seen as a function body *) -and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = +and eval_function_body (config : config) (body : statement) : st_cm_fun = fun cf ctx -> let cc = eval_statement config body in let cf_finish cf res = @@ -1482,7 +1468,7 @@ and eval_function_body (config : C.config) (body : A.statement) : st_cm_fun = * checking the invariants *) let cc = greedy_expand_symbolic_values config in (* Sanity check *) - let cc = comp_check_ctx cc Inv.check_invariants in + let cc = comp_check_ctx cc Invariants.check_invariants in (* Continue *) cc (cf res) in diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index e65758ae..d84e8be6 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -1,15 +1,8 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging -module Inv = Invariants -module S = SynthesizeSymbolic +open Types +open Values +open Contexts +open LlbcAst open Cps -open InterpreterExpressions (** Pop the current frame. @@ -17,13 +10,13 @@ open InterpreterExpressions dummy variables, after ending the proper borrows of course) but the return variable, move the return value out of the return variable, remove all the local variables (but preserve the abstractions!), remove the - {!constructor:C.env_elem.Frame} indicator delimiting the current frame and + {!constructor:env_elem.Frame} indicator delimiting the current frame and handle the return value to the continuation. If the boolean is false, we don't move the return value, and call the continuation with [None]. *) -val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun +val pop_frame : config -> bool -> (typed_value option -> m_fun) -> m_fun (** Helper. @@ -44,15 +37,15 @@ val pop_frame : C.config -> bool -> (V.typed_value option -> m_fun) -> m_fun - [ctx] *) val create_push_abstractions_from_abs_region_groups : - (T.RegionGroupId.id -> V.abs_kind) -> - LA.abs_region_group list -> - (T.RegionGroupId.id -> bool) -> - (V.abs -> C.eval_ctx -> C.eval_ctx * V.typed_avalue list) -> - C.eval_ctx -> - C.eval_ctx + (RegionGroupId.id -> abs_kind) -> + abs_region_group list -> + (RegionGroupId.id -> bool) -> + (abs -> eval_ctx -> eval_ctx * typed_avalue list) -> + eval_ctx -> + eval_ctx (** Evaluate a statement *) -val eval_statement : C.config -> LA.statement -> st_cm_fun +val eval_statement : config -> statement -> st_cm_fun (** Evaluate a statement seen as a function body *) -val eval_function_body : C.config -> LA.statement -> st_cm_fun +val eval_function_body : config -> statement -> st_cm_fun diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index e5a5b2ea..ecd8f53f 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -1,25 +1,22 @@ -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst -module L = Logging +open Types +open Values +open Expressions +open Contexts +open LlbcAst open Utils open TypesUtils -module PA = Print.EvalCtxLlbcAst open Cps (* TODO: we should probably rename the file to ContextsUtils *) (** The local logger *) -let log = L.interpreter_log +let log = Logging.interpreter_log (** Some utilities *) (** Auxiliary function - call a function which requires a continuation, and return the let context given to the continuation *) -let get_cf_ctx_no_synth (f : cm_fun) (ctx : C.eval_ctx) : C.eval_ctx = +let get_cf_ctx_no_synth (f : cm_fun) (ctx : eval_ctx) : eval_ctx = let nctx = ref None in let cf ctx = assert (!nctx = None); @@ -31,120 +28,120 @@ let get_cf_ctx_no_synth (f : cm_fun) (ctx : C.eval_ctx) : C.eval_ctx = let eval_ctx_to_string_no_filter = Print.Contexts.eval_ctx_to_string_no_filter let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string -let symbolic_value_to_string = PA.symbolic_value_to_string -let borrow_content_to_string = PA.borrow_content_to_string -let loan_content_to_string = PA.loan_content_to_string -let aborrow_content_to_string = PA.aborrow_content_to_string -let aloan_content_to_string = PA.aloan_content_to_string -let aproj_to_string = PA.aproj_to_string -let typed_value_to_string = PA.typed_value_to_string -let typed_avalue_to_string = PA.typed_avalue_to_string -let place_to_string = PA.place_to_string -let operand_to_string = PA.operand_to_string -let fun_sig_to_string = PA.fun_sig_to_string -let inst_fun_sig_to_string = PA.inst_fun_sig_to_string +let name_to_string = Print.EvalCtx.name_to_string +let symbolic_value_to_string = Print.EvalCtx.symbolic_value_to_string +let borrow_content_to_string = Print.EvalCtx.borrow_content_to_string +let loan_content_to_string = Print.EvalCtx.loan_content_to_string +let aborrow_content_to_string = Print.EvalCtx.aborrow_content_to_string +let aloan_content_to_string = Print.EvalCtx.aloan_content_to_string +let aproj_to_string = Print.EvalCtx.aproj_to_string +let typed_value_to_string = Print.EvalCtx.typed_value_to_string +let typed_avalue_to_string = Print.EvalCtx.typed_avalue_to_string +let place_to_string = Print.EvalCtx.place_to_string +let operand_to_string = Print.EvalCtx.operand_to_string +let fun_sig_to_string = Print.EvalCtx.fun_sig_to_string +let inst_fun_sig_to_string = Print.EvalCtx.inst_fun_sig_to_string +let ty_to_string = Print.EvalCtx.ty_to_string +let generic_args_to_string = Print.EvalCtx.generic_args_to_string let fun_id_or_trait_method_ref_to_string = - PA.fun_id_or_trait_method_ref_to_string + Print.EvalCtx.fun_id_or_trait_method_ref_to_string -let fun_decl_to_string = PA.fun_decl_to_string -let call_to_string = PA.call_to_string +let fun_decl_to_string = Print.EvalCtx.fun_decl_to_string +let call_to_string = Print.EvalCtx.call_to_string let trait_impl_to_string ctx = - PA.trait_impl_to_string { ctx with type_vars = []; const_generic_vars = [] } + Print.EvalCtx.trait_impl_to_string + { ctx with type_vars = []; const_generic_vars = [] } -let statement_to_string ctx = PA.statement_to_string ctx "" " " -let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " -let env_elem_to_string ctx = PA.env_elem_to_string ctx "" " " +let statement_to_string ctx = Print.EvalCtx.statement_to_string ctx "" " " + +let statement_to_string_with_tab ctx = + Print.EvalCtx.statement_to_string ctx " " " " + +let env_elem_to_string ctx = Print.EvalCtx.env_elem_to_string ctx "" " " let env_to_string ctx env = eval_ctx_to_string { ctx with env } -let abs_to_string ctx = PA.abs_to_string ctx "" " " +let abs_to_string ctx = Print.EvalCtx.abs_to_string ctx "" " " -let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = - sv0.V.sv_id = sv1.V.sv_id +let same_symbolic_id (sv0 : symbolic_value) (sv1 : symbolic_value) : bool = + sv0.sv_id = sv1.sv_id -let mk_var (index : E.VarId.id) (name : string option) (var_ty : T.ty) : A.var = - { A.index; name; var_ty } +let mk_var (index : VarId.id) (name : string option) (var_ty : ty) : var = + { index; name; var_ty } (** Small helper - TODO: move *) -let mk_place_from_var_id (var_id : E.VarId.id) : E.place = +let mk_place_from_var_id (var_id : VarId.id) : place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (sv_kind : V.sv_kind) (ty : T.ty) : V.symbolic_value - = +let mk_fresh_symbolic_value (sv_kind : sv_kind) (ty : ty) : symbolic_value = (* Sanity check *) assert (ty_is_rty ty); - let sv_id = C.fresh_symbolic_value_id () in - let svalue = { V.sv_kind; V.sv_id; V.sv_ty = ty } in + let sv_id = fresh_symbolic_value_id () in + let svalue = { sv_kind; sv_id; sv_ty = ty } in svalue -let mk_fresh_symbolic_value_from_no_regions_ty (sv_kind : V.sv_kind) (ty : T.ty) - : V.symbolic_value = +let mk_fresh_symbolic_value_from_no_regions_ty (sv_kind : sv_kind) (ty : ty) : + symbolic_value = assert (ty_no_regions ty); mk_fresh_symbolic_value sv_kind ty (** Create a fresh symbolic value *) -let mk_fresh_symbolic_typed_value (sv_kind : V.sv_kind) (rty : T.ty) : - V.typed_value = +let mk_fresh_symbolic_typed_value (sv_kind : sv_kind) (rty : ty) : typed_value = assert (ty_is_rty rty); - let ty = Subst.erase_regions rty in + let ty = Substitute.erase_regions rty in (* Generate the fresh a symbolic value *) let value = mk_fresh_symbolic_value sv_kind rty in - let value = V.VSymbolic value in - { V.value; V.ty } + let value = VSymbolic value in + { value; ty } -let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : V.sv_kind) - (ty : T.ty) : V.typed_value = +let mk_fresh_symbolic_typed_value_from_no_regions_ty (sv_kind : sv_kind) + (ty : ty) : typed_value = assert (ty_no_regions ty); mk_fresh_symbolic_typed_value sv_kind ty (** Create a typed value from a symbolic value. *) -let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : - V.typed_value = - let av = V.VSymbolic svalue in - let av : V.typed_value = - { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } +let mk_typed_value_from_symbolic_value (svalue : symbolic_value) : typed_value = + let av = VSymbolic svalue in + let av : typed_value = + { value = av; ty = Substitute.erase_regions svalue.sv_ty } in av (** Create a loans projector value from a symbolic value. Checks if the projector will actually project some regions. If not, - returns {!V.AIgnored} ([_]). + returns {!AIgnored} ([_]). TODO: update to handle 'static *) -let mk_aproj_loans_value_from_symbolic_value (regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) : V.typed_avalue = +let mk_aproj_loans_value_from_symbolic_value (regions : RegionId.Set.t) + (svalue : symbolic_value) : typed_avalue = if ty_has_regions_in_set regions svalue.sv_ty then - let av = V.ASymbolic (V.AProjLoans (svalue, [])) in - let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in + let av = ASymbolic (AProjLoans (svalue, [])) in + let av : typed_avalue = { value = av; ty = svalue.sv_ty } in av - else { V.value = V.AIgnored; ty = svalue.V.sv_ty } + else { value = AIgnored; ty = svalue.sv_ty } (** Create a borrows projector from a symbolic value *) -let mk_aproj_borrows_from_symbolic_value (proj_regions : T.RegionId.Set.t) - (svalue : V.symbolic_value) (proj_ty : T.ty) : V.aproj = +let mk_aproj_borrows_from_symbolic_value (proj_regions : RegionId.Set.t) + (svalue : symbolic_value) (proj_ty : ty) : aproj = assert (ty_is_rty proj_ty); if ty_has_regions_in_set proj_regions proj_ty then - V.AProjBorrows (svalue, proj_ty) - else V.AIgnoredProjBorrows + AProjBorrows (svalue, proj_ty) + else AIgnoredProjBorrows (** TODO: move *) -let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool - = - match asb with - | V.AsbBorrow bid' -> bid' = bid - | V.AsbProjReborrows _ -> false +let borrow_is_asb (bid : BorrowId.id) (asb : abstract_shared_borrow) : bool = + match asb with AsbBorrow bid' -> bid' = bid | AsbProjReborrows _ -> false (** TODO: move *) -let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool - = +let borrow_in_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : bool = List.exists (borrow_is_asb bid) asb (** TODO: move *) -let remove_borrow_from_asb (bid : V.BorrowId.id) - (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = +let remove_borrow_from_asb (bid : BorrowId.id) (asb : abstract_shared_borrows) : + abstract_shared_borrows = let removed = ref 0 in let asb = List.filter @@ -168,26 +165,26 @@ type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b [@@deriving show] (** Generic loan content: concrete or abstract *) -type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs +type g_loan_content = (loan_content, aloan_content) concrete_or_abs [@@deriving show] (** Generic borrow content: concrete or abstract *) -type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs +type g_borrow_content = (borrow_content, aborrow_content) concrete_or_abs [@@deriving show] type abs_or_var_id = - | AbsId of V.AbstractionId.id - | VarId of E.VarId.id - | DummyVarId of C.DummyVarId.id + | AbsId of AbstractionId.id + | VarId of VarId.id + | DummyVarId of DummyVarId.id (** Utility exception *) -exception FoundBorrowContent of V.borrow_content +exception FoundBorrowContent of borrow_content (** Utility exception *) -exception FoundLoanContent of V.loan_content +exception FoundLoanContent of loan_content (** Utility exception *) -exception FoundABorrowContent of V.aborrow_content +exception FoundABorrowContent of aborrow_content (** Utility exception *) exception FoundGBorrowContent of g_borrow_content @@ -196,30 +193,30 @@ exception FoundGBorrowContent of g_borrow_content exception FoundGLoanContent of g_loan_content (** Utility exception *) -exception FoundAProjBorrows of V.symbolic_value * T.ty +exception FoundAProjBorrows of symbolic_value * ty -let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : +let symbolic_value_id_in_ctx (sv_id : SymbolicValueId.id) (ctx : eval_ctx) : bool = let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_VSymbolic _ sv = - if sv.V.sv_id = sv_id then raise Found else () + if sv.sv_id = sv_id then raise Found else () method! visit_aproj env aproj = (match aproj with | AProjLoans (sv, _) | AProjBorrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () + if sv.sv_id = sv_id then raise Found else () | AEndedProjLoans _ | AEndedProjBorrows _ | AIgnoredProjBorrows -> ()); super#visit_aproj env aproj method! visit_abstract_shared_borrows _ asb = - let visit (asb : V.abstract_shared_borrow) : unit = + let visit (asb : abstract_shared_borrow) : unit = match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () + | AsbBorrow _ -> () + | AsbProjReborrows (sv, _) -> + if sv.sv_id = sv_id then raise Found else () in List.iter visit asb end @@ -236,21 +233,20 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : check that the set of ended regions doesn't intersect the set of regions used in the type (this is more general). *) -let symbolic_value_has_ended_regions (ended_regions : T.RegionId.Set.t) - (s : V.symbolic_value) : bool = - let regions = ty_regions s.V.sv_ty in - not (T.RegionId.Set.disjoint regions ended_regions) +let symbolic_value_has_ended_regions (ended_regions : RegionId.Set.t) + (s : symbolic_value) : bool = + let regions = ty_regions s.sv_ty in + not (RegionId.Set.disjoint regions ended_regions) -(** Check if a {!type:V.value} contains [⊥]. +(** Check if a {!type:value} contains [⊥]. Note that this function is very general: it also checks wether symbolic values contain already ended regions. *) -let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : - bool = +let bottom_in_value (ended_regions : RegionId.Set.t) (v : typed_value) : bool = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_VBottom _ = raise Found method! visit_symbolic_value _ s = @@ -264,21 +260,21 @@ let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : false with Found -> true -let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) - (v : V.typed_value) : bool = +let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : eval_ctx) + (v : typed_value) : bool = let obj = object - inherit [_] V.iter_typed_value + inherit [_] iter_typed_value method! visit_symbolic_value _ s = match s.sv_kind with - | V.FunCallRet | V.LoopOutput | V.LoopJoin -> + | FunCallRet | LoopOutput | LoopJoin -> if ty_has_borrow_under_mut ctx.type_context.type_infos s.sv_ty then raise Found else () - | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack | V.Global | V.LoopGivenBack | V.Aggregate - | V.ConstGeneric | V.TraitConst -> + | SynthInput | SynthInputGivenBack | FunCallGivenBack + | SynthRetGivenBack | Global | LoopGivenBack | Aggregate | ConstGeneric + | TraitConst -> () end in @@ -291,7 +287,7 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) (** Return the place used in an rvalue, if that makes sense. This is used to compute meta-data, to find pretty names. *) -let rvalue_get_place (rv : E.rvalue) : E.place option = +let rvalue_get_place (rv : rvalue) : place option = match rv with | Use (Copy p | Move p) -> Some p | Use (Constant _) -> None @@ -299,30 +295,29 @@ let rvalue_get_place (rv : E.rvalue) : E.place option = | UnaryOp _ | BinaryOp _ | Global _ | Discriminant _ | Aggregate _ -> None (** See {!ValuesUtils.symbolic_value_has_borrows} *) -let symbolic_value_has_borrows (ctx : C.eval_ctx) (sv : V.symbolic_value) : bool - = +let symbolic_value_has_borrows (ctx : eval_ctx) (sv : symbolic_value) : bool = ValuesUtils.symbolic_value_has_borrows ctx.type_context.type_infos sv (** See {!ValuesUtils.value_has_borrows}. *) -let value_has_borrows (ctx : C.eval_ctx) (v : V.value) : bool = +let value_has_borrows (ctx : eval_ctx) (v : value) : bool = ValuesUtils.value_has_borrows ctx.type_context.type_infos v (** See {!ValuesUtils.value_has_loans_or_borrows}. *) -let value_has_loans_or_borrows (ctx : C.eval_ctx) (v : V.value) : bool = +let value_has_loans_or_borrows (ctx : eval_ctx) (v : value) : bool = ValuesUtils.value_has_loans_or_borrows ctx.type_context.type_infos v (** See {!ValuesUtils.value_has_loans}. *) -let value_has_loans (v : V.value) : bool = ValuesUtils.value_has_loans v +let value_has_loans (v : value) : bool = ValuesUtils.value_has_loans v (** See {!compute_typed_value_ids}, {!compute_context_ids}, etc. *) type ids_sets = { - aids : V.AbstractionId.Set.t; - blids : V.BorrowId.Set.t; (** All the borrow/loan ids *) - borrow_ids : V.BorrowId.Set.t; (** Only the borrow ids *) - loan_ids : V.BorrowId.Set.t; (** Only the loan ids *) - dids : C.DummyVarId.Set.t; - rids : T.RegionId.Set.t; - sids : V.SymbolicValueId.Set.t; + aids : AbstractionId.Set.t; + blids : BorrowId.Set.t; (** All the borrow/loan ids *) + borrow_ids : BorrowId.Set.t; (** Only the borrow ids *) + loan_ids : BorrowId.Set.t; (** Only the loan ids *) + dids : DummyVarId.Set.t; + rids : RegionId.Set.t; + sids : SymbolicValueId.Set.t; } [@@deriving show] @@ -330,19 +325,17 @@ type ids_sets = { TODO: there misses information. *) -type ids_to_values = { - sids_to_values : V.symbolic_value V.SymbolicValueId.Map.t; -} +type ids_to_values = { sids_to_values : symbolic_value SymbolicValueId.Map.t } let compute_ids () = - let blids = ref V.BorrowId.Set.empty in - let borrow_ids = ref V.BorrowId.Set.empty in - let loan_ids = ref V.BorrowId.Set.empty in - let aids = ref V.AbstractionId.Set.empty in - let dids = ref C.DummyVarId.Set.empty in - let rids = ref T.RegionId.Set.empty in - let sids = ref V.SymbolicValueId.Set.empty in - let sids_to_values = ref V.SymbolicValueId.Map.empty in + let blids = ref BorrowId.Set.empty in + let borrow_ids = ref BorrowId.Set.empty in + let loan_ids = ref BorrowId.Set.empty in + let aids = ref AbstractionId.Set.empty in + let dids = ref DummyVarId.Set.empty in + let rids = ref RegionId.Set.empty in + let sids = ref SymbolicValueId.Set.empty in + let sids_to_values = ref SymbolicValueId.Map.empty in let get_ids () = { @@ -358,156 +351,154 @@ let compute_ids () = let get_ids_to_values () = { sids_to_values = !sids_to_values } in let obj = object - inherit [_] C.iter_eval_ctx as super - method! visit_dummy_var_id _ did = dids := C.DummyVarId.Set.add did !dids + inherit [_] iter_eval_ctx as super + method! visit_dummy_var_id _ did = dids := DummyVarId.Set.add did !dids method! visit_borrow_id _ id = - blids := V.BorrowId.Set.add id !blids; - borrow_ids := V.BorrowId.Set.add id !borrow_ids + blids := BorrowId.Set.add id !blids; + borrow_ids := BorrowId.Set.add id !borrow_ids method! visit_loan_id _ id = - blids := V.BorrowId.Set.add id !blids; - loan_ids := V.BorrowId.Set.add id !loan_ids + blids := BorrowId.Set.add id !blids; + loan_ids := BorrowId.Set.add id !loan_ids - method! visit_abstraction_id _ id = - aids := V.AbstractionId.Set.add id !aids - - method! visit_region_id _ id = rids := T.RegionId.Set.add id !rids + method! visit_abstraction_id _ id = aids := AbstractionId.Set.add id !aids + method! visit_region_id _ id = rids := RegionId.Set.add id !rids method! visit_symbolic_value env sv = - sids := V.SymbolicValueId.Set.add sv.sv_id !sids; - sids_to_values := V.SymbolicValueId.Map.add sv.sv_id sv !sids_to_values; + sids := SymbolicValueId.Set.add sv.sv_id !sids; + sids_to_values := SymbolicValueId.Map.add sv.sv_id sv !sids_to_values; super#visit_symbolic_value env sv method! visit_symbolic_value_id _ id = (* TODO: can we get there without going through [visit_symbolic_value] first? *) - sids := V.SymbolicValueId.Set.add id !sids + sids := SymbolicValueId.Set.add id !sids end in (obj, get_ids, get_ids_to_values) (** Compute the sets of ids found in a list of typed values. *) -let compute_typed_values_ids (xl : V.typed_value list) : - ids_sets * ids_to_values = +let compute_typed_values_ids (xl : typed_value list) : ids_sets * ids_to_values + = let compute, get_ids, get_ids_to_values = compute_ids () in List.iter (compute#visit_typed_value ()) xl; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in a typed value. *) -let compute_typed_value_ids (x : V.typed_value) : ids_sets * ids_to_values = +let compute_typed_value_ids (x : typed_value) : ids_sets * ids_to_values = compute_typed_values_ids [ x ] (** Compute the sets of ids found in a list of abstractions. *) -let compute_absl_ids (xl : V.abs list) : ids_sets * ids_to_values = +let compute_absl_ids (xl : abs list) : ids_sets * ids_to_values = let compute, get_ids, get_ids_to_values = compute_ids () in List.iter (compute#visit_abs ()) xl; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in an abstraction. *) -let compute_abs_ids (x : V.abs) : ids_sets * ids_to_values = +let compute_abs_ids (x : abs) : ids_sets * ids_to_values = compute_absl_ids [ x ] (** Compute the sets of ids found in an environment. *) -let compute_env_ids (x : C.env) : ids_sets * ids_to_values = +let compute_env_ids (x : env) : ids_sets * ids_to_values = let compute, get_ids, get_ids_to_values = compute_ids () in compute#visit_env () x; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in an environment element. *) -let compute_env_elem_ids (x : C.env_elem) : ids_sets * ids_to_values = +let compute_env_elem_ids (x : env_elem) : ids_sets * ids_to_values = compute_env_ids [ x ] (** Compute the sets of ids found in a list of contexts. *) -let compute_contexts_ids (ctxl : C.eval_ctx list) : ids_sets * ids_to_values = +let compute_contexts_ids (ctxl : eval_ctx list) : ids_sets * ids_to_values = let compute, get_ids, get_ids_to_values = compute_ids () in List.iter (compute#visit_eval_ctx ()) ctxl; (get_ids (), get_ids_to_values ()) (** Compute the sets of ids found in a context. *) -let compute_context_ids (ctx : C.eval_ctx) : ids_sets * ids_to_values = +let compute_context_ids (ctx : eval_ctx) : ids_sets * ids_to_values = compute_contexts_ids [ ctx ] (** **WARNING**: this function doesn't compute the normalized types (for the trait type aliases). This should be computed afterwards. *) -let initialize_eval_context (ctx : C.decls_ctx) - (region_groups : T.RegionGroupId.id list) (type_vars : T.type_var list) - (const_generic_vars : T.const_generic_var list) : C.eval_ctx = - C.reset_global_counters (); +let initialize_eval_context (ctx : decls_ctx) + (region_groups : RegionGroupId.id list) (type_vars : type_var list) + (const_generic_vars : const_generic_var list) : eval_ctx = + reset_global_counters (); let const_generic_vars_map = - T.ConstGenericVarId.Map.of_list + ConstGenericVarId.Map.of_list (List.map - (fun (cg : T.const_generic_var) -> - let ty = T.TLiteral cg.ty in - let cv = mk_fresh_symbolic_typed_value V.ConstGeneric ty in + (fun (cg : const_generic_var) -> + let ty = TLiteral cg.ty in + let cv = mk_fresh_symbolic_typed_value ConstGeneric ty in (cg.index, cv)) const_generic_vars) in { - C.type_context = ctx.type_ctx; - C.fun_context = ctx.fun_ctx; - C.global_context = ctx.global_ctx; - C.trait_decls_context = ctx.trait_decls_ctx; - C.trait_impls_context = ctx.trait_impls_ctx; - C.region_groups; - C.type_vars; - C.const_generic_vars; - C.const_generic_vars_map; - C.norm_trait_types = C.TraitTypeRefMap.empty (* Empty for now *); - C.env = [ C.EFrame ]; - C.ended_regions = T.RegionId.Set.empty; + type_context = ctx.type_ctx; + fun_context = ctx.fun_ctx; + global_context = ctx.global_ctx; + trait_decls_context = ctx.trait_decls_ctx; + trait_impls_context = ctx.trait_impls_ctx; + region_groups; + type_vars; + const_generic_vars; + const_generic_vars_map; + norm_trait_types = TraitTypeRefMap.empty (* Empty for now *); + env = [ EFrame ]; + ended_regions = RegionId.Set.empty; } (** Instantiate a function signature, introducing **fresh** abstraction ids and region ids. This is mostly used in preparation of function calls (when evaluating in symbolic mode). *) -let instantiate_fun_sig (ctx : C.eval_ctx) (generics : T.generic_args) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) : A.inst_fun_sig = +let instantiate_fun_sig (ctx : eval_ctx) (generics : generic_args) + (tr_self : trait_instance_id) (sg : fun_sig) + (regions_hierarchy : region_groups) : inst_fun_sig = log#ldebug (lazy ("instantiate_fun_sig:" ^ "\n- generics: " - ^ PA.generic_args_to_string ctx generics + ^ Print.EvalCtx.generic_args_to_string ctx generics ^ "\n- tr_self: " - ^ PA.trait_instance_id_to_string ctx tr_self + ^ Print.EvalCtx.trait_instance_id_to_string ctx tr_self ^ "\n- sg: " ^ fun_sig_to_string ctx sg)); (* Erase the regions in the generics we use for the instantiation *) - let generics = Subst.generic_args_erase_regions generics in - let tr_self = Subst.trait_instance_id_erase_regions tr_self in + let generics = Substitute.generic_args_erase_regions generics in + let tr_self = Substitute.trait_instance_id_erase_regions tr_self in (* Generate fresh abstraction ids and create a substitution from region * group ids to abstraction ids *) let rg_abs_ids_bindings = List.map (fun rg -> - let abs_id = C.fresh_abstraction_id () in - (rg.T.id, abs_id)) + let abs_id = fresh_abstraction_id () in + (rg.id, abs_id)) regions_hierarchy in - let asubst_map : V.AbstractionId.id T.RegionGroupId.Map.t = + let asubst_map : AbstractionId.id RegionGroupId.Map.t = List.fold_left - (fun mp (rg_id, abs_id) -> T.RegionGroupId.Map.add rg_id abs_id mp) - T.RegionGroupId.Map.empty rg_abs_ids_bindings + (fun mp (rg_id, abs_id) -> RegionGroupId.Map.add rg_id abs_id mp) + RegionGroupId.Map.empty rg_abs_ids_bindings in - let asubst (rg_id : T.RegionGroupId.id) : V.AbstractionId.id = - T.RegionGroupId.Map.find rg_id asubst_map + let asubst (rg_id : RegionGroupId.id) : AbstractionId.id = + RegionGroupId.Map.find rg_id asubst_map in (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Subst.fresh_regions_with_substs sg.generics.regions in + let _, rsubst, _ = Substitute.fresh_regions_with_substs sg.generics.regions in (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) assert (List.for_all TypesUtils.ty_no_regions generics.types); assert (TypesUtils.trait_instance_id_no_regions tr_self); let tsubst = - Subst.make_type_subst_from_vars sg.generics.types generics.types + Substitute.make_type_subst_from_vars sg.generics.types generics.types in let cgsubst = - Subst.make_const_generic_subst_from_vars sg.generics.const_generics + Substitute.make_const_generic_subst_from_vars sg.generics.const_generics generics.const_generics in let tr_subst = - Subst.make_trait_subst_from_clauses sg.generics.trait_clauses + Substitute.make_trait_subst_from_clauses sg.generics.trait_clauses generics.trait_refs in (* Substitute the signature *) diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 7830099f..49ba8370 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -1,29 +1,24 @@ (* The following module defines functions to check that some invariants * are always maintained by evaluation contexts *) -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module Assoc = AssociatedTypes -module A = LlbcAst -module L = Logging +open Types +open PrimitiveValues +open Values +open Contexts open Cps open TypesUtils open InterpreterUtils open InterpreterBorrowsCore (** The local logger *) -let log = L.invariants_log +let log = Logging.invariants_log type borrow_info = { - loan_kind : T.ref_kind; + loan_kind : ref_kind; loan_in_abs : bool; (* true if the loan was found in an abstraction *) - loan_ids : V.BorrowId.Set.t; - borrow_ids : V.BorrowId.Set.t; + loan_ids : BorrowId.Set.t; + borrow_ids : BorrowId.Set.t; } [@@deriving show] @@ -39,30 +34,26 @@ let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = { outer_borrow = true; outer_shared = true } -let ids_reprs_to_string (indent : string) - (reprs : V.BorrowId.id V.BorrowId.Map.t) : string = - V.BorrowId.Map.to_string (Some indent) V.BorrowId.to_string reprs +let ids_reprs_to_string (indent : string) (reprs : BorrowId.id BorrowId.Map.t) : + string = + BorrowId.Map.to_string (Some indent) BorrowId.to_string reprs let borrows_infos_to_string (indent : string) - (infos : borrow_info V.BorrowId.Map.t) : string = - V.BorrowId.Map.to_string (Some indent) show_borrow_info infos + (infos : borrow_info BorrowId.Map.t) : string = + BorrowId.Map.to_string (Some indent) show_borrow_info infos -type borrow_kind = Mut | Shared | Reserved +type borrow_kind = BMut | BShared | BReserved (** Check that: - loans and borrows are correctly related - a two-phase borrow can't point to a value inside an abstraction *) -let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = +let check_loans_borrows_relation_invariant (ctx : eval_ctx) : unit = (* Link all the borrow ids to a representant - necessary because of shared * borrows/loans *) - let ids_reprs : V.BorrowId.id V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty - in + let ids_reprs : BorrowId.id BorrowId.Map.t ref = ref BorrowId.Map.empty in (* Link all the id representants to a borrow information *) - let borrows_infos : borrow_info V.BorrowId.Map.t ref = - ref V.BorrowId.Map.empty - in + let borrows_infos : borrow_info BorrowId.Map.t ref = ref BorrowId.Map.empty in let context_to_string () : string = eval_ctx_to_string ctx ^ "- representants:\n" ^ ids_reprs_to_string " " !ids_reprs @@ -73,62 +64,61 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = * map, we register it in this list; once the borrows_infos map is completely * built, we check that all the borrow ids of the ignored loans are in this * map *) - let ignored_loans : (T.ref_kind * V.BorrowId.id) list ref = ref [] in + let ignored_loans : (ref_kind * BorrowId.id) list ref = ref [] in (* first, register all the loans *) (* Some utilities to register the loans *) - let register_ignored_loan (rkind : T.ref_kind) (bid : V.BorrowId.id) : unit = + let register_ignored_loan (rkind : ref_kind) (bid : BorrowId.id) : unit = ignored_loans := (rkind, bid) :: !ignored_loans in - let register_shared_loan (loan_in_abs : bool) (bids : V.BorrowId.Set.t) : unit - = + let register_shared_loan (loan_in_abs : bool) (bids : BorrowId.Set.t) : unit = let reprs = !ids_reprs in let infos = !borrows_infos in (* Use the first borrow id as representant *) - let repr_bid = V.BorrowId.Set.min_elt bids in - assert (not (V.BorrowId.Map.mem repr_bid infos)); + let repr_bid = BorrowId.Set.min_elt bids in + assert (not (BorrowId.Map.mem repr_bid infos)); (* Insert the mappings to the representant *) let reprs = - V.BorrowId.Set.fold + BorrowId.Set.fold (fun bid reprs -> - assert (not (V.BorrowId.Map.mem bid reprs)); - V.BorrowId.Map.add bid repr_bid reprs) + assert (not (BorrowId.Map.mem bid reprs)); + BorrowId.Map.add bid repr_bid reprs) bids reprs in (* Insert the loan info *) let info = { - loan_kind = T.Shared; + loan_kind = RShared; loan_in_abs; loan_ids = bids; - borrow_ids = V.BorrowId.Set.empty; + borrow_ids = BorrowId.Set.empty; } in - let infos = V.BorrowId.Map.add repr_bid info infos in + let infos = BorrowId.Map.add repr_bid info infos in (* Update *) ids_reprs := reprs; borrows_infos := infos in - let register_mut_loan (loan_in_abs : bool) (bid : V.BorrowId.id) : unit = + let register_mut_loan (loan_in_abs : bool) (bid : BorrowId.id) : unit = let reprs = !ids_reprs in let infos = !borrows_infos in (* Sanity checks *) - assert (not (V.BorrowId.Map.mem bid reprs)); - assert (not (V.BorrowId.Map.mem bid infos)); + assert (not (BorrowId.Map.mem bid reprs)); + assert (not (BorrowId.Map.mem bid infos)); (* Add the mapping for the representant *) - let reprs = V.BorrowId.Map.add bid bid reprs in + let reprs = BorrowId.Map.add bid bid reprs in (* Add the mapping for the loan info *) let info = { - loan_kind = T.Mut; + loan_kind = RMut; loan_in_abs; - loan_ids = V.BorrowId.Set.singleton bid; - borrow_ids = V.BorrowId.Set.empty; + loan_ids = BorrowId.Set.singleton bid; + borrow_ids = BorrowId.Set.empty; } in - let infos = V.BorrowId.Map.add bid info infos in + let infos = BorrowId.Map.add bid info infos in (* Update *) ids_reprs := reprs; borrows_infos := infos @@ -136,7 +126,7 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = let loans_visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_EBinding _ binder v = let inside_abs = false in @@ -161,7 +151,7 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = match lc with | AMutLoan (bid, _) -> register_mut_loan inside_abs bid | ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids - | AIgnoredMutLoan (Some bid, _) -> register_ignored_loan T.Mut bid + | AIgnoredMutLoan (Some bid, _) -> register_ignored_loan RMut bid | AIgnoredMutLoan (None, _) | AIgnoredSharedLoan _ | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ } @@ -182,27 +172,27 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = (* Then, register all the borrows *) (* Some utilities to register the borrows *) - let find_info (bid : V.BorrowId.id) : borrow_info = + let find_info (bid : BorrowId.id) : borrow_info = (* Find the representant *) - match V.BorrowId.Map.find_opt bid !ids_reprs with + match BorrowId.Map.find_opt bid !ids_reprs with | Some repr_bid -> (* Lookup the info *) - V.BorrowId.Map.find repr_bid !borrows_infos + BorrowId.Map.find repr_bid !borrows_infos | None -> let err = "find_info: could not find the representant of borrow " - ^ V.BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () + ^ BorrowId.to_string bid ^ ":\nContext:\n" ^ context_to_string () in log#serror err; raise (Failure err) in - let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = + let update_info (bid : BorrowId.id) (info : borrow_info) : unit = (* Find the representant *) - let repr_bid = V.BorrowId.Map.find bid !ids_reprs in + let repr_bid = BorrowId.Map.find bid !ids_reprs in (* Update the info *) let infos = - V.BorrowId.Map.update repr_bid + BorrowId.Map.update repr_bid (fun x -> match x with | Some _ -> Some info @@ -214,39 +204,39 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = let register_ignored_borrow = register_ignored_loan in - let register_borrow (kind : borrow_kind) (bid : V.BorrowId.id) : unit = + let register_borrow (kind : borrow_kind) (bid : BorrowId.id) : unit = (* Lookup the info *) let info = find_info bid in (* Check that the borrow kind is consistent *) (match (info.loan_kind, kind) with - | T.Shared, (Shared | Reserved) | T.Mut, Mut -> () + | RShared, (BShared | BReserved) | RMut, BMut -> () | _ -> raise (Failure "Invariant not satisfied")); (* A reserved borrow can't point to a value inside an abstraction *) - assert (kind <> Reserved || not info.loan_in_abs); + assert (kind <> BReserved || not info.loan_in_abs); (* Insert the borrow id *) let borrow_ids = info.borrow_ids in - assert (not (V.BorrowId.Set.mem bid borrow_ids)); - let info = { info with borrow_ids = V.BorrowId.Set.add bid borrow_ids } in + assert (not (BorrowId.Set.mem bid borrow_ids)); + let info = { info with borrow_ids = BorrowId.Set.add bid borrow_ids } in (* Update the info in the map *) update_info bid info in let borrows_visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abstract_shared_borrow _ asb = match asb with - | V.AsbBorrow bid -> register_borrow Shared bid - | V.AsbProjReborrows _ -> () + | AsbBorrow bid -> register_borrow BShared bid + | AsbProjReborrows _ -> () method! visit_borrow_content env bc = (* Register the loan *) let _ = match bc with - | VSharedBorrow bid -> register_borrow Shared bid - | VMutBorrow (bid, _) -> register_borrow Mut bid - | VReservedMutBorrow bid -> register_borrow Reserved bid + | VSharedBorrow bid -> register_borrow BShared bid + | VMutBorrow (bid, _) -> register_borrow BMut bid + | VReservedMutBorrow bid -> register_borrow BReserved bid in (* Continue exploring *) super#visit_borrow_content env bc @@ -254,9 +244,9 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = method! visit_aborrow_content env bc = let _ = match bc with - | AMutBorrow (bid, _) -> register_borrow Mut bid - | ASharedBorrow bid -> register_borrow Shared bid - | AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow Mut bid + | AMutBorrow (bid, _) -> register_borrow BMut bid + | ASharedBorrow bid -> register_borrow BShared bid + | AIgnoredMutBorrow (Some bid, _) -> register_ignored_borrow RMut bid | AIgnoredMutBorrow (None, _) | AEndedMutBorrow _ | AEndedIgnoredMutBorrow _ | AEndedSharedBorrow | AProjSharedBorrow _ -> @@ -284,26 +274,26 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = !ignored_loans; (* Then, check the borrow infos *) - V.BorrowId.Map.iter + BorrowId.Map.iter (fun _ info -> (* Note that we can't directly compare the sets - I guess they are * different depending on the order in which we add the elements... *) assert ( - V.BorrowId.Set.elements info.loan_ids - = V.BorrowId.Set.elements info.borrow_ids); + BorrowId.Set.elements info.loan_ids + = BorrowId.Set.elements info.borrow_ids); match info.loan_kind with - | T.Mut -> assert (V.BorrowId.Set.cardinal info.loan_ids = 1) - | T.Shared -> ()) + | RMut -> assert (BorrowId.Set.cardinal info.loan_ids = 1) + | RShared -> ()) !borrows_infos (** Check that: - borrows/loans can't contain ⊥ or reserved mut borrows - shared loans can't contain mutable loans *) -let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = +let check_borrowed_values_invariant (ctx : eval_ctx) : unit = let visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_VBottom info = (* No ⊥ inside borrowed values *) @@ -377,13 +367,13 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx -let check_literal_type (cv : V.literal) (ty : PV.literal_type) : unit = +let check_literal_type (cv : literal) (ty : literal_type) : unit = match (cv, ty) with - | PV.VScalar sv, PV.TInteger int_ty -> assert (sv.int_ty = int_ty) - | PV.VBool _, PV.TBool | PV.VChar _, PV.TChar -> () + | VScalar sv, TInteger int_ty -> assert (sv.int_ty = int_ty) + | VBool _, TBool | VChar _, TChar -> () | _ -> raise (Failure "Erroneous typing") -let check_typing_invariant (ctx : C.eval_ctx) : unit = +let check_typing_invariant (ctx : eval_ctx) : unit = (* TODO: the type of aloans doens't make sense: they have a type * of the shape [& (mut) T] where they should have type [T]... * This messes a bit the type invariant checks when checking the @@ -391,14 +381,14 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = * we introduce this function, so that we can easily spot all the involved * places. * *) - let aloan_get_expected_child_type (ty : T.ty) : T.ty = + let aloan_get_expected_child_type (ty : ty) : ty = let _, ty, _ = ty_get_ref ty in ty in let visitor = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_EBinding info binder v = @@ -421,7 +411,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | VAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in + let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) assert ( List.length generics.regions = List.length def.generics.regions); @@ -429,17 +419,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) + assert (VariantId.to_int variant_id < List.length variants) | None, Struct _ -> () | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Assoc.type_decl_get_inst_norm_field_etypes ctx def av.variant_id - generics + AssociatedTypes.type_decl_get_inst_norm_field_etypes ctx def + av.variant_id generics in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_value * ty) -> assert (v.ty = ty)) fields_with_types (* Tuple case *) | VAdt av, TAdt (TTuple, generics) -> @@ -452,7 +442,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_value * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_value * ty) -> assert (v.ty = ty)) fields_with_types (* Assumed type case *) | VAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -471,7 +461,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* *) assert ( List.for_all - (fun (v : V.typed_value) -> v.ty = inner_ty) + (fun (v : typed_value) -> v.ty = inner_ty) inner_values); (* The length is necessarily concrete *) let len = @@ -485,7 +475,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | VBottom, _ -> (* Nothing to check *) () | VBorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | VSharedBorrow bid, Shared | VReservedMutBorrow bid, Mut -> ( + | VSharedBorrow bid, RShared | VReservedMutBorrow bid, RMut -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan ek_all bid ctx in match glc with @@ -493,7 +483,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | Abstract (ASharedLoan (_, sv, _)) -> assert (sv.ty = ref_ty) | _ -> raise (Failure "Inconsistent context")) - | VMutBorrow (_, bv), Mut -> + | VMutBorrow (_, bv), RMut -> assert ( (* Check that the borrowed value has the proper type *) bv.ty = ref_ty) @@ -507,10 +497,10 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = match glc with | Concrete (VMutBorrow (_, bv)) -> assert (bv.ty = ty) | Abstract (AMutBorrow (_, sv)) -> - assert (Subst.erase_regions sv.ty = ty) + assert (Substitute.erase_regions sv.ty = ty) | _ -> raise (Failure "Inconsistent context"))) | VSymbolic sv, ty -> - let ty' = Subst.erase_regions sv.sv_ty in + let ty' = Substitute.erase_regions sv.sv_ty in assert (ty' = ty) | _ -> raise (Failure "Erroneous typing")); (* Continue exploring to inspect the subterms *) @@ -533,7 +523,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | AAdt av, TAdt (TAdtId def_id, generics) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) - let def = C.ctx_lookup_type_decl ctx def_id in + let def = ctx_lookup_type_decl ctx def_id in (* Check the number of parameters *) assert ( List.length generics.regions = List.length def.generics.regions); @@ -544,17 +534,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Check that the variant id is consistent *) (match (av.variant_id, def.kind) with | Some variant_id, Enum variants -> - assert (T.VariantId.to_int variant_id < List.length variants) + assert (VariantId.to_int variant_id < List.length variants) | None, Struct _ -> () | _ -> raise (Failure "Erroneous typing")); (* Check that the field types are correct *) let field_types = - Assoc.type_decl_get_inst_norm_field_rtypes ctx def av.variant_id - generics + AssociatedTypes.type_decl_get_inst_norm_field_rtypes ctx def + av.variant_id generics in let fields_with_types = List.combine av.field_values field_types in List.iter - (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_avalue * ty) -> assert (v.ty = ty)) fields_with_types (* Tuple case *) | AAdt av, TAdt (TTuple, generics) -> @@ -567,7 +557,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.combine av.field_values generics.types in List.iter - (fun ((v, ty) : V.typed_avalue * T.ty) -> assert (v.ty = ty)) + (fun ((v, ty) : typed_avalue * ty) -> assert (v.ty = ty)) fields_with_types (* Assumed type case *) | AAdt av, TAdt (TAssumed aty_id, generics) -> ( @@ -586,23 +576,23 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | AMutBorrow (_, av), Mut -> + | AMutBorrow (_, av), RMut -> (* Check that the child value has the proper type *) assert (av.ty = ref_ty) - | ASharedBorrow bid, Shared -> ( + | ASharedBorrow bid, RShared -> ( (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> - assert (sv.ty = Subst.erase_regions ref_ty) + assert (sv.ty = Substitute.erase_regions ref_ty) | _ -> raise (Failure "Inconsistent context")) - | AIgnoredMutBorrow (_opt_bid, av), Mut -> assert (av.ty = ref_ty) + | AIgnoredMutBorrow (_opt_bid, av), RMut -> assert (av.ty = ref_ty) | ( AEndedIgnoredMutBorrow { given_back; child; given_back_meta = _ }, - Mut ) -> + RMut ) -> assert (given_back.ty = ref_ty); assert (child.ty = ref_ty) - | AProjSharedBorrow _, Shared -> () + | AProjSharedBorrow _, RShared -> () | _ -> raise (Failure "Inconsistent context")) | ALoan lc, aty -> ( match lc with @@ -614,18 +604,18 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = let glc = lookup_borrow ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> - assert (bv.ty = Subst.erase_regions borrowed_aty) + assert (bv.ty = Substitute.erase_regions borrowed_aty) | Abstract (AMutBorrow (_, sv)) -> assert ( - Subst.erase_regions sv.ty - = Subst.erase_regions borrowed_aty) + Substitute.erase_regions sv.ty + = Substitute.erase_regions borrowed_aty) | _ -> raise (Failure "Inconsistent context")) | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in assert (child_av.ty = borrowed_aty) | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in - assert (sv.ty = Subst.erase_regions borrowed_aty); + assert (sv.ty = Substitute.erase_regions borrowed_aty); (* TODO: the type of aloans doesn't make sense, see above *) assert (child_av.ty = borrowed_aty) | AEndedMutLoan { given_back; child; given_back_meta = _ } @@ -636,17 +626,17 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | AIgnoredSharedLoan child_av -> assert (child_av.ty = aloan_get_expected_child_type aty)) | ASymbolic aproj, ty -> ( - let ty1 = Subst.erase_regions ty in + let ty1 = Substitute.erase_regions ty in match aproj with | AProjLoans (sv, _) -> - let ty2 = Subst.erase_regions sv.sv_ty in + let ty2 = Substitute.erase_regions sv.sv_ty in assert (ty1 = ty2); (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) let abs = Option.get info in assert (ty_has_regions_in_set abs.regions sv.sv_ty) | AProjBorrows (sv, proj_ty) -> - let ty2 = Subst.erase_regions sv.sv_ty in + let ty2 = Substitute.erase_regions sv.sv_ty in assert (ty1 = ty2); (* Also check that the symbolic values contain regions of interest - * otherwise they should have been reduced to [_] *) @@ -656,7 +646,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = List.iter (fun (_, proj) -> match proj with - | V.AProjBorrows (_sv, ty') -> assert (ty' = ty) + | AProjBorrows (_sv, ty') -> assert (ty' = ty) | AEndedProjBorrows _ | AIgnoredProjBorrows -> () | _ -> raise (Failure "Unexpected")) given_back_ls @@ -665,34 +655,30 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> log#lerror (lazy - ("Erroneous typing:" ^ "\n- raw value: " - ^ V.show_typed_avalue atv ^ "\n- value: " + ("Erroneous typing:" ^ "\n- raw value: " ^ show_typed_avalue atv + ^ "\n- value: " ^ typed_avalue_to_string ctx atv - ^ "\n- type: " - ^ PA.ty_to_string ctx atv.V.ty)); + ^ "\n- type: " ^ ty_to_string ctx atv.ty)); raise (Failure "Erroneous typing")); (* Continue exploring to inspect the subterms *) super#visit_typed_avalue info atv end in - visitor#visit_eval_ctx (None : V.abs option) ctx + visitor#visit_eval_ctx (None : abs option) ctx type proj_borrows_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; - proj_ty : T.rty; (** The regions shouldn't be erased *) + abs_id : AbstractionId.id; + regions : RegionId.Set.t; + proj_ty : rty; (** The regions shouldn't be erased *) as_shared_value : bool; (** True if the value is below a shared borrow *) } [@@deriving show] -type proj_loans_info = { - abs_id : V.AbstractionId.id; - regions : T.RegionId.Set.t; -} +type proj_loans_info = { abs_id : AbstractionId.id; regions : RegionId.Set.t } [@@deriving show] type sv_info = { - ty : T.rty; (** The regions shouldn't be erased *) + ty : rty; (** The regions shouldn't be erased *) env_count : int; aproj_borrows : proj_borrows_info list; aproj_loans : proj_loans_info list; @@ -712,32 +698,32 @@ type sv_info = { - the union of the aproj_loans contains the aproj_borrows applied on the same symbolic values *) -let check_symbolic_values (ctx : C.eval_ctx) : unit = +let check_symbolic_values (ctx : eval_ctx) : unit = (* Small utility *) - let module M = V.SymbolicValueId.Map in + let module M = SymbolicValueId.Map in let infos : sv_info M.t ref = ref M.empty in - let lookup_info (sv : V.symbolic_value) : sv_info = - match M.find_opt sv.V.sv_id !infos with + let lookup_info (sv : symbolic_value) : sv_info = + match M.find_opt sv.sv_id !infos with | Some info -> info | None -> { ty = sv.sv_ty; env_count = 0; aproj_borrows = []; aproj_loans = [] } in - let update_info (sv : V.symbolic_value) (info : sv_info) = + let update_info (sv : symbolic_value) (info : sv_info) = infos := M.add sv.sv_id info !infos in - let add_env_sv (sv : V.symbolic_value) : unit = + let add_env_sv (sv : symbolic_value) : unit = let info = lookup_info sv in let info = { info with env_count = info.env_count + 1 } in update_info sv info in - let add_aproj_borrows (sv : V.symbolic_value) abs_id regions proj_ty + let add_aproj_borrows (sv : symbolic_value) abs_id regions proj_ty as_shared_value : unit = let info = lookup_info sv in let binfo = { abs_id; regions; proj_ty; as_shared_value } in let info = { info with aproj_borrows = binfo :: info.aproj_borrows } in update_info sv info in - let add_aproj_loans (sv : V.symbolic_value) abs_id regions : unit = + let add_aproj_loans (sv : symbolic_value) abs_id regions : unit = let info = lookup_info sv in let linfo = { abs_id; regions } in let info = { info with aproj_loans = linfo :: info.aproj_loans } in @@ -746,14 +732,14 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = (* Visitor *) let obj = object - inherit [_] C.iter_eval_ctx as super + inherit [_] iter_eval_ctx as super method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_VSymbolic _ sv = add_env_sv sv method! visit_abstract_shared_borrow abs asb = let abs = Option.get abs in match asb with - | V.AsbBorrow _ -> () + | AsbBorrow _ -> () | AsbProjReborrows (sv, proj_ty) -> add_aproj_borrows sv abs.abs_id abs.regions proj_ty true @@ -772,7 +758,7 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = log#ldebug (lazy ("check_symbolic_values: collected information:\n" - ^ V.SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); + ^ SymbolicValueId.Map.to_string (Some " ") show_sv_info !infos)); (* Check *) let check_info _id info = (* TODO: check that: @@ -798,14 +784,14 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = List.fold_left (fun regions linfo -> let regions = - T.RegionId.Set.fold + RegionId.Set.fold (fun rid regions -> - assert (not (T.RegionId.Set.mem rid regions)); - T.RegionId.Set.add rid regions) + assert (not (RegionId.Set.mem rid regions)); + RegionId.Set.add rid regions) regions linfo.regions in regions) - T.RegionId.Set.empty info.aproj_loans + RegionId.Set.empty info.aproj_loans in (* Check that the union of the loan projectors contains the borrow projections. *) List.iter @@ -818,7 +804,7 @@ let check_symbolic_values (ctx : C.eval_ctx) : unit = M.iter check_info !infos -let check_invariants (ctx : C.eval_ctx) : unit = +let check_invariants (ctx : eval_ctx) : unit = if !Config.check_invariants then ( log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ctx)); check_loans_borrows_relation_invariant ctx; diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index de46320b..01216157 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -1,3 +1,4 @@ +open Types open LlbcAst include Charon.LlbcAstUtils open Collections @@ -20,12 +21,6 @@ let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : | FRegular id -> (FunDeclId.Map.find id fun_decls).signature | FAssumed aid -> Assumed.get_assumed_fun_sig aid -let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : - Names.fun_name = - match fun_id with - | FRegular id -> (FunDeclId.Map.find id fun_decls).name - | FAssumed aid -> Assumed.get_assumed_fun_name aid - (** Return the opaque declarations found in the crate, which are also *not builtin*. [filter_assumed]: if [true], do not consider as opaque the external definitions @@ -34,7 +29,7 @@ let lookup_fun_name (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : Remark: the list of functions also contains the list of opaque global bodies. *) let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : - T.type_decl list * fun_decl list = + type_decl list * fun_decl list = let open ExtractBuiltin in let is_opaque_fun (d : fun_decl) : bool = let sname = name_to_simple_name d.name in @@ -46,15 +41,15 @@ let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : || (not (SimpleNameMap.mem sname builtin_globals_map)) && not (SimpleNameMap.mem sname (builtin_funs_map ()))) in - let is_opaque_type (d : T.type_decl) : bool = + let is_opaque_type (d : type_decl) : bool = let sname = name_to_simple_name d.name in - d.kind = T.Opaque + d.kind = Opaque && ((not filter_assumed) || not (SimpleNameMap.mem sname (builtin_types_map ()))) in (* Note that by checking the function bodies we also the globals *) - ( List.filter is_opaque_type (T.TypeDeclId.Map.values k.types), - List.filter is_opaque_fun (FunDeclId.Map.values k.functions) ) + ( List.filter is_opaque_type (TypeDeclId.Map.values k.type_decls), + List.filter is_opaque_fun (FunDeclId.Map.values k.fun_decls) ) (** Return true if the crate contains opaque declarations, ignoring the assumed definitions. *) diff --git a/compiler/Names.ml b/compiler/Names.ml deleted file mode 100644 index 97dbc180..00000000 --- a/compiler/Names.ml +++ /dev/null @@ -1 +0,0 @@ -include Charon.Names diff --git a/compiler/PrePasses.ml b/compiler/PrePasses.ml index 67063af9..c6b098e6 100644 --- a/compiler/PrePasses.ml +++ b/compiler/PrePasses.ml @@ -2,16 +2,13 @@ (concrete/symbolic) interpreter on it *) -module T = Types -module V = Values -module E = Expressions -module C = Contexts -module A = LlbcAst -module L = Logging +open Types +open Expressions +open LlbcAst open Utils open LlbcAstUtils -let log = L.pre_passes_log +let log = Logging.pre_passes_log (** Rustc inserts a lot of drops before the assignments. @@ -27,11 +24,11 @@ let log = L.pre_passes_log Rem.: we don't use this anymore *) -let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = +let filter_drop_assigns (f : fun_decl) : fun_decl = (* The visitor *) let obj = object (self) - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Sequence env st1 st2 = match (st1.content, st2.content) with @@ -91,7 +88,7 @@ let filter_drop_assigns (f : A.fun_decl) : A.fun_decl = restrictions on the rvalue), fake reads, drops (usually, returns will be followed by such statements) *) -let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = +let remove_useless_cf_merges (crate : crate) (f : fun_decl) : fun_decl = let f0 = f in (* Return [true] if the statement can be moved inside the branches of a switch. * @@ -99,8 +96,7 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = * (inside the encountered sequences) don't need to end with [return] or [panic], * but all the paths inside the whole statement have to. * *) - let rec can_be_moved_aux (must_end_with_exit : bool) (st : A.statement) : bool - = + let rec can_be_moved_aux (must_end_with_exit : bool) (st : statement) : bool = match st.content with | SetDiscriminant _ | Assert _ | Call _ | Break _ | Continue _ | Switch _ | Loop _ -> @@ -120,7 +116,7 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = (* The visitor *) let obj = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Sequence env st1 st2 = match st1.content with @@ -189,14 +185,14 @@ let remove_useless_cf_merges (crate : A.crate) (f : A.fun_decl) : A.fun_decl = }; ]} *) -let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = +let remove_loop_breaks (crate : crate) (f : fun_decl) : fun_decl = let f0 = f in (* Check that a statement doesn't contain loops, breaks or continues *) - let statement_has_no_loop_break_continue (st : A.statement) : bool = + let statement_has_no_loop_break_continue (st : statement) : bool = let obj = object - inherit [_] A.iter_statement + inherit [_] iter_statement method! visit_Loop _ _ = raise Found method! visit_Break _ _ = raise Found method! visit_Continue _ _ = raise Found @@ -212,10 +208,10 @@ let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = break statement breaks exactly one level, and that there are no nested loops. *) - let replace_breaks_with (st : A.statement) (nst : A.statement) : A.statement = + let replace_breaks_with (st : statement) (nst : statement) : statement = let obj = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Loop entered_loop loop = assert (not entered_loop); @@ -232,7 +228,7 @@ let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = (* The visitor *) let obj = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Sequence env st1 st2 = match st1.content with @@ -365,27 +361,27 @@ let remove_loop_breaks (crate : A.crate) (f : A.fun_decl) : A.fun_decl = We then check that [x] completely disappeared from the function body (for sanity). *) -let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = +let remove_shallow_borrows (crate : crate) (f : fun_decl) : fun_decl = let f0 = f in - let filter_in_body (body : A.statement) : A.statement = - let filtered = ref E.VarId.Set.empty in + let filter_in_body (body : statement) : statement = + let filtered = ref VarId.Set.empty in let filter_visitor = object - inherit [_] A.map_statement as super + inherit [_] map_statement as super method! visit_Assign env p rv = match (p.projection, rv) with - | [], E.RvRef (_, E.Shallow) -> + | [], RvRef (_, BShallow) -> (* Filter *) - filtered := E.VarId.Set.add p.var_id !filtered; + filtered := VarId.Set.add p.var_id !filtered; Nop | _ -> (* Don't filter *) super#visit_Assign env p rv method! visit_FakeRead env p = - if p.projection = [] && E.VarId.Set.mem p.var_id !filtered then + if p.projection = [] && VarId.Set.mem p.var_id !filtered then (* Filter *) Nop else super#visit_FakeRead env p @@ -398,8 +394,8 @@ let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = (* Check that the filtered variables completely disappeared from the body *) let check_visitor = object - inherit [_] A.iter_statement - method! visit_var_id _ id = assert (not (E.VarId.Set.mem id !filtered)) + inherit [_] iter_statement + method! visit_var_id _ id = assert (not (VarId.Set.mem id !filtered)) end in check_visitor#visit_statement () body; @@ -423,14 +419,14 @@ let remove_shallow_borrows (crate : A.crate) (f : A.fun_decl) : A.fun_decl = ^ "\n")); f -let apply_passes (crate : A.crate) : A.crate = +let apply_passes (crate : crate) : crate = let passes = [ remove_loop_breaks crate; remove_shallow_borrows crate ] in - let functions = + let fun_decls = List.fold_left - (fun fl pass -> A.FunDeclId.Map.map pass fl) - crate.functions passes + (fun fl pass -> FunDeclId.Map.map pass fl) + crate.fun_decls passes in - let crate = { crate with functions } in + let crate = { crate with fun_decls } in log#ldebug (lazy ("After pre-passes:\n" ^ Print.Crate.crate_to_string crate ^ "\n")); crate diff --git a/compiler/Print.ml b/compiler/Print.ml index 28e940ba..cd83a589 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -1,8 +1,16 @@ include Charon.PrintUtils include Charon.PrintLlbcAst -module V = Values -module VU = ValuesUtils -module C = Contexts +open Charon.PrintPrimitiveValues +open Charon.PrintTypes +open Charon.PrintExpressions +open Charon.PrintLlbcAst.Ast +open Types +open TypesUtils +open Values +open ValuesUtils +open Expressions +open LlbcAst +open Contexts module PrimitiveValues = Charon.PrintPrimitiveValues module Types = Charon.PrintTypes module Expressions = Charon.PrintExpressions @@ -14,63 +22,28 @@ let bool_to_string (b : bool) : string = if b then "true" else "false" (** Pretty-printing for values *) module Values = struct - type value_formatter = { - region_id_to_string : T.RegionId.id -> string; - type_var_id_to_string : T.TypeVarId.id -> string; - type_decl_id_to_string : T.TypeDeclId.id -> string; - const_generic_var_id_to_string : T.ConstGenericVarId.id -> string; - global_decl_id_to_string : T.GlobalDeclId.id -> string; - trait_decl_id_to_string : T.TraitDeclId.id -> string; - trait_impl_id_to_string : T.TraitImplId.id -> string; - trait_clause_id_to_string : T.TraitClauseId.id -> string; - adt_variant_to_string : T.TypeDeclId.id -> T.VariantId.id -> string; - var_id_to_string : E.VarId.id -> string; - adt_field_names : - T.TypeDeclId.id -> T.VariantId.id option -> string list option; - } - - let value_to_type_formatter (fmt : value_formatter) : PT.type_formatter = - { - PT.region_id_to_string = fmt.region_id_to_string; - PT.type_var_id_to_string = fmt.type_var_id_to_string; - PT.type_decl_id_to_string = fmt.type_decl_id_to_string; - PT.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - PT.global_decl_id_to_string = fmt.global_decl_id_to_string; - PT.trait_decl_id_to_string = fmt.trait_decl_id_to_string; - PT.trait_impl_id_to_string = fmt.trait_impl_id_to_string; - PT.trait_clause_id_to_string = fmt.trait_clause_id_to_string; - } - - let var_id_to_string (id : E.VarId.id) : string = - "var@" ^ E.VarId.to_string id + let symbolic_value_id_to_pretty_string (id : SymbolicValueId.id) : string = + "s@" ^ SymbolicValueId.to_string id - let symbolic_value_id_to_string (id : V.SymbolicValueId.id) : string = - "s@" ^ V.SymbolicValueId.to_string id + let symbolic_value_to_string (env : fmt_env) (sv : symbolic_value) : string = + symbolic_value_id_to_pretty_string sv.sv_id + ^ " : " ^ ty_to_string env sv.sv_ty - let symbolic_value_to_string (fmt : PT.type_formatter) (sv : V.symbolic_value) - : string = - symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.ty_to_string fmt sv.sv_ty - - let symbolic_value_proj_to_string (fmt : value_formatter) - (sv : V.symbolic_value) (rty : T.ty) : string = - let ty_fmt = value_to_type_formatter fmt in - symbolic_value_id_to_string sv.sv_id - ^ " : " - ^ PT.ty_to_string ty_fmt sv.sv_ty - ^ " <: " ^ PT.ty_to_string ty_fmt rty + let symbolic_value_proj_to_string (env : fmt_env) (sv : symbolic_value) + (rty : ty) : string = + symbolic_value_id_to_pretty_string sv.sv_id + ^ " : " ^ ty_to_string env sv.sv_ty ^ " <: " ^ ty_to_string env rty (* TODO: it may be a good idea to try to factorize this function with * typed_avalue_to_string. At some point we had done it, because [typed_value] * and [typed_avalue] were instances of the same general type [g_typed_value], * but then we removed this general type because it proved to be a bad idea. *) - let rec typed_value_to_string (fmt : value_formatter) (v : V.typed_value) : - string = - let ty_fmt : PT.type_formatter = value_to_type_formatter fmt in + let rec typed_value_to_string (env : fmt_env) (v : typed_value) : string = match v.value with - | VLiteral cv -> PPV.literal_to_string cv + | VLiteral cv -> literal_to_string cv | VAdt av -> ( let field_values = - List.map (typed_value_to_string fmt) av.field_values + List.map (typed_value_to_string env) av.field_values in match v.ty with | TAdt (TTuple, _) -> @@ -80,11 +53,11 @@ module Values = struct (* "Regular" ADT *) let adt_ident = match av.variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id + | Some vid -> adt_variant_to_string env def_id vid + | None -> type_decl_id_to_string env def_id in if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with + match adt_field_names env def_id av.variant_id with | None -> let field_values = String.concat ", " field_values in adt_ident ^ " (" ^ field_values ^ ")" @@ -105,91 +78,84 @@ module Values = struct | TArray, _ -> (* Happens when we aggregate values *) "@Array[" ^ String.concat ", " field_values ^ "]" - | _ -> - raise (Failure ("Inconsistent value: " ^ V.show_typed_value v))) + | _ -> raise (Failure ("Inconsistent value: " ^ show_typed_value v)) + ) | _ -> raise (Failure "Inconsistent typed value")) - | VBottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | VBorrow bc -> borrow_content_to_string fmt bc - | VLoan lc -> loan_content_to_string fmt lc - | VSymbolic s -> symbolic_value_to_string ty_fmt s + | VBottom -> "⊥ : " ^ ty_to_string env v.ty + | VBorrow bc -> borrow_content_to_string env bc + | VLoan lc -> loan_content_to_string env lc + | VSymbolic s -> symbolic_value_to_string env s - and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : - string = + and borrow_content_to_string (env : fmt_env) (bc : borrow_content) : string = match bc with - | VSharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | VSharedBorrow bid -> "⌊shared@" ^ BorrowId.to_string bid ^ "⌋" | VMutBorrow (bid, tv) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_value_to_string fmt tv + "&mut@" ^ BorrowId.to_string bid ^ " (" + ^ typed_value_to_string env tv ^ ")" - | VReservedMutBorrow bid -> - "⌊reserved_mut@" ^ V.BorrowId.to_string bid ^ "⌋" + | VReservedMutBorrow bid -> "⌊reserved_mut@" ^ BorrowId.to_string bid ^ "⌋" - and loan_content_to_string (fmt : value_formatter) (lc : V.loan_content) : - string = + and loan_content_to_string (env : fmt_env) (lc : loan_content) : string = match lc with | VSharedLoan (loans, v) -> - let loans = V.BorrowId.Set.to_string None loans in - "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string fmt v ^ ")" - | VMutLoan bid -> "⌊mut@" ^ V.BorrowId.to_string bid ^ "⌋" + let loans = BorrowId.Set.to_string None loans in + "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string env v ^ ")" + | VMutLoan bid -> "⌊mut@" ^ BorrowId.to_string bid ^ "⌋" - let abstract_shared_borrow_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrow) : string = + let abstract_shared_borrow_to_string (env : fmt_env) + (abs : abstract_shared_borrow) : string = match abs with - | AsbBorrow bid -> V.BorrowId.to_string bid + | AsbBorrow bid -> BorrowId.to_string bid | AsbProjReborrows (sv, rty) -> - "{" ^ symbolic_value_proj_to_string fmt sv rty ^ "}" + "{" ^ symbolic_value_proj_to_string env sv rty ^ "}" - let abstract_shared_borrows_to_string (fmt : value_formatter) - (abs : V.abstract_shared_borrows) : string = + let abstract_shared_borrows_to_string (env : fmt_env) + (abs : abstract_shared_borrows) : string = "{" - ^ String.concat "," (List.map (abstract_shared_borrow_to_string fmt) abs) + ^ String.concat "," (List.map (abstract_shared_borrow_to_string env) abs) ^ "}" - let rec aproj_to_string (fmt : value_formatter) (pv : V.aproj) : string = + let rec aproj_to_string (env : fmt_env) (pv : aproj) : string = match pv with | AProjLoans (sv, given_back) -> let given_back = if given_back = [] then "" else let given_back = List.map snd given_back in - let given_back = List.map (aproj_to_string fmt) given_back in + let given_back = List.map (aproj_to_string env) given_back in " (" ^ String.concat "," given_back ^ ") " in - "⌊" - ^ symbolic_value_to_string (value_to_type_formatter fmt) sv - ^ given_back ^ "⌋" + "⌊" ^ symbolic_value_to_string env sv ^ given_back ^ "⌋" | AProjBorrows (sv, rty) -> - "(" ^ symbolic_value_proj_to_string fmt sv rty ^ ")" + "(" ^ symbolic_value_proj_to_string env sv rty ^ ")" | AEndedProjLoans (_, given_back) -> if given_back = [] then "_" else let given_back = List.map snd given_back in - let given_back = List.map (aproj_to_string fmt) given_back in + let given_back = List.map (aproj_to_string env) given_back in "ended_aproj_loans (" ^ String.concat "," given_back ^ ")" | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" - let rec typed_avalue_to_string (fmt : value_formatter) (v : V.typed_avalue) : - string = - let ty_fmt : PT.type_formatter = value_to_type_formatter fmt in + let rec typed_avalue_to_string (env : fmt_env) (v : typed_avalue) : string = match v.value with | AAdt av -> ( let field_values = - List.map (typed_avalue_to_string fmt) av.field_values + List.map (typed_avalue_to_string env) av.field_values in match v.ty with - | T.TAdt (T.TTuple, _) -> + | TAdt (TTuple, _) -> (* Tuple *) "(" ^ String.concat ", " field_values ^ ")" - | T.TAdt (T.TAdtId def_id, _) -> + | TAdt (TAdtId def_id, _) -> (* "Regular" ADT *) let adt_ident = match av.variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id + | Some vid -> adt_variant_to_string env def_id vid + | None -> type_decl_id_to_string env def_id in if List.length field_values > 0 then - match fmt.adt_field_names def_id av.V.variant_id with + match adt_field_names env def_id av.variant_id with | None -> let field_values = String.concat ", " field_values in adt_ident ^ " (" ^ field_values ^ ")" @@ -203,133 +169,130 @@ module Values = struct let field_values = String.concat " " field_values in adt_ident ^ " { " ^ field_values ^ " }" else adt_ident - | T.TAdt (T.TAssumed aty, _) -> ( + | TAdt (TAssumed aty, _) -> ( (* Assumed type *) match (aty, field_values) with | TBox, [ bv ] -> "@Box(" ^ bv ^ ")" | _ -> raise (Failure "Inconsistent value")) | _ -> raise (Failure "Inconsistent typed value")) - | ABottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty - | ABorrow bc -> aborrow_content_to_string fmt bc - | ALoan lc -> aloan_content_to_string fmt lc - | ASymbolic s -> aproj_to_string fmt s + | ABottom -> "⊥ : " ^ ty_to_string env v.ty + | ABorrow bc -> aborrow_content_to_string env bc + | ALoan lc -> aloan_content_to_string env lc + | ASymbolic s -> aproj_to_string env s | AIgnored -> "_" - and aloan_content_to_string (fmt : value_formatter) (lc : V.aloan_content) : - string = + and aloan_content_to_string (env : fmt_env) (lc : aloan_content) : string = match lc with | AMutLoan (bid, av) -> - "⌊mut@" ^ V.BorrowId.to_string bid ^ ", " - ^ typed_avalue_to_string fmt av + "⌊mut@" ^ BorrowId.to_string bid ^ ", " + ^ typed_avalue_to_string env av ^ "⌋" | ASharedLoan (loans, v, av) -> - let loans = V.BorrowId.Set.to_string None loans in + let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " - ^ typed_value_to_string fmt v + ^ typed_value_to_string env v ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AEndedMutLoan ml -> "@ended_mut_loan{" - ^ typed_avalue_to_string fmt ml.child + ^ typed_avalue_to_string env ml.child ^ "; " - ^ typed_avalue_to_string fmt ml.given_back + ^ typed_avalue_to_string env ml.given_back ^ " }" | AEndedSharedLoan (v, av) -> "@ended_shared_loan(" - ^ typed_value_to_string fmt v + ^ typed_value_to_string env v ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AIgnoredMutLoan (opt_bid, av) -> "@ignored_mut_loan(" - ^ option_to_string V.BorrowId.to_string opt_bid + ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AEndedIgnoredMutLoan ml -> "@ended_ignored_mut_loan{ " - ^ typed_avalue_to_string fmt ml.child + ^ typed_avalue_to_string env ml.child ^ "; " - ^ typed_avalue_to_string fmt ml.given_back + ^ typed_avalue_to_string env ml.given_back ^ "}" | AIgnoredSharedLoan sl -> - "@ignored_shared_loan(" ^ typed_avalue_to_string fmt sl ^ ")" + "@ignored_shared_loan(" ^ typed_avalue_to_string env sl ^ ")" - and aborrow_content_to_string (fmt : value_formatter) (bc : V.aborrow_content) - : string = + and aborrow_content_to_string (env : fmt_env) (bc : aborrow_content) : string + = match bc with | AMutBorrow (bid, av) -> - "&mut@" ^ V.BorrowId.to_string bid ^ " (" - ^ typed_avalue_to_string fmt av + "&mut@" ^ BorrowId.to_string bid ^ " (" + ^ typed_avalue_to_string env av ^ ")" - | ASharedBorrow bid -> "⌊shared@" ^ V.BorrowId.to_string bid ^ "⌋" + | ASharedBorrow bid -> "⌊shared@" ^ BorrowId.to_string bid ^ "⌋" | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" - ^ option_to_string V.BorrowId.to_string opt_bid + ^ option_to_string BorrowId.to_string opt_bid ^ ", " - ^ typed_avalue_to_string fmt av + ^ typed_avalue_to_string env av ^ ")" | AEndedMutBorrow (_mv, child) -> - "@ended_mut_borrow(" ^ typed_avalue_to_string fmt child ^ ")" + "@ended_mut_borrow(" ^ typed_avalue_to_string env child ^ ")" | AEndedIgnoredMutBorrow { child; given_back; given_back_meta = _ } -> "@ended_ignored_mut_borrow{ " - ^ typed_avalue_to_string fmt child + ^ typed_avalue_to_string env child ^ "; " - ^ typed_avalue_to_string fmt given_back + ^ typed_avalue_to_string env given_back ^ ")" | AEndedSharedBorrow -> "@ended_shared_borrow" | AProjSharedBorrow sb -> "@ignored_shared_borrow(" - ^ abstract_shared_borrows_to_string fmt sb + ^ abstract_shared_borrows_to_string env sb ^ ")" - let loop_abs_kind_to_string (kind : V.loop_abs_kind) : string = + let loop_abs_kind_to_string (kind : loop_abs_kind) : string = match kind with | LoopSynthInput -> "LoopSynthInput" | LoopCall -> "LoopCall" - let abs_kind_to_string (kind : V.abs_kind) : string = + let abs_kind_to_string (kind : abs_kind) : string = match kind with - | V.FunCall (fid, rg_id) -> - "FunCall(fid:" ^ V.FunCallId.to_string fid ^ ", rg_id:" - ^ T.RegionGroupId.to_string rg_id + | FunCall (fid, rg_id) -> + "FunCall(fid:" ^ FunCallId.to_string fid ^ ", rg_id:" + ^ RegionGroupId.to_string rg_id ^ ")" | SynthInput rg_id -> - "SynthInput(rg_id:" ^ T.RegionGroupId.to_string rg_id ^ ")" - | SynthRet rg_id -> - "SynthRet(rg_id:" ^ T.RegionGroupId.to_string rg_id ^ ")" + "SynthInput(rg_id:" ^ RegionGroupId.to_string rg_id ^ ")" + | SynthRet rg_id -> "SynthRet(rg_id:" ^ RegionGroupId.to_string rg_id ^ ")" | Loop (lp_id, rg_id, abs_kind) -> - "Loop(loop_id:" ^ V.LoopId.to_string lp_id ^ ", rg_id:" - ^ option_to_string T.RegionGroupId.to_string rg_id + "Loop(loop_id:" ^ LoopId.to_string lp_id ^ ", rg_id:" + ^ option_to_string RegionGroupId.to_string rg_id ^ ", loop abs kind: " ^ loop_abs_kind_to_string abs_kind ^ ")" | Identity -> "Identity" - let abs_to_string (fmt : value_formatter) (verbose : bool) (indent : string) - (indent_incr : string) (abs : V.abs) : string = + let abs_to_string (env : fmt_env) (verbose : bool) (indent : string) + (indent_incr : string) (abs : abs) : string = let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues + List.map (fun av -> indent2 ^ typed_avalue_to_string env av) abs.avalues in let avs = String.concat ",\n" avs in let kind = if verbose then "[kind:" ^ abs_kind_to_string abs.kind ^ "]" else "" in indent ^ "abs@" - ^ V.AbstractionId.to_string abs.abs_id + ^ AbstractionId.to_string abs.abs_id ^ kind ^ "{parents=" - ^ V.AbstractionId.Set.to_string None abs.parents + ^ AbstractionId.Set.to_string None abs.parents ^ "}" ^ "{regions=" - ^ T.RegionId.Set.to_string None abs.regions + ^ RegionId.Set.to_string None abs.regions ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" - let inst_fun_sig_to_string (fmt : value_formatter) (sg : LlbcAst.inst_fun_sig) - : string = + let inst_fun_sig_to_string (env : fmt_env) (sg : LlbcAst.inst_fun_sig) : + string = (* TODO: print the trait type constraints? *) - let ty_fmt = value_to_type_formatter fmt in - let ty_to_string = PT.ty_to_string ty_fmt in + let ty_to_string = ty_to_string env in let inputs = "(" ^ String.concat ", " (List.map ty_to_string sg.inputs) ^ ")" @@ -338,71 +301,67 @@ module Values = struct inputs ^ " -> " ^ output end -module PV = Values (* local module *) - (** Pretty-printing for contexts *) module Contexts = struct - let var_binder_to_string (bv : C.var_binder) : string = + open Values + + let var_binder_to_string (env : fmt_env) (bv : var_binder) : string = match bv.name with - | None -> PV.var_id_to_string bv.index - | Some name -> name ^ "^" ^ E.VarId.to_string bv.index + | None -> var_id_to_string env bv.index + | Some name -> name ^ "^" ^ VarId.to_string bv.index - let dummy_var_id_to_string (bid : C.DummyVarId.id) : string = - "_@" ^ C.DummyVarId.to_string bid + let dummy_var_id_to_string (bid : DummyVarId.id) : string = + "_@" ^ DummyVarId.to_string bid - let binder_to_string (bv : C.binder) : string = + let binder_to_string (env : fmt_env) (bv : binder) : string = match bv with - | BVar b -> var_binder_to_string b + | BVar b -> var_binder_to_string env b | BDummy bid -> dummy_var_id_to_string bid - let env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) + let env_elem_to_string (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : C.env_elem) : string = + (ev : env_elem) : string = match ev with | EBinding (var, tv) -> - let bv = binder_to_string var in + let bv = binder_to_string env var in let ty = - if with_var_types then - " : " ^ PT.ty_to_string (PV.value_to_type_formatter fmt) tv.V.ty - else "" + if with_var_types then " : " ^ ty_to_string env tv.ty else "" in - indent ^ bv ^ ty ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | EAbs abs -> PV.abs_to_string fmt verbose indent indent_incr abs + indent ^ bv ^ ty ^ " -> " ^ typed_value_to_string env tv ^ " ;" + | EAbs abs -> abs_to_string env verbose indent indent_incr abs | EFrame -> raise (Failure "Can't print a Frame element") - let opt_env_elem_to_string (fmt : PV.value_formatter) (verbose : bool) + let opt_env_elem_to_string (env : fmt_env) (verbose : bool) (with_var_types : bool) (indent : string) (indent_incr : string) - (ev : C.env_elem option) : string = + (ev : env_elem option) : string = match ev with | None -> indent ^ "..." | Some ev -> - env_elem_to_string fmt verbose with_var_types indent indent_incr ev + env_elem_to_string env verbose with_var_types indent indent_incr ev (** Filters "dummy" bindings from an environment, to gain space and clarity/ See [env_to_string]. *) - let filter_env (env : C.env) : C.env_elem option list = + let filter_env (env : env) : env_elem option list = (* We filter: * - non-dummy bindings which point to ⊥ * - dummy bindings which don't contain loans nor borrows * Note that the first case can sometimes be confusing: we may try to improve * it... *) - let filter_elem (ev : C.env_elem) : C.env_elem option = + let filter_elem (ev : env_elem) : env_elem option = match ev with | EBinding (BVar _, tv) -> (* Not a dummy binding: check if the value is ⊥ *) - if VU.is_bottom tv.value then None else Some ev + if is_bottom tv.value then None else Some ev | EBinding (BDummy _, tv) -> (* Dummy binding: check if the value contains borrows or loans *) - if VU.borrows_in_value tv || VU.loans_in_value tv then Some ev - else None + if borrows_in_value tv || loans_in_value tv then Some ev else None | _ -> Some ev in let env = List.map filter_elem env in (* We collapse groups of filtered values - so that we can print one * single "..." for a whole group of filtered values *) - let rec group_filtered (env : C.env_elem option list) : - C.env_elem option list = + let rec group_filtered (env : env_elem option list) : env_elem option list = match env with | [] -> [] | None :: None :: env -> group_filtered (None :: env) @@ -415,8 +374,8 @@ module Contexts = struct "..." to gain space and clarity. [with_var_types]: if true, print the type of the variables *) - let env_to_string (filter : bool) (fmt : PV.value_formatter) (verbose : bool) - (with_var_types : bool) (env : C.env) : string = + let env_to_string (filter : bool) (fmt_env : fmt_env) (verbose : bool) + (with_var_types : bool) (env : env) : string = let env = if filter then filter_env env else List.map (fun ev -> Some ev) env in @@ -424,124 +383,70 @@ module Contexts = struct ^ String.concat "\n" (List.map (fun ev -> - opt_env_elem_to_string fmt verbose with_var_types " " " " ev) + opt_env_elem_to_string fmt_env verbose with_var_types " " " " ev) env) ^ "\n}" - type ctx_formatter = PV.value_formatter - - let ast_to_ctx_formatter (fmt : PA.ast_formatter) : ctx_formatter = + let decls_ctx_to_fmt_env (ctx : decls_ctx) : fmt_env = + let type_decls = ctx.type_ctx.type_decls in + let fun_decls = ctx.fun_ctx.fun_decls in + let global_decls = ctx.global_ctx.global_decls in + let trait_decls = ctx.trait_decls_ctx.trait_decls in + let trait_impls = ctx.trait_impls_ctx.trait_impls in + let generics = TypesUtils.empty_generic_params in + let preds = TypesUtils.empty_predicates in { - PV.region_id_to_string = fmt.region_id_to_string; - PV.type_var_id_to_string = fmt.type_var_id_to_string; - PV.type_decl_id_to_string = fmt.type_decl_id_to_string; - PV.const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - PV.global_decl_id_to_string = fmt.global_decl_id_to_string; - PV.adt_variant_to_string = fmt.adt_variant_to_string; - PV.var_id_to_string = fmt.var_id_to_string; - PV.adt_field_names = fmt.adt_field_names; - PV.trait_decl_id_to_string = fmt.trait_decl_id_to_string; - PV.trait_impl_id_to_string = fmt.trait_impl_id_to_string; - PV.trait_clause_id_to_string = fmt.trait_clause_id_to_string; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + preds; + locals = []; } - let ast_to_value_formatter (fmt : PA.ast_formatter) : PV.value_formatter = - ast_to_ctx_formatter fmt - - let ctx_to_type_formatter (fmt : ctx_formatter) : PT.type_formatter = - PV.value_to_type_formatter fmt - - let eval_ctx_to_ctx_formatter (ctx : C.eval_ctx) : ctx_formatter = - let region_id_to_string r = PT.region_id_to_string r in - - let type_var_id_to_string vid = - (* The context may be invalid *) - match C.lookup_type_var_opt ctx vid with - | None -> T.TypeVarId.to_string vid - | Some v -> v.name - in - let const_generic_var_id_to_string vid = - match C.lookup_const_generic_var_opt ctx vid with - | None -> T.ConstGenericVarId.to_string vid - | Some v -> v.name - in - let type_decl_id_to_string def_id = - let def = C.ctx_lookup_type_decl ctx def_id in - name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = C.ctx_lookup_global_decl ctx def_id in - name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = C.ctx_lookup_trait_decl ctx def_id in - name_to_string def.name + let eval_ctx_to_fmt_env (ctx : eval_ctx) : fmt_env = + let type_decls = ctx.type_context.type_decls in + let fun_decls = ctx.fun_context.fun_decls in + let global_decls = ctx.global_context.global_decls in + let trait_decls = ctx.trait_decls_context.trait_decls in + let trait_impls = ctx.trait_impls_context.trait_impls in + (* Below: it is always safe to omit fields - if an id can't be found at + printing time, we print the id (in raw form) instead of the name it + designates. *) + let generics : generic_params = + { + types = ctx.type_vars; + (* The regions have been transformed to region groups *) + regions = []; + const_generics = ctx.const_generic_vars; + (* We don't need the trait clauses so we initialize them to empty *) + trait_clauses = []; + } in - let trait_impl_id_to_string def_id = - let def = C.ctx_lookup_trait_impl ctx def_id in - name_to_string def.name - in - let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in - let adt_variant_to_string = - PT.type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_decls - in - let var_id_to_string vid = - let bv = C.ctx_lookup_var_binder ctx vid in - var_binder_to_string bv - in - let adt_field_names = - PT.type_ctx_to_adt_field_names_fun ctx.type_context.type_decls - in - { - region_id_to_string; - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - - let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : PA.ast_formatter = - let ctx_fmt = eval_ctx_to_ctx_formatter ctx in - let adt_field_to_string = - PT.type_ctx_to_adt_field_to_string_fun ctx.type_context.type_decls - in - let fun_decl_id_to_string def_id = - let def = C.ctx_lookup_fun_decl ctx def_id in - fun_name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = C.ctx_lookup_global_decl ctx def_id in - global_name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = C.ctx_lookup_trait_decl ctx def_id in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = C.ctx_lookup_trait_impl ctx def_id in - name_to_string def.name + (* We don't need the predicates so we initialize them to empty *) + let preds = empty_predicates in + (* For the locals: we retrieve the information from the environment. + Note that the locals don't need to be ordered based on their indices. + *) + let rec env_to_locals (env : env) : (VarId.id * string option) list = + match env with + | [] | EFrame :: _ -> [] + | EAbs _ :: env -> env_to_locals env + | EBinding (BVar b, _) :: env -> (b.index, b.name) :: env_to_locals env + | EBinding (BDummy _, _) :: env -> env_to_locals env in - let trait_clause_id_to_string id = PT.trait_clause_id_to_pretty_string id in + let locals = env_to_locals ctx.env in { - region_id_to_string = ctx_fmt.PV.region_id_to_string; - type_var_id_to_string = ctx_fmt.PV.type_var_id_to_string; - type_decl_id_to_string = ctx_fmt.PV.type_decl_id_to_string; - const_generic_var_id_to_string = ctx_fmt.PV.const_generic_var_id_to_string; - adt_variant_to_string = ctx_fmt.PV.adt_variant_to_string; - var_id_to_string = ctx_fmt.PV.var_id_to_string; - adt_field_names = ctx_fmt.PV.adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + preds; + locals; } (** Split an [env] at every occurrence of [Frame], eliminating those elements. @@ -550,8 +455,8 @@ module Contexts = struct * frames: from the current frame to the first pushed (oldest frame) * values: from the first pushed (oldest) to the last pushed *) - let split_env_according_to_frames (env : C.env) : C.env list = - let rec split_aux (frames : C.env list) (curr_frame : C.env) (env : C.env) = + let split_env_according_to_frames (env : env) : env list = + let rec split_aux (frames : env list) (curr_frame : env) (env : env) = match env with | [] -> if List.length curr_frame > 0 then curr_frame :: frames else frames @@ -561,9 +466,10 @@ module Contexts = struct let frames = split_aux [] [] env in frames - let fmt_eval_ctx_to_string_gen (fmt : ctx_formatter) (verbose : bool) - (filter : bool) (with_var_types : bool) (ctx : C.eval_ctx) : string = - let ended_regions = T.RegionId.Set.to_string None ctx.ended_regions in + let eval_ctx_to_string_gen (verbose : bool) (filter : bool) + (with_var_types : bool) (ctx : eval_ctx) : string = + let fmt_env = eval_ctx_to_fmt_env ctx in + let ended_regions = RegionId.Set.to_string None ctx.ended_regions in let frames = split_env_according_to_frames ctx.env in let num_frames = List.length frames in let frames = @@ -575,149 +481,139 @@ module Contexts = struct List.iter (fun ev -> match ev with - | C.EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 - | C.EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 - | C.EAbs _ -> num_abs := !num_abs + 1 + | EBinding (BDummy _, _) -> num_dummies := !num_abs + 1 + | EBinding (BVar _, _) -> num_bindings := !num_bindings + 1 + | EAbs _ -> num_abs := !num_abs + 1 | _ -> raise (Failure "Unreachable")) f; "\n# Frame " ^ string_of_int i ^ ":" ^ "\n- locals: " ^ string_of_int !num_bindings ^ "\n- dummy bindings: " ^ string_of_int !num_dummies ^ "\n- abstractions: " ^ string_of_int !num_abs ^ "\n" - ^ env_to_string filter fmt verbose with_var_types f + ^ env_to_string filter fmt_env verbose with_var_types f ^ "\n") frames in "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames - let eval_ctx_to_string_gen (verbose : bool) (filter : bool) - (with_var_types : bool) (ctx : C.eval_ctx) : string = - let fmt = eval_ctx_to_ctx_formatter ctx in - fmt_eval_ctx_to_string_gen fmt verbose filter with_var_types ctx - - let eval_ctx_to_string (ctx : C.eval_ctx) : string = + let eval_ctx_to_string (ctx : eval_ctx) : string = eval_ctx_to_string_gen false true true ctx - let eval_ctx_to_string_no_filter (ctx : C.eval_ctx) : string = + let eval_ctx_to_string_no_filter (ctx : eval_ctx) : string = eval_ctx_to_string_gen false false true ctx end -module PC = Contexts (* local module *) - (** Pretty-printing for LLBC ASTs (functions based on an evaluation context) *) -module EvalCtxLlbcAst = struct - let ty_to_string (ctx : C.eval_ctx) (t : T.ty) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.ty_to_string fmt t +module EvalCtx = struct + open Values + open Contexts - let generic_params_to_strings (ctx : C.eval_ctx) (x : T.generic_params) : - string list * string list = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.generic_params_to_strings fmt x + let name_to_string (ctx : eval_ctx) (n : name) : string = + let env = eval_ctx_to_fmt_env ctx in + name_to_string env n - let generic_args_to_string (ctx : C.eval_ctx) (x : T.generic_args) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.generic_args_to_string fmt x + let ty_to_string (ctx : eval_ctx) (t : ty) : string = + let env = eval_ctx_to_fmt_env ctx in + ty_to_string env t - let trait_ref_to_string (ctx : C.eval_ctx) (x : T.trait_ref) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.trait_ref_to_string fmt x + let generic_params_to_strings (ctx : eval_ctx) (x : generic_params) : + string list * string list = + let env = eval_ctx_to_fmt_env ctx in + generic_params_to_strings env x - let trait_instance_id_to_string (ctx : C.eval_ctx) (x : T.trait_instance_id) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PT.trait_instance_id_to_string fmt x + let generic_args_to_string (ctx : eval_ctx) (x : generic_args) : string = + let env = eval_ctx_to_fmt_env ctx in + generic_args_to_string env x + + let trait_ref_to_string (ctx : eval_ctx) (x : trait_ref) : string = + let env = eval_ctx_to_fmt_env ctx in + trait_ref_to_string env x - let borrow_content_to_string (ctx : C.eval_ctx) (bc : V.borrow_content) : + let trait_instance_id_to_string (ctx : eval_ctx) (x : trait_instance_id) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.borrow_content_to_string fmt bc + let env = eval_ctx_to_fmt_env ctx in + trait_instance_id_to_string env x - let loan_content_to_string (ctx : C.eval_ctx) (lc : V.loan_content) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.loan_content_to_string fmt lc + let borrow_content_to_string (ctx : eval_ctx) (bc : borrow_content) : string = + let env = eval_ctx_to_fmt_env ctx in + borrow_content_to_string env bc - let aborrow_content_to_string (ctx : C.eval_ctx) (bc : V.aborrow_content) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aborrow_content_to_string fmt bc + let loan_content_to_string (ctx : eval_ctx) (lc : loan_content) : string = + let env = eval_ctx_to_fmt_env ctx in + loan_content_to_string env lc - let aloan_content_to_string (ctx : C.eval_ctx) (lc : V.aloan_content) : string + let aborrow_content_to_string (ctx : eval_ctx) (bc : aborrow_content) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aloan_content_to_string fmt lc + let env = eval_ctx_to_fmt_env ctx in + aborrow_content_to_string env bc - let aproj_to_string (ctx : C.eval_ctx) (p : V.aproj) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.aproj_to_string fmt p + let aloan_content_to_string (ctx : eval_ctx) (lc : aloan_content) : string = + let env = eval_ctx_to_fmt_env ctx in + aloan_content_to_string env lc - let symbolic_value_to_string (ctx : C.eval_ctx) (sv : V.symbolic_value) : - string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - let fmt = PC.ctx_to_type_formatter fmt in - PV.symbolic_value_to_string fmt sv + let aproj_to_string (ctx : eval_ctx) (p : aproj) : string = + let env = eval_ctx_to_fmt_env ctx in + aproj_to_string env p + + let symbolic_value_to_string (ctx : eval_ctx) (sv : symbolic_value) : string = + let env = eval_ctx_to_fmt_env ctx in + symbolic_value_to_string env sv - let typed_value_to_string (ctx : C.eval_ctx) (v : V.typed_value) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.typed_value_to_string fmt v + let typed_value_to_string (ctx : eval_ctx) (v : typed_value) : string = + let env = eval_ctx_to_fmt_env ctx in + typed_value_to_string env v - let typed_avalue_to_string (ctx : C.eval_ctx) (v : V.typed_avalue) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.typed_avalue_to_string fmt v + let typed_avalue_to_string (ctx : eval_ctx) (v : typed_avalue) : string = + let env = eval_ctx_to_fmt_env ctx in + typed_avalue_to_string env v - let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PE.place_to_string fmt op + let place_to_string (ctx : eval_ctx) (op : place) : string = + let env = eval_ctx_to_fmt_env ctx in + place_to_string env op - let operand_to_string (ctx : C.eval_ctx) (op : E.operand) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PE.operand_to_string fmt op + let operand_to_string (ctx : eval_ctx) (op : operand) : string = + let env = eval_ctx_to_fmt_env ctx in + operand_to_string env op - let call_to_string (ctx : C.eval_ctx) (call : A.call) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.call_to_string fmt "" call + let call_to_string (ctx : eval_ctx) (call : call) : string = + let env = eval_ctx_to_fmt_env ctx in + call_to_string env "" call - let fun_decl_to_string (ctx : C.eval_ctx) (f : A.fun_decl) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.fun_decl_to_string fmt "" " " f + let fun_decl_to_string (ctx : eval_ctx) (f : fun_decl) : string = + let env = eval_ctx_to_fmt_env ctx in + fun_decl_to_string env "" " " f - let fun_sig_to_string (ctx : C.eval_ctx) (x : A.fun_sig) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.fun_sig_to_string fmt "" " " x + let fun_sig_to_string (ctx : eval_ctx) (x : fun_sig) : string = + let env = eval_ctx_to_fmt_env ctx in + fun_sig_to_string env "" " " x - let inst_fun_sig_to_string (ctx : C.eval_ctx) (x : LlbcAst.inst_fun_sig) : + let inst_fun_sig_to_string (ctx : eval_ctx) (x : LlbcAst.inst_fun_sig) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - let fmt = PC.ast_to_value_formatter fmt in - PV.inst_fun_sig_to_string fmt x - - let fun_id_or_trait_method_ref_to_string (ctx : C.eval_ctx) - (x : E.fun_id_or_trait_method_ref) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PE.fun_id_or_trait_method_ref_to_string fmt x "..." - - let statement_to_string (ctx : C.eval_ctx) (indent : string) - (indent_incr : string) (e : A.statement) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.statement_to_string fmt indent indent_incr e - - let trait_impl_to_string (ctx : C.eval_ctx) (timpl : A.trait_impl) : string = - let fmt = PC.eval_ctx_to_ast_formatter ctx in - PA.trait_impl_to_string fmt " " " " timpl - - let env_elem_to_string (ctx : C.eval_ctx) (indent : string) - (indent_incr : string) (ev : C.env_elem) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PC.env_elem_to_string fmt false true indent indent_incr ev - - let abs_to_string (ctx : C.eval_ctx) (indent : string) (indent_incr : string) - (abs : V.abs) : string = - let fmt = PC.eval_ctx_to_ctx_formatter ctx in - PV.abs_to_string fmt false indent indent_incr abs + let env = eval_ctx_to_fmt_env ctx in + inst_fun_sig_to_string env x + + let fun_id_or_trait_method_ref_to_string (ctx : eval_ctx) + (x : fun_id_or_trait_method_ref) : string = + let env = eval_ctx_to_fmt_env ctx in + fun_id_or_trait_method_ref_to_string env x "..." + + let statement_to_string (ctx : eval_ctx) (indent : string) + (indent_incr : string) (e : statement) : string = + let env = eval_ctx_to_fmt_env ctx in + statement_to_string env indent indent_incr e + + let trait_impl_to_string (ctx : eval_ctx) (timpl : trait_impl) : string = + let env = eval_ctx_to_fmt_env ctx in + trait_impl_to_string env " " " " timpl + + let env_elem_to_string (ctx : eval_ctx) (indent : string) + (indent_incr : string) (ev : env_elem) : string = + let env = eval_ctx_to_fmt_env ctx in + env_elem_to_string env false true indent indent_incr ev + + let abs_to_string (ctx : eval_ctx) (indent : string) (indent_incr : string) + (abs : abs) : string = + let env = eval_ctx_to_fmt_env ctx in + abs_to_string env false indent indent_incr abs end diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 8b737cb5..e6686951 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -3,80 +3,102 @@ open Pure open PureUtils -type type_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - const_generic_var_id_to_string : ConstGenericVarId.id -> string; - global_decl_id_to_string : GlobalDeclId.id -> string; - trait_decl_id_to_string : TraitDeclId.id -> string; - trait_impl_id_to_string : TraitImplId.id -> string; - trait_clause_id_to_string : TraitClauseId.id -> string; +(** The formatting context for pure definitions uses non-pure definitions + to lookup names. The main reason is that when building the pure definitions + like in [SymbolicToPure] we don't have a pure context available, while + at every stage we have the original LLBC definitions at hand. + *) +type fmt_env = { + type_decls : Types.type_decl TypeDeclId.Map.t; + fun_decls : LlbcAst.fun_decl FunDeclId.Map.t; + global_decls : LlbcAst.global_decl GlobalDeclId.Map.t; + trait_decls : LlbcAst.trait_decl TraitDeclId.Map.t; + trait_impls : LlbcAst.trait_impl TraitImplId.Map.t; + generics : generic_params; + locals : (VarId.id * string option) list; } -type value_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - const_generic_var_id_to_string : ConstGenericVarId.id -> string; - global_decl_id_to_string : GlobalDeclId.id -> string; - adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; - var_id_to_string : VarId.id -> string; - adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - trait_decl_id_to_string : TraitDeclId.id -> string; - trait_impl_id_to_string : TraitImplId.id -> string; - trait_clause_id_to_string : TraitClauseId.id -> string; -} +let var_id_to_pretty_string (id : var_id) : string = "v@" ^ VarId.to_string id + +let type_var_id_to_string (env : fmt_env) (id : type_var_id) : string = + (* Note that the types are not necessarily ordered following their indices *) + match + List.find_opt (fun (x : type_var) -> x.index = id) env.generics.types + with + | None -> Print.Types.type_var_id_to_pretty_string id + | Some x -> Print.Types.type_var_to_string x -let value_to_type_formatter (fmt : value_formatter) : type_formatter = +let const_generic_var_id_to_string (env : fmt_env) (id : const_generic_var_id) : + string = + (* Note that the regions are not necessarily ordered following their indices *) + match + List.find_opt + (fun (x : const_generic_var) -> x.index = id) + env.generics.const_generics + with + | None -> Print.Types.const_generic_var_id_to_pretty_string id + | Some x -> Print.Types.const_generic_var_to_string x + +let var_id_to_string (env : fmt_env) (id : VarId.id) : string = + match List.find_opt (fun (i, _) -> i = id) env.locals with + | None -> var_id_to_pretty_string id + | Some (_, name) -> ( + match name with + | None -> var_id_to_pretty_string id + | Some name -> name ^ "^" ^ VarId.to_string id) + +let trait_clause_id_to_string = Print.Types.trait_clause_id_to_string + +let fmt_env_to_llbc_fmt_env (env : fmt_env) : Print.fmt_env = { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - global_decl_id_to_string = fmt.global_decl_id_to_string; - trait_decl_id_to_string = fmt.trait_decl_id_to_string; - trait_impl_id_to_string = fmt.trait_impl_id_to_string; - trait_clause_id_to_string = fmt.trait_clause_id_to_string; + type_decls = env.type_decls; + fun_decls = env.fun_decls; + global_decls = env.global_decls; + trait_decls = env.trait_decls; + trait_impls = env.trait_impls; + generics = TypesUtils.empty_generic_params; + preds = TypesUtils.empty_predicates; + locals = []; } -(* TODO: we need to store which variables we have encountered so far, and - remove [var_id_to_string]. -*) -type ast_formatter = { - type_var_id_to_string : TypeVarId.id -> string; - type_decl_id_to_string : TypeDeclId.id -> string; - const_generic_var_id_to_string : ConstGenericVarId.id -> string; - adt_variant_to_string : TypeDeclId.id -> VariantId.id -> string; - var_id_to_string : VarId.id -> string; - adt_field_to_string : - TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; - adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - fun_decl_id_to_string : FunDeclId.id -> string; - global_decl_id_to_string : GlobalDeclId.id -> string; - trait_decl_id_to_string : TraitDeclId.id -> string; - trait_impl_id_to_string : TraitImplId.id -> string; - trait_clause_id_to_string : TraitClauseId.id -> string; -} - -let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = +let decls_ctx_to_fmt_env (ctx : Contexts.decls_ctx) : fmt_env = { - type_var_id_to_string = fmt.type_var_id_to_string; - type_decl_id_to_string = fmt.type_decl_id_to_string; - const_generic_var_id_to_string = fmt.const_generic_var_id_to_string; - global_decl_id_to_string = fmt.global_decl_id_to_string; - adt_variant_to_string = fmt.adt_variant_to_string; - var_id_to_string = fmt.var_id_to_string; - adt_field_names = fmt.adt_field_names; - trait_decl_id_to_string = fmt.trait_decl_id_to_string; - trait_impl_id_to_string = fmt.trait_impl_id_to_string; - trait_clause_id_to_string = fmt.trait_clause_id_to_string; + type_decls = ctx.type_ctx.type_decls; + fun_decls = ctx.fun_ctx.fun_decls; + global_decls = ctx.global_ctx.global_decls; + trait_decls = ctx.trait_decls_ctx.trait_decls; + trait_impls = ctx.trait_impls_ctx.trait_impls; + generics = empty_generic_params; + locals = []; } -let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = - let fmt = ast_to_value_formatter fmt in - value_to_type_formatter fmt +let name_to_string (env : fmt_env) = + Print.Types.name_to_string (fmt_env_to_llbc_fmt_env env) + +let type_decl_id_to_string (env : fmt_env) = + Print.Types.type_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let global_decl_id_to_string (env : fmt_env) = + Print.Types.global_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let fun_decl_id_to_string (env : fmt_env) = + Print.Expressions.fun_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let trait_decl_id_to_string (env : fmt_env) = + Print.Types.trait_decl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let trait_impl_id_to_string (env : fmt_env) = + Print.Types.trait_impl_id_to_string (fmt_env_to_llbc_fmt_env env) + +let adt_field_to_string (env : fmt_env) = + Print.Types.adt_field_to_string (fmt_env_to_llbc_fmt_env env) + +let adt_variant_from_type_decl_id_to_string (env : fmt_env) = + Print.Types.adt_variant_to_string (fmt_env_to_llbc_fmt_env env) + +let adt_field_names (env : fmt_env) = + Print.Types.adt_field_names (fmt_env_to_llbc_fmt_env env) -let name_to_string = Print.name_to_string -let fun_name_to_string = Print.fun_name_to_string -let global_name_to_string = Print.global_name_to_string let option_to_string = Print.option_to_string let type_var_to_string = Print.Types.type_var_to_string let const_generic_var_to_string = Print.Types.const_generic_var_to_string @@ -85,110 +107,6 @@ let literal_type_to_string = Print.PrimitiveValues.literal_type_to_string let scalar_value_to_string = Print.PrimitiveValues.scalar_value_to_string let literal_to_string = Print.PrimitiveValues.literal_to_string -(* Remark: not using generic_params on purpose, because we may use parameters - which either come from LLBC or from pure, and the [generic_params] type - for those ASTs is not the same. Note that it works because we actually don't - need to know the trait clauses to print the AST: we can thus ignore them. -*) -let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (global_decls : A.global_decl GlobalDeclId.Map.t) - (trait_decls : A.trait_decl TraitDeclId.Map.t) - (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) - (const_generic_params : const_generic_var list) : type_formatter = - let type_var_id_to_string vid = - let var = TypeVarId.nth type_params vid in - type_var_to_string var - in - let const_generic_var_id_to_string vid = - let var = ConstGenericVarId.nth const_generic_params vid in - const_generic_var_to_string var - in - let type_decl_id_to_string def_id = - let def = TypeDeclId.Map.find def_id type_decls in - name_to_string def.name - in - let global_decl_id_to_string def_id = - let def = GlobalDeclId.Map.find def_id global_decls in - name_to_string def.name - in - let trait_decl_id_to_string def_id = - let def = TraitDeclId.Map.find def_id trait_decls in - name_to_string def.name - in - let trait_impl_id_to_string def_id = - let def = TraitImplId.Map.find def_id trait_impls in - name_to_string def.name - in - let trait_clause_id_to_string id = - Print.PT.trait_clause_id_to_pretty_string id - in - { - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - -(* TODO: there is a bit of duplication with Print.fun_decl_to_ast_formatter. - - TODO: use the pure defs as inputs? Note that it is a bit annoying for the - functions (there is a difference between the forward/backward functions...) - while we only need those definitions to lookup proper names for the def ids. -*) -let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (fun_decls : A.fun_decl FunDeclId.Map.t) - (global_decls : A.global_decl GlobalDeclId.Map.t) - (trait_decls : A.trait_decl TraitDeclId.Map.t) - (trait_impls : A.trait_impl TraitImplId.Map.t) (type_params : type_var list) - (const_generic_params : const_generic_var list) : ast_formatter = - let ({ - type_var_id_to_string; - type_decl_id_to_string; - const_generic_var_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - : type_formatter) = - mk_type_formatter type_decls global_decls trait_decls trait_impls - type_params const_generic_params - in - let adt_variant_to_string = - Print.Types.type_ctx_to_adt_variant_to_string_fun type_decls - in - let var_id_to_string vid = - (* TODO: somehow lookup in the context *) - "^" ^ VarId.to_string vid - in - let adt_field_names = - Print.Types.type_ctx_to_adt_field_names_fun type_decls - in - let adt_field_to_string = - Print.Types.type_ctx_to_adt_field_to_string_fun type_decls - in - let fun_decl_id_to_string def_id = - let def = FunDeclId.Map.find def_id fun_decls in - fun_name_to_string def.name - in - { - type_var_id_to_string; - const_generic_var_id_to_string; - type_decl_id_to_string; - adt_variant_to_string; - var_id_to_string; - adt_field_names; - adt_field_to_string; - fun_decl_id_to_string; - global_decl_id_to_string; - trait_decl_id_to_string; - trait_impl_id_to_string; - trait_clause_id_to_string; - } - let assumed_ty_to_string (aty : assumed_ty) : string = match aty with | TState -> "State" @@ -201,137 +119,135 @@ let assumed_ty_to_string (aty : assumed_ty) : string = | TRawPtr Mut -> "MutRawPtr" | TRawPtr Const -> "ConstRawPtr" -let type_id_to_string (fmt : type_formatter) (id : type_id) : string = +let type_id_to_string (env : fmt_env) (id : type_id) : string = match id with - | TAdtId id -> fmt.type_decl_id_to_string id + | TAdtId id -> type_decl_id_to_string env id | TTuple -> "" | TAssumed aty -> assumed_ty_to_string aty (* TODO: duplicates Charon.PrintTypes.const_generic_to_string *) -let const_generic_to_string (fmt : type_formatter) (cg : T.const_generic) : - string = +let const_generic_to_string (env : fmt_env) (cg : const_generic) : string = match cg with - | CGGlobal id -> fmt.global_decl_id_to_string id - | CGVar id -> fmt.const_generic_var_id_to_string id + | CGGlobal id -> global_decl_id_to_string env id + | CGVar id -> const_generic_var_id_to_string env id | CGValue lit -> literal_to_string lit -let rec ty_to_string (fmt : type_formatter) (inside : bool) (ty : ty) : string = +let rec ty_to_string (env : fmt_env) (inside : bool) (ty : ty) : string = match ty with | TAdt (id, generics) -> ( match id with | TTuple -> - let generics = generic_args_to_strings fmt false generics in + let generics = generic_args_to_strings env false generics in "(" ^ String.concat " * " generics ^ ")" | TAdtId _ | TAssumed _ -> - let generics = generic_args_to_strings fmt true generics in + let generics = generic_args_to_strings env true generics in let generics_s = if generics = [] then "" else " " ^ String.concat " " generics in - let ty_s = type_id_to_string fmt id ^ generics_s in + let ty_s = type_id_to_string env id ^ generics_s in if generics <> [] && inside then "(" ^ ty_s ^ ")" else ty_s) - | TVar tv -> fmt.type_var_id_to_string tv + | TVar tv -> type_var_id_to_string env tv | TLiteral lty -> literal_type_to_string lty | TArrow (arg_ty, ret_ty) -> let ty = - ty_to_string fmt true arg_ty ^ " -> " ^ ty_to_string fmt false ret_ty + ty_to_string env true arg_ty ^ " -> " ^ ty_to_string env false ret_ty in if inside then "(" ^ ty ^ ")" else ty | TTraitType (trait_ref, generics, type_name) -> - let trait_ref = trait_ref_to_string fmt false trait_ref in + let trait_ref = trait_ref_to_string env false trait_ref in let s = if generics = empty_generic_args then trait_ref ^ "::" ^ type_name else - let generics = generic_args_to_string fmt generics in + let generics = generic_args_to_string env generics in "(" ^ trait_ref ^ " " ^ generics ^ ")::" ^ type_name in if inside then "(" ^ s ^ ")" else s -and generic_args_to_strings (fmt : type_formatter) (inside : bool) +and generic_args_to_strings (env : fmt_env) (inside : bool) (generics : generic_args) : string list = - let tys = List.map (ty_to_string fmt inside) generics.types in - let cgs = List.map (const_generic_to_string fmt) generics.const_generics in + let tys = List.map (ty_to_string env inside) generics.types in + let cgs = List.map (const_generic_to_string env) generics.const_generics in let trait_refs = - List.map (trait_ref_to_string fmt inside) generics.trait_refs + List.map (trait_ref_to_string env inside) generics.trait_refs in List.concat [ tys; cgs; trait_refs ] -and generic_args_to_string (fmt : type_formatter) (generics : generic_args) : - string = - String.concat " " (generic_args_to_strings fmt true generics) +and generic_args_to_string (env : fmt_env) (generics : generic_args) : string = + String.concat " " (generic_args_to_strings env true generics) -and trait_ref_to_string (fmt : type_formatter) (inside : bool) (tr : trait_ref) - : string = - let trait_id = trait_instance_id_to_string fmt false tr.trait_id in - let generics = generic_args_to_string fmt tr.generics in +and trait_ref_to_string (env : fmt_env) (inside : bool) (tr : trait_ref) : + string = + let trait_id = trait_instance_id_to_string env false tr.trait_id in + let generics = generic_args_to_string env tr.generics in let s = trait_id ^ generics in if tr.generics = empty_generic_args || not inside then s else "(" ^ s ^ ")" -and trait_instance_id_to_string (fmt : type_formatter) (inside : bool) +and trait_instance_id_to_string (env : fmt_env) (inside : bool) (id : trait_instance_id) : string = match id with | Self -> "Self" - | TraitImpl id -> fmt.trait_impl_id_to_string id - | Clause id -> fmt.trait_clause_id_to_string id + | TraitImpl id -> trait_impl_id_to_string env id + | Clause id -> trait_clause_id_to_string env id | ParentClause (inst_id, _decl_id, clause_id) -> - let inst_id = trait_instance_id_to_string fmt false inst_id in - let clause_id = fmt.trait_clause_id_to_string clause_id in + let inst_id = trait_instance_id_to_string env false inst_id in + let clause_id = trait_clause_id_to_string env clause_id in "parent(" ^ inst_id ^ ")::" ^ clause_id | ItemClause (inst_id, _decl_id, item_name, clause_id) -> - let inst_id = trait_instance_id_to_string fmt false inst_id in - let clause_id = fmt.trait_clause_id_to_string clause_id in + let inst_id = trait_instance_id_to_string env false inst_id in + let clause_id = trait_clause_id_to_string env clause_id in "(" ^ inst_id ^ ")::" ^ item_name ^ "::[" ^ clause_id ^ "]" - | TraitRef tr -> trait_ref_to_string fmt inside tr + | TraitRef tr -> trait_ref_to_string env inside tr | UnknownTrait msg -> "UNKNOWN(" ^ msg ^ ")" -let trait_clause_to_string (fmt : type_formatter) (clause : trait_clause) : - string = - let clause_id = fmt.trait_clause_id_to_string clause.clause_id in - let trait_id = fmt.trait_decl_id_to_string clause.trait_id in - let generics = generic_args_to_strings fmt true clause.generics in +let trait_clause_to_string (env : fmt_env) (clause : trait_clause) : string = + let clause_id = trait_clause_id_to_string env clause.clause_id in + let trait_id = trait_decl_id_to_string env clause.trait_id in + let generics = generic_args_to_strings env true clause.generics in let generics = if generics = [] then "" else " " ^ String.concat " " generics in "[" ^ clause_id ^ "]: " ^ trait_id ^ generics -let generic_params_to_strings (fmt : type_formatter) (generics : generic_params) - : string list = +let generic_params_to_strings (env : fmt_env) (generics : generic_params) : + string list = let tys = List.map type_var_to_string generics.types in let cgs = List.map const_generic_var_to_string generics.const_generics in let trait_clauses = - List.map (trait_clause_to_string fmt) generics.trait_clauses + List.map (trait_clause_to_string env) generics.trait_clauses in List.concat [ tys; cgs; trait_clauses ] -let field_to_string fmt inside (f : field) : string = +let field_to_string env inside (f : field) : string = match f.field_name with - | None -> ty_to_string fmt inside f.field_ty + | None -> ty_to_string env inside f.field_ty | Some field_name -> - let s = field_name ^ " : " ^ ty_to_string fmt false f.field_ty in + let s = field_name ^ " : " ^ ty_to_string env false f.field_ty in if inside then "(" ^ s ^ ")" else s -let variant_to_string fmt (v : variant) : string = +let variant_to_string env (v : variant) : string = v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string fmt false) v.fields) + ^ String.concat ", " (List.map (field_to_string env false) v.fields) ^ ")" -let type_decl_to_string (fmt : type_formatter) (def : type_decl) : string = - let name = name_to_string def.name in +let type_decl_to_string (env : fmt_env) (def : type_decl) : string = + let env = { env with generics = def.generics } in + let name = def.name in let params = if def.generics = empty_generic_params then "" - else " " ^ String.concat " " (generic_params_to_strings fmt def.generics) + else " " ^ String.concat " " (generic_params_to_strings env def.generics) in match def.kind with | Struct fields -> if List.length fields > 0 then let fields = String.concat "," - (List.map (fun f -> "\n " ^ field_to_string fmt false f) fields) + (List.map (fun f -> "\n " ^ field_to_string env false f) fields) in "struct " ^ name ^ params ^ "{" ^ fields ^ "}" else "struct " ^ name ^ params ^ "{}" | Enum variants -> let variants = - List.map (fun v -> "| " ^ variant_to_string fmt v) variants + List.map (fun v -> "| " ^ variant_to_string env v) variants in let variants = String.concat "\n" variants in "enum " ^ name ^ params ^ " =\n" ^ variants @@ -342,48 +258,50 @@ let var_to_varname (v : var) : string = | Some name -> name ^ "^" ^ VarId.to_string v.id | None -> "^" ^ VarId.to_string v.id -let var_to_string (fmt : type_formatter) (v : var) : string = +let var_to_string (env : fmt_env) (v : var) : string = let varname = var_to_varname v in - "(" ^ varname ^ " : " ^ ty_to_string fmt false v.ty ^ ")" + "(" ^ varname ^ " : " ^ ty_to_string env false v.ty ^ ")" -let rec mprojection_to_string (fmt : ast_formatter) (inside : string) +let rec mprojection_to_string (env : fmt_env) (inside : string) (p : mprojection) : string = match p with | [] -> inside | pe :: p' -> ( - let s = mprojection_to_string fmt inside p' in + let s = mprojection_to_string env inside p' in match pe.pkind with | E.ProjTuple _ -> "(" ^ s ^ ")." ^ T.FieldId.to_string pe.field_id | E.ProjAdt (adt_id, opt_variant_id) -> ( let field_name = - match fmt.adt_field_to_string adt_id opt_variant_id pe.field_id with + match adt_field_to_string env adt_id opt_variant_id pe.field_id with | Some field_name -> field_name | None -> T.FieldId.to_string pe.field_id in match opt_variant_id with | None -> "(" ^ s ^ ")." ^ field_name | Some variant_id -> - let variant_name = fmt.adt_variant_to_string adt_id variant_id in + let variant_name = + adt_variant_from_type_decl_id_to_string env adt_id variant_id + in "(" ^ s ^ " as " ^ variant_name ^ ")." ^ field_name)) -let mplace_to_string (fmt : ast_formatter) (p : mplace) : string = +let mplace_to_string (env : fmt_env) (p : mplace) : string = let name = match p.name with None -> "" | Some name -> name in (* We add the "llbc" suffix to the variable index, because meta-places * use indices of the variables in the original LLBC program, while * regular places use indices for the pure variables: we want to make * this explicit, otherwise it is confusing. *) let name = name ^ "^" ^ E.VarId.to_string p.var_id ^ "llbc" in - mprojection_to_string fmt name p.projection + mprojection_to_string env name p.projection -let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) +let adt_variant_to_string (env : fmt_env) (adt_id : type_id) (variant_id : VariantId.id option) : string = match adt_id with | TTuple -> "Tuple" | TAdtId def_id -> ( (* "Regular" ADT *) match variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id) + | Some vid -> adt_variant_from_type_decl_id_to_string env def_id vid + | None -> type_decl_id_to_string env def_id) | TAssumed aty -> ( (* Assumed type *) match aty with @@ -407,7 +325,7 @@ let adt_variant_to_string (fmt : value_formatter) (adt_id : type_id) else if variant_id = fuel_succ_id then "@Fuel::Succ" else raise (Failure "Unreachable: improper variant id for fuel type")) -let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) +let adt_field_to_string (env : fmt_env) (adt_id : type_id) (field_id : FieldId.id) : string = match adt_id with | TTuple -> @@ -415,7 +333,7 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (* Tuples don't use the opaque field id for the field indices, but [int] *) | TAdtId def_id -> ( (* "Regular" ADT *) - let fields = fmt.adt_field_names def_id None in + let fields = adt_field_names env def_id None in match fields with | None -> FieldId.to_string field_id | Some fields -> FieldId.nth fields field_id) @@ -432,9 +350,9 @@ let adt_field_to_string (fmt : value_formatter) (adt_id : type_id) (** TODO: we don't need a general function anymore (it is now only used for patterns) *) -let adt_g_value_to_string (fmt : value_formatter) - (value_to_string : 'v -> string) (variant_id : VariantId.id option) - (field_values : 'v list) (ty : ty) : string = +let adt_g_value_to_string (env : fmt_env) (value_to_string : 'v -> string) + (variant_id : VariantId.id option) (field_values : 'v list) (ty : ty) : + string = let field_values = List.map value_to_string field_values in match ty with | TAdt (TTuple, _) -> @@ -444,11 +362,11 @@ let adt_g_value_to_string (fmt : value_formatter) (* "Regular" ADT *) let adt_ident = match variant_id with - | Some vid -> fmt.adt_variant_to_string def_id vid - | None -> fmt.type_decl_id_to_string def_id + | Some vid -> adt_variant_from_type_decl_id_to_string env def_id vid + | None -> type_decl_id_to_string env def_id in if field_values <> [] then - match fmt.adt_field_names def_id variant_id with + match adt_field_names env def_id variant_id with | None -> let field_values = String.concat ", " field_values in adt_ident ^ " (" ^ field_values ^ ")" @@ -504,42 +422,38 @@ let adt_g_value_to_string (fmt : value_formatter) let id = assumed_ty_to_string aty in id ^ " [" ^ String.concat "; " field_values ^ "]") | _ -> - let fmt = value_to_type_formatter fmt in raise (Failure ("Inconsistently typed value: expected ADT type but found:" - ^ "\n- ty: " ^ ty_to_string fmt false ty ^ "\n- variant_id: " + ^ "\n- ty: " ^ ty_to_string env false ty ^ "\n- variant_id: " ^ Print.option_to_string VariantId.to_string variant_id)) -let rec typed_pattern_to_string (fmt : ast_formatter) (v : typed_pattern) : - string = +let rec typed_pattern_to_string (env : fmt_env) (v : typed_pattern) : string = match v.value with | PatConstant cv -> literal_to_string cv - | PatVar (v, None) -> var_to_string (ast_to_type_formatter fmt) v + | PatVar (v, None) -> var_to_string env v | PatVar (v, Some mp) -> - let mp = "[@mplace=" ^ mplace_to_string fmt mp ^ "]" in + let mp = "[@mplace=" ^ mplace_to_string env mp ^ "]" in "(" ^ var_to_varname v ^ " " ^ mp ^ " : " - ^ ty_to_string (ast_to_type_formatter fmt) false v.ty + ^ ty_to_string env false v.ty ^ ")" | PatDummy -> "_" | PatAdt av -> - adt_g_value_to_string - (ast_to_value_formatter fmt) - (typed_pattern_to_string fmt) + adt_g_value_to_string env + (typed_pattern_to_string env) av.variant_id av.field_values v.ty -let fun_sig_to_string (fmt : ast_formatter) (sg : fun_sig) : string = - let ty_fmt = ast_to_type_formatter fmt in - let generics = generic_params_to_strings ty_fmt sg.generics in - let inputs = List.map (ty_to_string ty_fmt false) sg.inputs in - let output = ty_to_string ty_fmt false sg.output in +let fun_sig_to_string (env : fmt_env) (sg : fun_sig) : string = + let env = { env with generics = sg.generics } in + let generics = generic_params_to_strings env sg.generics in + let inputs = List.map (ty_to_string env false) sg.inputs in + let output = ty_to_string env false sg.output in let all_types = List.concat [ generics; inputs; [ output ] ] in String.concat " -> " all_types -let inst_fun_sig_to_string (fmt : ast_formatter) (sg : inst_fun_sig) : string = - let ty_fmt = ast_to_type_formatter fmt in - let inputs = List.map (ty_to_string ty_fmt false) sg.inputs in - let output = ty_to_string ty_fmt false sg.output in +let inst_fun_sig_to_string (env : fmt_env) (sg : inst_fun_sig) : string = + let inputs = List.map (ty_to_string env false) sg.inputs in + let output = ty_to_string env false sg.output in let all_types = List.append inputs [ output ] in String.concat " -> " all_types @@ -568,10 +482,14 @@ let llbc_assumed_fun_id_to_string (fid : A.assumed_fun_id) : string = | ArrayToSliceShared -> "@ArrayToSliceShared" | ArrayToSliceMut -> "@ArrayToSliceMut" | ArrayRepeat -> "@ArrayRepeat" - | SliceLen -> "@SliceLen" | SliceIndexShared -> "@SliceIndexShared" | SliceIndexMut -> "@SliceIndexMut" +let llbc_fun_id_to_string (env : fmt_env) (fid : A.fun_id) : string = + match fid with + | FRegular fid -> fun_decl_id_to_string env fid + | FAssumed fid -> llbc_assumed_fun_id_to_string fid + let pure_assumed_fun_id_to_string (fid : pure_assumed_fun_id) : string = match fid with | Return -> "return" @@ -580,16 +498,15 @@ let pure_assumed_fun_id_to_string (fid : pure_assumed_fun_id) : string = | FuelDecrease -> "fuel_decrease" | FuelEqZero -> "fuel_eq_zero" -let regular_fun_id_to_string (fmt : ast_formatter) (fun_id : fun_id) : string = +let regular_fun_id_to_string (env : fmt_env) (fun_id : fun_id) : string = match fun_id with | FromLlbc (fid, lp_id, rg_id) -> let f = match fid with - | FunId (FRegular fid) -> fmt.fun_decl_id_to_string fid + | FunId (FRegular fid) -> fun_decl_id_to_string env fid | FunId (FAssumed fid) -> llbc_assumed_fun_id_to_string fid | TraitMethod (trait_ref, method_name, _) -> - let fmt = ast_to_type_formatter fmt in - trait_ref_to_string fmt true trait_ref ^ "." ^ method_name + trait_ref_to_string env true trait_ref ^ "." ^ method_name in f ^ fun_suffix lp_id rg_id | Pure fid -> pure_assumed_fun_id_to_string fid @@ -604,60 +521,59 @@ let unop_to_string (unop : unop) : string = let binop_to_string = Print.Expressions.binop_to_string -let fun_or_op_id_to_string (fmt : ast_formatter) (fun_id : fun_or_op_id) : - string = +let fun_or_op_id_to_string (env : fmt_env) (fun_id : fun_or_op_id) : string = match fun_id with - | Fun fun_id -> regular_fun_id_to_string fmt fun_id + | Fun fun_id -> regular_fun_id_to_string env fun_id | Unop unop -> unop_to_string unop | Binop (binop, int_ty) -> binop_to_string binop ^ "<" ^ integer_type_to_string int_ty ^ ">" (** [inside]: controls the introduction of parentheses *) -let rec texpression_to_string (fmt : ast_formatter) (inside : bool) - (indent : string) (indent_incr : string) (e : texpression) : string = +let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) + (indent_incr : string) (e : texpression) : string = match e.e with - | Var var_id -> fmt.var_id_to_string var_id - | CVar cg_id -> fmt.const_generic_var_id_to_string cg_id + | Var var_id -> var_id_to_string env var_id + | CVar cg_id -> const_generic_var_id_to_string env cg_id | Const cv -> literal_to_string cv | App _ -> (* Recursively destruct the app, to have a pair (app, arguments list) *) let app, args = destruct_apps e in (* Convert to string *) - app_to_string fmt inside indent indent_incr app args + app_to_string env inside indent indent_incr app args | Abs _ -> let xl, e = destruct_abs_list e in - let e = abs_to_string fmt indent indent_incr xl e in + let e = abs_to_string env indent indent_incr xl e in if inside then "(" ^ e ^ ")" else e | Qualif _ -> (* Qualifier without arguments *) - app_to_string fmt inside indent indent_incr e [] + app_to_string env inside indent indent_incr e [] | Let (monadic, lv, re, e) -> - let e = let_to_string fmt indent indent_incr monadic lv re e in + let e = let_to_string env indent indent_incr monadic lv re e in if inside then "(" ^ e ^ ")" else e | Switch (scrutinee, body) -> - let e = switch_to_string fmt indent indent_incr scrutinee body in + let e = switch_to_string env indent indent_incr scrutinee body in if inside then "(" ^ e ^ ")" else e | Loop loop -> - let e = loop_to_string fmt indent indent_incr loop in + let e = loop_to_string env indent indent_incr loop in if inside then "(" ^ e ^ ")" else e | StructUpdate supd -> ( let s = match supd.init with | None -> "" - | Some vid -> " " ^ fmt.var_id_to_string vid ^ " with" + | Some vid -> " " ^ var_id_to_string env vid ^ " with" in let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in (* The id should be a custom type decl id or an array *) match supd.struct_id with | TAdtId aid -> - let field_names = Option.get (fmt.adt_field_names aid None) in + let field_names = Option.get (adt_field_names env aid None) in let fields = List.map (fun (fid, fe) -> let field = FieldId.nth field_names fid in let fe = - texpression_to_string fmt false indent2 indent_incr fe + texpression_to_string env false indent2 indent_incr fe in "\n" ^ indent1 ^ field ^ " := " ^ fe ^ ";") supd.updates @@ -668,21 +584,21 @@ let rec texpression_to_string (fmt : ast_formatter) (inside : bool) let fields = List.map (fun (_, fe) -> - texpression_to_string fmt false indent2 indent_incr fe) + texpression_to_string env false indent2 indent_incr fe) supd.updates in "[ " ^ String.concat ", " fields ^ " ]" | _ -> raise (Failure "Unexpected")) | Meta (meta, e) -> ( - let meta_s = meta_to_string fmt meta in - let e = texpression_to_string fmt inside indent indent_incr e in + let meta_s = meta_to_string env meta in + let e = texpression_to_string env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignment _ | Tag _ -> let e = meta_s ^ "\n" ^ indent ^ e in if inside then "(" ^ e ^ ")" else e | MPlace _ -> "(" ^ meta_s ^ " " ^ e ^ ")") -and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) +and app_to_string (env : fmt_env) (inside : bool) (indent : string) (indent_incr : string) (app : texpression) (args : texpression list) : string = (* There are two possibilities: either the [app] is an instantiated, @@ -692,40 +608,37 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) match app.e with | Qualif qualif -> (* Qualifier case *) - let ty_fmt = ast_to_type_formatter fmt in (* Convert the qualifier identifier *) let qualif_s = match qualif.id with - | FunOrOp fun_id -> fun_or_op_id_to_string fmt fun_id - | Global global_id -> fmt.global_decl_id_to_string global_id + | FunOrOp fun_id -> fun_or_op_id_to_string env fun_id + | Global global_id -> global_decl_id_to_string env global_id | AdtCons adt_cons_id -> let variant_s = - adt_variant_to_string - (ast_to_value_formatter fmt) - adt_cons_id.adt_id adt_cons_id.variant_id + adt_variant_to_string env adt_cons_id.adt_id + adt_cons_id.variant_id in ConstStrings.constructor_prefix ^ variant_s | Proj { adt_id; field_id } -> - let value_fmt = ast_to_value_formatter fmt in - let adt_s = adt_variant_to_string value_fmt adt_id None in - let field_s = adt_field_to_string value_fmt adt_id field_id in + let adt_s = adt_variant_to_string env adt_id None in + let field_s = adt_field_to_string env adt_id field_id in (* Adopting an F*-like syntax *) ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s | TraitConst (trait_ref, generics, const_name) -> - let trait_ref = trait_ref_to_string ty_fmt true trait_ref in - let generics_s = generic_args_to_string ty_fmt generics in + let trait_ref = trait_ref_to_string env true trait_ref in + let generics_s = generic_args_to_string env generics in if generics <> empty_generic_args then "(" ^ trait_ref ^ generics_s ^ ")." ^ const_name else trait_ref ^ "." ^ const_name in (* Convert the type instantiation *) - let generics = generic_args_to_strings ty_fmt true qualif.generics in + let generics = generic_args_to_strings env true qualif.generics in (* *) (qualif_s, generics) | _ -> (* "Regular" expression case *) let inside = args <> [] || (args = [] && inside) in - (texpression_to_string fmt inside indent indent_incr app, []) + (texpression_to_string env inside indent indent_incr app, []) in (* Convert the arguments. * The arguments are expressions, so indentation might get weird... (though @@ -733,7 +646,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) let arg_to_string = let inside = true in let indent1 = indent ^ indent_incr in - texpression_to_string fmt inside indent1 indent_incr + texpression_to_string env inside indent1 indent_incr in let args = List.map arg_to_string args in let all_args = List.append generics args in @@ -744,32 +657,31 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) (* Add parentheses *) if all_args <> [] && inside then "(" ^ e ^ ")" else e -and abs_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) +and abs_to_string (env : fmt_env) (indent : string) (indent_incr : string) (xl : typed_pattern list) (e : texpression) : string = - let xl = List.map (typed_pattern_to_string fmt) xl in - let e = texpression_to_string fmt false indent indent_incr e in + let xl = List.map (typed_pattern_to_string env) xl in + let e = texpression_to_string env false indent indent_incr e in "λ " ^ String.concat " " xl ^ ". " ^ e -and let_to_string (fmt : ast_formatter) (indent : string) (indent_incr : string) +and let_to_string (env : fmt_env) (indent : string) (indent_incr : string) (monadic : bool) (lv : typed_pattern) (re : texpression) (e : texpression) : string = let indent1 = indent ^ indent_incr in let inside = false in - let re = texpression_to_string fmt inside indent1 indent_incr re in - let e = texpression_to_string fmt inside indent indent_incr e in - let lv = typed_pattern_to_string fmt lv in + let re = texpression_to_string env inside indent1 indent_incr re in + let e = texpression_to_string env inside indent indent_incr e in + let lv = typed_pattern_to_string env lv in if monadic then lv ^ " <-- " ^ re ^ ";\n" ^ indent ^ e else "let " ^ lv ^ " = " ^ re ^ " in\n" ^ indent ^ e -and switch_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (scrutinee : texpression) (body : switch_body) : - string = +and switch_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (scrutinee : texpression) (body : switch_body) : string = let indent1 = indent ^ indent_incr in (* Printing can mess up on the scrutinee, because it is an expression - but * in most situations it will be a value or a function call, so it should be * ok*) - let scrut = texpression_to_string fmt true indent1 indent_incr scrutinee in - let e_to_string = texpression_to_string fmt false indent1 indent_incr in + let scrut = texpression_to_string env true indent1 indent_incr scrutinee in + let e_to_string = texpression_to_string env false indent1 indent_incr in match body with | If (e_true, e_false) -> let e_true = e_to_string e_true in @@ -778,79 +690,74 @@ and switch_to_string (fmt : ast_formatter) (indent : string) ^ indent ^ "else\n" ^ indent1 ^ e_false | Match branches -> let branch_to_string (b : match_branch) : string = - let pat = typed_pattern_to_string fmt b.pat in + let pat = typed_pattern_to_string env b.pat in indent ^ "| " ^ pat ^ " ->\n" ^ indent1 ^ e_to_string b.branch in let branches = List.map branch_to_string branches in "match " ^ scrut ^ " with\n" ^ String.concat "\n" branches -and loop_to_string (fmt : ast_formatter) (indent : string) - (indent_incr : string) (loop : loop) : string = +and loop_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (loop : loop) : string = let indent1 = indent ^ indent_incr in let indent2 = indent1 ^ indent_incr in - let type_fmt = ast_to_type_formatter fmt in let loop_inputs = "fresh_vars: [" - ^ String.concat "; " (List.map (var_to_string type_fmt) loop.inputs) + ^ String.concat "; " (List.map (var_to_string env) loop.inputs) ^ "]" in let back_output_tys = let tys = match loop.back_output_tys with | None -> "" - | Some tys -> - String.concat "; " - (List.map (ty_to_string (ast_to_type_formatter fmt) false) tys) + | Some tys -> String.concat "; " (List.map (ty_to_string env false) tys) in "back_output_tys: [" ^ tys ^ "]" in let fun_end = - texpression_to_string fmt false indent2 indent_incr loop.fun_end + texpression_to_string env false indent2 indent_incr loop.fun_end in let loop_body = - texpression_to_string fmt false indent2 indent_incr loop.loop_body + texpression_to_string env false indent2 indent_incr loop.loop_body in "loop {\n" ^ indent1 ^ loop_inputs ^ "\n" ^ indent1 ^ back_output_tys ^ "\n" ^ indent1 ^ "fun_end: {\n" ^ indent2 ^ fun_end ^ "\n" ^ indent1 ^ "}\n" ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and meta_to_string (fmt : ast_formatter) (meta : meta) : string = +and meta_to_string (env : fmt_env) (meta : meta) : string = let meta = match meta with | Assignment (lp, rv, rp) -> let rp = match rp with | None -> "" - | Some rp -> " [@src=" ^ mplace_to_string fmt rp ^ "]" + | Some rp -> " [@src=" ^ mplace_to_string env rp ^ "]" in - "@assign(" ^ mplace_to_string fmt lp ^ " := " - ^ texpression_to_string fmt false "" "" rv + "@assign(" ^ mplace_to_string env lp ^ " := " + ^ texpression_to_string env false "" "" rv ^ rp ^ ")" | SymbolicAssignment (var_id, rv) -> "@symb_assign(" ^ VarId.to_string var_id ^ " := " - ^ texpression_to_string fmt false "" "" rv + ^ texpression_to_string env false "" "" rv ^ ")" - | MPlace mp -> "@mplace=" ^ mplace_to_string fmt mp + | MPlace mp -> "@mplace=" ^ mplace_to_string env mp | Tag msg -> "@tag \"" ^ msg ^ "\"" in "@meta[" ^ meta ^ "]" -let fun_decl_to_string (fmt : ast_formatter) (def : fun_decl) : string = - let type_fmt = ast_to_type_formatter fmt in - let name = - fun_name_to_string def.basename ^ fun_suffix def.loop_id def.back_id - in - let signature = fun_sig_to_string fmt def.signature in +let fun_decl_to_string (env : fmt_env) (def : fun_decl) : string = + let env = { env with generics = def.signature.generics } in + let name = def.name ^ fun_suffix def.loop_id def.back_id in + let signature = fun_sig_to_string env def.signature in match def.body with | None -> "val " ^ name ^ " :\n " ^ signature | Some body -> let inside = false in let indent = " " in - let inputs = List.map (var_to_string type_fmt) body.inputs in + let inputs = List.map (var_to_string env) body.inputs in let inputs = if inputs = [] then indent else " fun " ^ String.concat " " inputs ^ " ->\n" ^ indent in - let body = texpression_to_string fmt inside indent indent body.body in + let body = texpression_to_string env inside indent indent body.body in "let " ^ name ^ " :\n " ^ signature ^ " =\n" ^ inputs ^ body diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 72a6400e..fa059499 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -1,6 +1,4 @@ open Identifiers -open Names -module PV = PrimitiveValues module T = Types module V = Values module E = Expressions @@ -35,6 +33,7 @@ IdGen () module ConstGenericVarId = T.ConstGenericVarId +type llbc_name = T.name [@@deriving show, ord] type integer_type = T.integer_type [@@deriving show, ord] type const_generic_var = T.const_generic_var [@@deriving show, ord] type const_generic = T.const_generic [@@deriving show, ord] @@ -381,7 +380,13 @@ type predicates = { trait_type_constraints : trait_type_constraint list } type type_decl = { def_id : TypeDeclId.id; - name : name; + llbc_name : llbc_name; + (** The original name coming from the LLBC declaration *) + name : string; + (** We use the name only for printing purposes (for debugging): + the name used at extraction time will be derived from the + llbc_name. + *) generics : generic_params; kind : type_decl_kind; preds : predicates; @@ -994,11 +999,11 @@ type fun_decl = { loop_id : LoopId.id option; (** [Some] if this definition was generated for a loop *) back_id : T.RegionGroupId.id option; - basename : fun_name; - (** The "base" name of the function. - - The base name is the original name of the Rust function. We add suffixes - (to identify the forward/backward functions) later. + llbc_name : llbc_name; (** The original LLBC name. *) + name : string; + (** We use the name only for printing purposes (for debugging): + the name used at extraction time will be derived from the + llbc_name. *) signature : fun_sig; is_global_decl_body : bool; @@ -1008,7 +1013,8 @@ type fun_decl = { type trait_decl = { def_id : trait_decl_id; - name : name; + llbc_name : llbc_name; + name : string; generics : generic_params; preds : predicates; parent_clauses : trait_clause list; @@ -1021,7 +1027,8 @@ type trait_decl = { type trait_impl = { def_id : trait_impl_id; - name : name; + llbc_name : llbc_name; + name : string; impl_trait : trait_decl_ref; generics : generic_params; preds : predicates; diff --git a/compiler/PureTypeCheck.ml b/compiler/PureTypeCheck.ml index ea1851f0..a62a2361 100644 --- a/compiler/PureTypeCheck.ml +++ b/compiler/PureTypeCheck.ml @@ -63,7 +63,7 @@ type tc_ctx = { let check_literal (v : literal) (ty : literal_type) : unit = match (ty, v) with - | TInteger int_ty, PV.VScalar sv -> assert (int_ty = sv.PV.int_ty) + | TInteger int_ty, VScalar sv -> assert (int_ty = sv.int_ty) | TBool, VBool _ | TChar, VChar _ -> () | _ -> raise (Failure "Inconsistent type") diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 4cc7ef91..5f92d18a 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -15,11 +15,11 @@ end module RegularFunIdMap = Collections.MakeMap (RegularFunIdOrderedType) (** We use this type as a key for lookups *) -type regular_fun_id_not_loop = A.fun_id * T.RegionGroupId.id option +type regular_fun_id_not_loop = LlbcAst.fun_id * RegionGroupId.id option [@@deriving show, ord] (** We use this type as a key for lookups *) -type fun_loop_id = A.FunDeclId.id * LoopId.id option [@@deriving show, ord] +type fun_loop_id = FunDeclId.id * LoopId.id option [@@deriving show, ord] module RegularFunIdNotLoopOrderedType = struct type t = regular_fun_id_not_loop @@ -64,7 +64,7 @@ let dest_arrow_ty (ty : ty) : ty * ty = let compute_literal_type (cv : literal) : literal_type = match cv with - | PV.VScalar sv -> TInteger sv.PV.int_ty + | VScalar sv -> TInteger sv.int_ty | VBool _ -> TBool | VChar _ -> TChar @@ -647,6 +647,7 @@ let trait_decl_is_empty (trait_decl : trait_decl) : bool = let { def_id = _; name = _; + llbc_name = _; generics = _; preds = _; parent_clauses; @@ -664,6 +665,7 @@ let trait_impl_is_empty (trait_impl : trait_impl) : bool = let { def_id = _; name = _; + llbc_name = _; impl_trait = _; generics = _; preds = _; diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index 8227e1fa..e101ba49 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -25,7 +25,6 @@ be grouped together). *) -open Names open Types open TypesUtils open Expressions @@ -42,9 +41,9 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) - (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : name) + (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : string) (sg : fun_sig) : region_groups = - log#ldebug (lazy (__FUNCTION__ ^ ": " ^ name_to_string fun_name)); + log#ldebug (lazy (__FUNCTION__ ^ ": " ^ fun_name)); (* Initialize a normalization context (we may need to normalize some associated types) *) let norm_ctx : AssociatedTypes.norm_ctx = @@ -264,10 +263,23 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) (trait_impls : trait_impl TraitImplId.Map.t) : region_groups FunIdMap.t = + let open Print in + let env : fmt_env = + { + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics = empty_generic_params; + preds = empty_predicates; + locals = []; + } + in let regular = List.map (fun ((fid, d) : FunDeclId.id * fun_decl) -> - (FRegular fid, (d.name, d.signature))) + (FRegular fid, (Types.name_to_string env d.name, d.signature))) (FunDeclId.Map.bindings fun_decls) in let assumed = diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 45edc602..01509dec 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -2,26 +2,26 @@ function bodies, etc. *) -module T = Types -module TU = TypesUtils -module V = Values -module E = Expressions -module A = LlbcAst -module C = Contexts +open Types +open TypesUtils +open Values +open Expressions +open LlbcAst +open Contexts type subst = { - r_subst : T.region -> T.region; - ty_subst : T.TypeVarId.id -> T.ty; - cg_subst : T.ConstGenericVarId.id -> T.const_generic; + r_subst : region -> region; + ty_subst : TypeVarId.id -> ty; + cg_subst : ConstGenericVarId.id -> const_generic; (** Substitution from *local* trait clause to trait instance *) - tr_subst : T.TraitClauseId.id -> T.trait_instance_id; + tr_subst : TraitClauseId.id -> trait_instance_id; (** Substitution for the [Self] trait instance *) - tr_self : T.trait_instance_id; + tr_self : trait_instance_id; } let st_substitute_visitor (subst : subst) = object - inherit [_] A.map_statement + inherit [_] map_statement method! visit_region _ r = subst.r_subst r method! visit_TVar _ id = subst.ty_subst id @@ -43,51 +43,50 @@ let st_substitute_visitor (subst : subst) = **IMPORTANT**: this doesn't normalize the types. *) -let ty_substitute (subst : subst) (ty : T.ty) : T.ty = +let ty_substitute (subst : subst) (ty : ty) : ty = let visitor = st_substitute_visitor subst in visitor#visit_ty () ty (** **IMPORTANT**: this doesn't normalize the types. *) -let trait_ref_substitute (subst : subst) (tr : T.trait_ref) : T.trait_ref = +let trait_ref_substitute (subst : subst) (tr : trait_ref) : trait_ref = let visitor = st_substitute_visitor subst in visitor#visit_trait_ref () tr (** **IMPORTANT**: this doesn't normalize the types. *) -let trait_instance_id_substitute (subst : subst) (tr : T.trait_instance_id) : - T.trait_instance_id = +let trait_instance_id_substitute (subst : subst) (tr : trait_instance_id) : + trait_instance_id = let visitor = st_substitute_visitor subst in visitor#visit_trait_instance_id () tr (** **IMPORTANT**: this doesn't normalize the types. *) -let generic_args_substitute (subst : subst) (g : T.generic_args) : - T.generic_args = +let generic_args_substitute (subst : subst) (g : generic_args) : generic_args = let visitor = st_substitute_visitor subst in visitor#visit_generic_args () g -let predicates_substitute (subst : subst) (p : T.predicates) : T.predicates = +let predicates_substitute (subst : subst) (p : predicates) : predicates = let visitor = st_substitute_visitor subst in visitor#visit_predicates () p let erase_regions_subst : subst = { - r_subst = (fun _ -> T.RErased); - ty_subst = (fun vid -> T.TVar vid); - cg_subst = (fun id -> T.CGVar id); - tr_subst = (fun id -> T.Clause id); - tr_self = T.Self; + r_subst = (fun _ -> RErased); + ty_subst = (fun vid -> TVar vid); + cg_subst = (fun id -> CGVar id); + tr_subst = (fun id -> Clause id); + tr_self = Self; } -(** Convert an {!T.rty} to an {!T.ety} by erasing the region variables *) -let erase_regions (ty : T.ty) : T.ty = ty_substitute erase_regions_subst ty +(** Convert an {!rty} to an {!ety} by erasing the region variables *) +let erase_regions (ty : ty) : ty = ty_substitute erase_regions_subst ty -let trait_ref_erase_regions (tr : T.trait_ref) : T.trait_ref = +let trait_ref_erase_regions (tr : trait_ref) : trait_ref = trait_ref_substitute erase_regions_subst tr -let trait_instance_id_erase_regions (tr : T.trait_instance_id) : - T.trait_instance_id = +let trait_instance_id_erase_regions (tr : trait_instance_id) : trait_instance_id + = trait_instance_id_substitute erase_regions_subst tr -let generic_args_erase_regions (tr : T.generic_args) : T.generic_args = +let generic_args_erase_regions (tr : generic_args) : generic_args = generic_args_substitute erase_regions_subst tr (** Generate fresh regions for region variables. @@ -95,133 +94,124 @@ let generic_args_erase_regions (tr : T.generic_args) : T.generic_args = Return the list of new regions and appropriate substitutions from the original region variables to the fresh regions. - TODO: simplify? we only need the subst [T.RegionVarId.id -> T.RegionId.id] + TODO: simplify? we only need the subst [RegionVarId.id -> RegionId.id] *) -let fresh_regions_with_substs (region_vars : T.region_var list) : - T.RegionId.id list - * (T.RegionId.id -> T.RegionId.id) - * (T.region -> T.region) = +let fresh_regions_with_substs (region_vars : region_var list) : + RegionId.id list * (RegionId.id -> RegionId.id) * (region -> region) = (* Generate fresh regions *) - let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in + let fresh_region_ids = List.map (fun _ -> fresh_region_id ()) region_vars in (* Generate the map from region var ids to regions *) let ls = List.combine region_vars fresh_region_ids in let rid_map = List.fold_left - (fun mp ((k : T.region_var), v) -> T.RegionId.Map.add k.T.index v mp) - T.RegionId.Map.empty ls + (fun mp ((k : region_var), v) -> RegionId.Map.add k.index v mp) + RegionId.Map.empty ls in (* Generate the substitution from region var id to region *) - let rid_subst id = T.RegionId.Map.find id rid_map in + let rid_subst id = RegionId.Map.find id rid_map in (* Generate the substitution from region to region *) - let r_subst (r : T.region) = - match r with - | T.RStatic | T.RErased -> r - | T.RVar id -> T.RVar (rid_subst id) + let r_subst (r : region) = + match r with RStatic | RErased -> r | RVar id -> RVar (rid_subst id) in (* Return *) (fresh_region_ids, rid_subst, r_subst) (** Erase the regions in a type and perform a substitution *) -let erase_regions_substitute_types (ty_subst : T.TypeVarId.id -> T.ty) - (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (ty : T.ty) : T.ty = - let r_subst (_ : T.region) : T.region = T.RErased in +let erase_regions_substitute_types (ty_subst : TypeVarId.id -> ty) + (cg_subst : ConstGenericVarId.id -> const_generic) + (tr_subst : TraitClauseId.id -> trait_instance_id) + (tr_self : trait_instance_id) (ty : ty) : ty = + let r_subst (_ : region) : region = RErased in let subst = { r_subst; ty_subst; cg_subst; tr_subst; tr_self } in ty_substitute subst ty (** Create a region substitution from a list of region variable ids and a list of regions (with which to substitute the region variable ids *) -let make_region_subst (var_ids : T.RegionId.id list) (regions : T.region list) : - T.region -> T.region = +let make_region_subst (var_ids : RegionId.id list) (regions : region list) : + region -> region = let ls = List.combine var_ids regions in let mp = List.fold_left - (fun mp (k, v) -> T.RegionId.Map.add k v mp) - T.RegionId.Map.empty ls + (fun mp (k, v) -> RegionId.Map.add k v mp) + RegionId.Map.empty ls in fun r -> - match r with - | T.RStatic | T.RErased -> r - | T.RVar id -> T.RegionId.Map.find id mp + match r with RStatic | RErased -> r | RVar id -> RegionId.Map.find id mp -let make_region_subst_from_vars (vars : T.region_var list) - (regions : T.region list) : T.region -> T.region = - make_region_subst - (List.map (fun (x : T.region_var) -> x.T.index) vars) - regions +let make_region_subst_from_vars (vars : region_var list) (regions : region list) + : region -> region = + make_region_subst (List.map (fun (x : region_var) -> x.index) vars) regions (** Create a type substitution from a list of type variable ids and a list of types (with which to substitute the type variable ids) *) -let make_type_subst (var_ids : T.TypeVarId.id list) (tys : T.ty list) : - T.TypeVarId.id -> T.ty = +let make_type_subst (var_ids : TypeVarId.id list) (tys : ty list) : + TypeVarId.id -> ty = let ls = List.combine var_ids tys in let mp = List.fold_left - (fun mp (k, v) -> T.TypeVarId.Map.add k v mp) - T.TypeVarId.Map.empty ls + (fun mp (k, v) -> TypeVarId.Map.add k v mp) + TypeVarId.Map.empty ls in - fun id -> T.TypeVarId.Map.find id mp + fun id -> TypeVarId.Map.find id mp -let make_type_subst_from_vars (vars : T.type_var list) (tys : T.ty list) : - T.TypeVarId.id -> T.ty = - make_type_subst (List.map (fun (x : T.type_var) -> x.T.index) vars) tys +let make_type_subst_from_vars (vars : type_var list) (tys : ty list) : + TypeVarId.id -> ty = + make_type_subst (List.map (fun (x : type_var) -> x.index) vars) tys (** Create a const generic substitution from a list of const generic variable ids and a list of const generics (with which to substitute the const generic variable ids) *) -let make_const_generic_subst (var_ids : T.ConstGenericVarId.id list) - (cgs : T.const_generic list) : T.ConstGenericVarId.id -> T.const_generic = +let make_const_generic_subst (var_ids : ConstGenericVarId.id list) + (cgs : const_generic list) : ConstGenericVarId.id -> const_generic = let ls = List.combine var_ids cgs in let mp = List.fold_left - (fun mp (k, v) -> T.ConstGenericVarId.Map.add k v mp) - T.ConstGenericVarId.Map.empty ls + (fun mp (k, v) -> ConstGenericVarId.Map.add k v mp) + ConstGenericVarId.Map.empty ls in - fun id -> T.ConstGenericVarId.Map.find id mp + fun id -> ConstGenericVarId.Map.find id mp -let make_const_generic_subst_from_vars (vars : T.const_generic_var list) - (cgs : T.const_generic list) : T.ConstGenericVarId.id -> T.const_generic = +let make_const_generic_subst_from_vars (vars : const_generic_var list) + (cgs : const_generic list) : ConstGenericVarId.id -> const_generic = make_const_generic_subst - (List.map (fun (x : T.const_generic_var) -> x.T.index) vars) + (List.map (fun (x : const_generic_var) -> x.index) vars) cgs (** Create a trait substitution from a list of trait clause ids and a list of trait refs *) -let make_trait_subst (clause_ids : T.TraitClauseId.id list) - (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = +let make_trait_subst (clause_ids : TraitClauseId.id list) (trs : trait_ref list) + : TraitClauseId.id -> trait_instance_id = let ls = List.combine clause_ids trs in let mp = List.fold_left - (fun mp (k, v) -> T.TraitClauseId.Map.add k (T.TraitRef v) mp) - T.TraitClauseId.Map.empty ls + (fun mp (k, v) -> TraitClauseId.Map.add k (TraitRef v) mp) + TraitClauseId.Map.empty ls in - fun id -> T.TraitClauseId.Map.find id mp + fun id -> TraitClauseId.Map.find id mp -let make_trait_subst_from_clauses (clauses : T.trait_clause list) - (trs : T.trait_ref list) : T.TraitClauseId.id -> T.trait_instance_id = +let make_trait_subst_from_clauses (clauses : trait_clause list) + (trs : trait_ref list) : TraitClauseId.id -> trait_instance_id = make_trait_subst - (List.map (fun (x : T.trait_clause) -> x.T.clause_id) clauses) + (List.map (fun (x : trait_clause) -> x.clause_id) clauses) trs -let make_subst_from_generics (params : T.generic_params) (args : T.generic_args) - (tr_self : T.trait_instance_id) : subst = - let r_subst = make_region_subst_from_vars params.T.regions args.T.regions in - let ty_subst = make_type_subst_from_vars params.T.types args.T.types in +let make_subst_from_generics (params : generic_params) (args : generic_args) + (tr_self : trait_instance_id) : subst = + let r_subst = make_region_subst_from_vars params.regions args.regions in + let ty_subst = make_type_subst_from_vars params.types args.types in let cg_subst = - make_const_generic_subst_from_vars params.T.const_generics - args.T.const_generics + make_const_generic_subst_from_vars params.const_generics args.const_generics in let tr_subst = - make_trait_subst_from_clauses params.T.trait_clauses args.T.trait_refs + make_trait_subst_from_clauses params.trait_clauses args.trait_refs in { r_subst; ty_subst; cg_subst; tr_subst; tr_self } -let make_subst_from_generics_erase_regions (params : T.generic_params) - (generics : T.generic_args) (tr_self : T.trait_instance_id) = +let make_subst_from_generics_erase_regions (params : generic_params) + (generics : generic_args) (tr_self : trait_instance_id) = let generics = generic_args_erase_regions generics in let tr_self = trait_instance_id_erase_regions tr_self in let subst = make_subst_from_generics params generics tr_self in - { subst with r_subst = (fun _ -> T.RErased) } + { subst with r_subst = (fun _ -> RErased) } (** Instantiate the type variables in an ADT definition, and return, for every variant, the list of the types of its fields. @@ -229,27 +219,25 @@ let make_subst_from_generics_erase_regions (params : T.generic_params) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let type_decl_get_instantiated_variants_fields_types (def : T.type_decl) - (generics : T.generic_args) : (T.VariantId.id option * T.ty list) list = +let type_decl_get_instantiated_variants_fields_types (def : type_decl) + (generics : generic_args) : (VariantId.id option * ty list) list = (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let subst = make_subst_from_generics def.T.generics generics tr_self in - let (variants_fields : (T.VariantId.id option * T.field list) list) = - match def.T.kind with - | T.Enum variants -> - List.mapi - (fun i v -> (Some (T.VariantId.of_int i), v.T.fields)) - variants - | T.Struct fields -> [ (None, fields) ] - | T.Opaque -> + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.generics generics tr_self in + let (variants_fields : (VariantId.id option * field list) list) = + match def.kind with + | Enum variants -> + List.mapi (fun i v -> (Some (VariantId.of_int i), v.fields)) variants + | Struct fields -> [ (None, fields) ] + | Opaque -> raise (Failure ("Can't retrieve the variants of an opaque type: " - ^ Names.name_to_string def.name)) + ^ show_name def.name)) in List.map (fun (id, fields) -> - (id, List.map (fun f -> ty_substitute subst f.T.field_ty) fields)) + (id, List.map (fun f -> ty_substitute subst f.field_ty) fields)) variants_fields (** Instantiate the type variables in an ADT definition, and return the list @@ -258,17 +246,16 @@ let type_decl_get_instantiated_variants_fields_types (def : T.type_decl) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let type_decl_get_instantiated_field_types (def : T.type_decl) - (opt_variant_id : T.VariantId.id option) (generics : T.generic_args) : - T.ty list = +let type_decl_get_instantiated_field_types (def : type_decl) + (opt_variant_id : VariantId.id option) (generics : generic_args) : ty list = (* For now, check that there are no clauses - otherwise we might need to normalize the types *) assert (def.generics.trait_clauses = []); (* There shouldn't be any reference to Self *) - let tr_self = T.UnknownTrait __FUNCTION__ in - let subst = make_subst_from_generics def.T.generics generics tr_self in - let fields = TU.type_decl_get_fields def opt_variant_id in - List.map (fun f -> ty_substitute subst f.T.field_ty) fields + let tr_self = UnknownTrait __FUNCTION__ in + let subst = make_subst_from_generics def.generics generics tr_self in + let fields = type_decl_get_fields def opt_variant_id in + List.map (fun f -> ty_substitute subst f.field_ty) fields (** Return the types of the properly instantiated ADT's variant, provided a context. @@ -276,10 +263,10 @@ let type_decl_get_instantiated_field_types (def : T.type_decl) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_get_instantiated_field_types (ctx : C.eval_ctx) - (def_id : T.TypeDeclId.id) (opt_variant_id : T.VariantId.id option) - (generics : T.generic_args) : T.ty list = - let def = C.ctx_lookup_type_decl ctx def_id in +let ctx_adt_get_instantiated_field_types (ctx : eval_ctx) + (def_id : TypeDeclId.id) (opt_variant_id : VariantId.id option) + (generics : generic_args) : ty list = + let def = ctx_lookup_type_decl ctx def_id in type_decl_get_instantiated_field_types def opt_variant_id generics (** Return the types of the properly instantiated ADT value (note that @@ -288,98 +275,94 @@ let ctx_adt_get_instantiated_field_types (ctx : C.eval_ctx) **IMPORTANT**: this function doesn't normalize the types, you may want to use the [AssociatedTypes] equivalent instead. *) -let ctx_adt_value_get_instantiated_field_types (ctx : C.eval_ctx) - (adt : V.adt_value) (id : T.type_id) (generics : T.generic_args) : T.ty list - = +let ctx_adt_value_get_instantiated_field_types (ctx : eval_ctx) + (adt : adt_value) (id : type_id) (generics : generic_args) : ty list = match id with - | T.TAdtId id -> + | TAdtId id -> (* Retrieve the types of the fields *) - ctx_adt_get_instantiated_field_types ctx id adt.V.variant_id generics - | T.TTuple -> + ctx_adt_get_instantiated_field_types ctx id adt.variant_id generics + | TTuple -> assert (generics.regions = []); generics.types - | T.TAssumed aty -> ( + | TAssumed aty -> ( match aty with - | T.TBox -> + | TBox -> assert (generics.regions = []); assert (List.length generics.types = 1); assert (generics.const_generics = []); generics.types - | T.TArray | T.TSlice | T.TStr -> + | TArray | TSlice | TStr -> (* Those types don't have fields *) raise (Failure "Unreachable")) (** Apply a type substitution to a place *) -let place_substitute (subst : subst) (p : E.place) : E.place = +let place_substitute (subst : subst) (p : place) : place = (* There is in fact nothing to do *) (st_substitute_visitor subst)#visit_place () p (** Apply a type substitution to an operand *) -let operand_substitute (subst : subst) (op : E.operand) : E.operand = +let operand_substitute (subst : subst) (op : operand) : operand = (st_substitute_visitor subst)#visit_operand () op (** Apply a type substitution to an rvalue *) -let rvalue_substitute (subst : subst) (rv : E.rvalue) : E.rvalue = +let rvalue_substitute (subst : subst) (rv : rvalue) : rvalue = (st_substitute_visitor subst)#visit_rvalue () rv (** Apply a type substitution to an assertion *) -let assertion_substitute (subst : subst) (a : A.assertion) : A.assertion = +let assertion_substitute (subst : subst) (a : assertion) : assertion = (st_substitute_visitor subst)#visit_assertion () a (** Apply a type substitution to a call *) -let call_substitute (subst : subst) (call : A.call) : A.call = +let call_substitute (subst : subst) (call : call) : call = (st_substitute_visitor subst)#visit_call () call (** Apply a type substitution to a statement *) -let statement_substitute (subst : subst) (st : A.statement) : A.statement = +let statement_substitute (subst : subst) (st : statement) : statement = (st_substitute_visitor subst)#visit_statement () st (** Apply a type substitution to a function body. Return the local variables and the body. *) -let fun_body_substitute_in_body (subst : subst) (body : A.fun_body) : - A.var list * A.statement = +let fun_body_substitute_in_body (subst : subst) (body : fun_body) : + var list * statement = let locals = List.map - (fun (v : A.var) -> { v with A.var_ty = ty_substitute subst v.A.var_ty }) - body.A.locals + (fun (v : var) -> { v with var_ty = ty_substitute subst v.var_ty }) + body.locals in let body = statement_substitute subst body.body in (locals, body) let trait_type_constraint_substitute (subst : subst) - (ttc : T.trait_type_constraint) : T.trait_type_constraint = - let { T.trait_ref; generics; type_name; ty } = ttc in + (ttc : trait_type_constraint) : trait_type_constraint = + let { trait_ref; generics; type_name; ty } = ttc in let visitor = st_substitute_visitor subst in let trait_ref = visitor#visit_trait_ref () trait_ref in let generics = visitor#visit_generic_args () generics in let ty = visitor#visit_ty () ty in - { T.trait_ref; generics; type_name; ty } + { trait_ref; generics; type_name; ty } (** Substitute a function signature, together with the regions hierarchy associated to that signature. **IMPORTANT:** this function doesn't normalize the types. *) -let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) - (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.ty) - (cg_subst : T.ConstGenericVarId.id -> T.const_generic) - (tr_subst : T.TraitClauseId.id -> T.trait_instance_id) - (tr_self : T.trait_instance_id) (sg : A.fun_sig) - (regions_hierarchy : T.region_groups) : A.inst_fun_sig = - let r_subst' (r : T.region) : T.region = - match r with - | T.RStatic | T.RErased -> r - | T.RVar rid -> T.RVar (r_subst rid) +let substitute_signature (asubst : RegionGroupId.id -> AbstractionId.id) + (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) + (cg_subst : ConstGenericVarId.id -> const_generic) + (tr_subst : TraitClauseId.id -> trait_instance_id) + (tr_self : trait_instance_id) (sg : fun_sig) + (regions_hierarchy : region_groups) : inst_fun_sig = + let r_subst' (r : region) : region = + match r with RStatic | RErased -> r | RVar rid -> RVar (r_subst rid) in let subst = { r_subst = r_subst'; ty_subst; cg_subst; tr_subst; tr_self } in - let inputs = List.map (ty_substitute subst) sg.A.inputs in - let output = ty_substitute subst sg.A.output in - let subst_region_group (rg : T.region_group) : A.abs_region_group = + let inputs = List.map (ty_substitute subst) sg.inputs in + let output = ty_substitute subst sg.output in + let subst_region_group (rg : region_group) : abs_region_group = let id = asubst rg.id in let regions = List.map r_subst rg.regions in let parents = List.map asubst rg.parents in - ({ id; regions; parents } : A.abs_region_group) + ({ id; regions; parents } : abs_region_group) in let regions_hierarchy = List.map subst_region_group regions_hierarchy in let trait_type_constraints = @@ -387,13 +370,11 @@ let substitute_signature (asubst : T.RegionGroupId.id -> V.AbstractionId.id) (trait_type_constraint_substitute subst) sg.preds.trait_type_constraints in - { A.inputs; output; regions_hierarchy; trait_type_constraints } + { inputs; output; regions_hierarchy; trait_type_constraints } (** Substitute variable identifiers in a type *) -let statement_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) (ty : T.ty) : - T.ty = - let open T in +let statement_substitute_ids (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) (ty : ty) : ty = let visitor = object inherit [_] map_ty @@ -405,14 +386,14 @@ let statement_substitute_ids (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) visitor#visit_ty () ty -let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) - (asubst : V.AbstractionId.id -> V.AbstractionId.id) = +let subst_ids_visitor (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) + (asubst : AbstractionId.id -> AbstractionId.id) = object (self : 'self) - inherit [_] C.map_env + inherit [_] map_env method! visit_type_var_id _ id = ty_subst id method! visit_const_generic_var_id _ id = cg_subst id method! visit_region_id _ rid = r_subst rid @@ -429,18 +410,17 @@ let subst_ids_visitor (r_subst : T.RegionId.id -> T.RegionId.id) method! visit_abstraction_id _ id = asubst id end -let typed_value_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_value) : - V.typed_value = +let typed_value_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) (v : typed_value) : typed_value = let asubst _ = raise (Failure "Unreachable") in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_value () v -let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) - (v : V.typed_value) : V.typed_value = +let typed_value_subst_rids (r_subst : RegionId.id -> RegionId.id) + (v : typed_value) : typed_value = typed_value_subst_ids r_subst (fun x -> x) (fun x -> x) @@ -448,36 +428,35 @@ let typed_value_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (fun x -> x) v -let typed_avalue_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) (v : V.typed_avalue) : - V.typed_avalue = +let typed_avalue_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) (v : typed_avalue) : typed_avalue = let asubst _ = raise (Failure "Unreachable") in let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_typed_avalue () v -let abs_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) - (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : V.abs) : V.abs = +let abs_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) + (asubst : AbstractionId.id -> AbstractionId.id) (x : abs) : abs = let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_abs () x -let env_subst_ids (r_subst : T.RegionId.id -> T.RegionId.id) - (ty_subst : T.TypeVarId.id -> T.TypeVarId.id) - (cg_subst : T.ConstGenericVarId.id -> T.ConstGenericVarId.id) - (ssubst : V.SymbolicValueId.id -> V.SymbolicValueId.id) - (bsubst : V.BorrowId.id -> V.BorrowId.id) - (asubst : V.AbstractionId.id -> V.AbstractionId.id) (x : C.env) : C.env = +let env_subst_ids (r_subst : RegionId.id -> RegionId.id) + (ty_subst : TypeVarId.id -> TypeVarId.id) + (cg_subst : ConstGenericVarId.id -> ConstGenericVarId.id) + (ssubst : SymbolicValueId.id -> SymbolicValueId.id) + (bsubst : BorrowId.id -> BorrowId.id) + (asubst : AbstractionId.id -> AbstractionId.id) (x : env) : env = let vis = subst_ids_visitor r_subst ty_subst cg_subst ssubst bsubst asubst in vis#visit_env () x -let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) - (x : V.typed_avalue) : V.typed_avalue = +let typed_avalue_subst_rids (r_subst : RegionId.id -> RegionId.id) + (x : typed_avalue) : typed_avalue = let asubst _ = raise (Failure "Unreachable") in let vis = subst_ids_visitor r_subst @@ -489,8 +468,7 @@ let typed_avalue_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) in vis#visit_typed_avalue () x -let env_subst_rids (r_subst : T.RegionId.id -> T.RegionId.id) (x : C.env) : - C.env = +let env_subst_rids (r_subst : RegionId.id -> RegionId.id) (x : env) : env = let vis = subst_ids_visitor r_subst (fun x -> x) diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index d114f18d..7c5d28a7 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -3,10 +3,10 @@ the symbolic execution: we later apply transformations to generate the pure AST that we export. *) -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst +open Types +open Expressions +open Values +open LlbcAst (** "Meta"-place: a place stored as meta-data. @@ -23,16 +23,16 @@ type mplace = { because the most important information in a place is the name of the variable! *) - projection : E.projection; + projection : projection; (** We store the projection because we can, but it is actually not that useful *) } [@@deriving show] type call_id = - | Fun of A.fun_id_or_trait_method_ref * V.FunCallId.id + | Fun of fun_id_or_trait_method_ref * FunCallId.id (** A "regular" function (i.e., a function which is not a primitive operation) *) - | Unop of E.unop - | Binop of E.binop + | Unop of unop + | Binop of binop [@@deriving show, ord] type call = { @@ -42,11 +42,11 @@ type call = { evaluated). We need it to compute the translated values for shared borrows (we need to perform lookups). *) - abstractions : V.AbstractionId.id list; - generics : T.generic_args; - args : V.typed_value list; + abstractions : AbstractionId.id list; + generics : generic_args; + args : typed_value list; args_places : mplace option list; (** Meta information *) - dest : V.symbolic_value; + dest : symbolic_value; dest_place : mplace option; (** Meta information *) } [@@deriving show] @@ -56,14 +56,14 @@ type call = { *) type meta = - | Assignment of Contexts.eval_ctx * mplace * V.typed_value * mplace option + | Assignment of Contexts.eval_ctx * mplace * typed_value * mplace option (** We generated an assignment (destination, assigned value, src) *) [@@deriving show] -type variant_id = T.VariantId.id [@@deriving show] -type global_decl_id = A.GlobalDeclId.id [@@deriving show] -type 'a symbolic_value_id_map = 'a V.SymbolicValueId.Map.t [@@deriving show] -type 'a region_group_id_map = 'a T.RegionGroupId.Map.t [@@deriving show] +type variant_id = VariantId.id [@@deriving show] +type global_decl_id = GlobalDeclId.id [@@deriving show] +type 'a symbolic_value_id_map = 'a SymbolicValueId.Map.t [@@deriving show] +type 'a region_group_id_map = 'a RegionGroupId.Map.t [@@deriving show] (** Ancestor for {!expression} iter visitor. @@ -73,12 +73,12 @@ type 'a region_group_id_map = 'a T.RegionGroupId.Map.t [@@deriving show] *) class ['self] iter_expression_base = object (self : 'self) - inherit [_] V.iter_abs + inherit [_] iter_abs method visit_eval_ctx : 'env -> Contexts.eval_ctx -> unit = fun _ _ -> () method visit_call : 'env -> call -> unit = fun _ _ -> () - method visit_loop_id : 'env -> V.loop_id -> unit = fun _ _ -> () + method visit_loop_id : 'env -> loop_id -> unit = fun _ _ -> () - method visit_region_group_id : 'env -> T.RegionGroupId.id -> unit = + method visit_region_group_id : 'env -> RegionGroupId.id -> unit = fun _ _ -> () method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () @@ -87,7 +87,7 @@ class ['self] iter_expression_base = method visit_region_group_id_map : 'a. ('env -> 'a -> unit) -> 'env -> 'a region_group_id_map -> unit = fun f env m -> - T.RegionGroupId.Map.iter + RegionGroupId.Map.iter (fun id x -> self#visit_region_group_id env id; f env x) @@ -96,18 +96,16 @@ class ['self] iter_expression_base = method visit_symbolic_value_id_map : 'a. ('env -> 'a -> unit) -> 'env -> 'a symbolic_value_id_map -> unit = fun f env m -> - V.SymbolicValueId.Map.iter + SymbolicValueId.Map.iter (fun id x -> self#visit_symbolic_value_id env id; f env x) m - method visit_symbolic_value_id_set : 'env -> V.symbolic_value_id_set -> unit - = - fun env s -> - V.SymbolicValueId.Set.iter (self#visit_symbolic_value_id env) s + method visit_symbolic_value_id_set : 'env -> symbolic_value_id_set -> unit = + fun env s -> SymbolicValueId.Set.iter (self#visit_symbolic_value_id env) s - method visit_symbolic_expansion : 'env -> V.symbolic_expansion -> unit = + method visit_symbolic_expansion : 'env -> symbolic_expansion -> unit = fun _ _ -> () end @@ -116,7 +114,7 @@ class ['self] iter_expression_base = lambda-calculus expressions. *) type expression = - | Return of Contexts.eval_ctx * V.typed_value option + | Return of Contexts.eval_ctx * typed_value option (** There are two cases: - the AST is for a forward function: the typed value should contain the value which was in the return variable @@ -128,22 +126,22 @@ type expression = *) | Panic | FunCall of call * expression - | EndAbstraction of Contexts.eval_ctx * V.abs * expression + | EndAbstraction of Contexts.eval_ctx * abs * expression (** The context is the evaluation context upon ending the abstraction, just after we removed the abstraction from the context. The context is the evaluation context from after evaluating the asserted value. It has the same purpose as for the {!Return} case. *) - | EvalGlobal of global_decl_id * V.symbolic_value * expression + | EvalGlobal of global_decl_id * symbolic_value * expression (** Evaluate a global to a fresh symbolic value *) - | Assertion of Contexts.eval_ctx * V.typed_value * expression + | Assertion of Contexts.eval_ctx * typed_value * expression (** An assertion. The context is the evaluation context from after evaluating the asserted value. It has the same purpose as for the {!Return} case. *) - | Expansion of mplace option * V.symbolic_value * expansion + | Expansion of mplace option * symbolic_value * expansion (** Expansion of a symbolic value. The place is "meta": it gives the path to the symbolic value (if available) @@ -155,7 +153,7 @@ type expression = | IntroSymbolic of Contexts.eval_ctx * mplace option - * V.symbolic_value + * symbolic_value * value_aggregate * expression (** We introduce a new symbolic value, equal to some other value. @@ -171,7 +169,7 @@ type expression = *) | ForwardEnd of Contexts.eval_ctx - * V.typed_value symbolic_value_id_map option + * typed_value symbolic_value_id_map option * expression * expression region_group_id_map (** We use this delimiter to indicate at which point we switch to the @@ -193,7 +191,7 @@ type expression = comments for the {!Return} variant). *) | Loop of loop (** Loop *) - | ReturnWithLoop of V.loop_id * bool + | ReturnWithLoop of loop_id * bool (** End the function with a call to a loop function. This encompasses the cases when we synthesize a function body @@ -205,12 +203,12 @@ type expression = | Meta of meta * expression (** Meta information *) and loop = { - loop_id : V.loop_id; - input_svalues : V.symbolic_value list; (** The input symbolic values *) - fresh_svalues : V.symbolic_value_id_set; + loop_id : loop_id; + input_svalues : symbolic_value list; (** The input symbolic values *) + fresh_svalues : symbolic_value_id_set; (** The symbolic values introduced by the loop fixed-point *) rg_to_given_back_tys : - ((T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t[@opaque]); + ((RegionId.Set.t * ty list) RegionGroupId.Map.t[@opaque]); (** The map from region group ids to the types of the values given back by the corresponding loop abstractions. *) @@ -220,7 +218,7 @@ and loop = { } and expansion = - | ExpandNoBranch of V.symbolic_expansion * expression + | ExpandNoBranch of symbolic_expansion * expression (** A symbolic expansion which doesn't generate a branching. Includes: - concrete expansion @@ -228,25 +226,24 @@ and expansion = *Doesn't* include: - expansion of ADTs with one variant *) - | ExpandAdt of (variant_id option * V.symbolic_value list * expression) list + | ExpandAdt of (variant_id option * symbolic_value list * expression) list (** ADT expansion *) | ExpandBool of expression * expression (** A boolean expansion (i.e, an [if ... then ... else ...]) *) - | ExpandInt of - T.integer_type * (V.scalar_value * expression) list * expression + | ExpandInt of integer_type * (scalar_value * expression) list * expression (** An integer expansion (i.e, a switch over an integer). The last expression is for the "otherwise" branch. *) (* Remark: this type doesn't have to be mutually recursive with the other types, but it makes it easy to generate the visitors *) and value_aggregate = - | VaSingleValue of V.typed_value (** Regular case *) - | VaArray of V.typed_value list + | VaSingleValue of typed_value (** Regular case *) + | VaArray of typed_value list (** This is used when introducing array aggregates *) - | VaCGValue of T.const_generic_var_id + | VaCGValue of const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) - | VaTraitConstValue of T.trait_ref * T.generic_args * string + | VaTraitConstValue of trait_ref * generic_args * string (** A trait constant value *) [@@deriving show, diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 922aa307..2460e040 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2,18 +2,19 @@ open Utils open LlbcAstUtils open Pure open PureUtils +open PrimitiveValues +module T = Types module Id = Identifiers module C = Contexts module A = LlbcAst module S = SymbolicAst module TA = TypesAnalysis -module L = Logging module PP = PrintPure module FA = FunsAnalysis module IU = InterpreterUtils (** The local logger *) -let log = L.symbolic_to_pure_log +let log = Logging.symbolic_to_pure_log type type_context = { llbc_type_decls : T.type_decl TypeDeclId.Map.t; @@ -208,113 +209,92 @@ type bs_ctx = { [@@deriving show] (* TODO: move *) -let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.Ast.ast_formatter = - Print.Ast.decls_and_fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls - ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls - ctx.trait_decls_ctx ctx.trait_impls_ctx ctx.fun_decl - -let bs_ctx_to_ctx_formatter (ctx : bs_ctx) : Print.Contexts.ctx_formatter = - let region_id_to_string = Print.Types.region_id_to_string in - let type_var_id_to_string = Print.Types.type_var_id_to_string in - let var_id_to_string = Print.Expressions.var_id_to_string in - let ast_fmt = bs_ctx_to_ast_formatter ctx in +let bs_ctx_to_fmt_env (ctx : bs_ctx) : Print.fmt_env = + let type_decls = ctx.type_context.llbc_type_decls in + let fun_decls = ctx.fun_context.llbc_fun_decls in + let global_decls = ctx.global_context.llbc_global_decls in + let trait_decls = ctx.trait_decls_ctx in + let trait_impls = ctx.trait_impls_ctx in + let generics = ctx.fun_decl.signature.generics in + let preds = ctx.fun_decl.signature.preds in { - Print.Values.region_id_to_string; - type_var_id_to_string; - type_decl_id_to_string = ast_fmt.type_decl_id_to_string; - const_generic_var_id_to_string = ast_fmt.const_generic_var_id_to_string; - global_decl_id_to_string = ast_fmt.global_decl_id_to_string; - adt_variant_to_string = ast_fmt.adt_variant_to_string; - var_id_to_string; - adt_field_names = ast_fmt.adt_field_names; - trait_decl_id_to_string = ast_fmt.trait_decl_id_to_string; - trait_impl_id_to_string = ast_fmt.trait_impl_id_to_string; - trait_clause_id_to_string = ast_fmt.trait_clause_id_to_string; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + preds; + locals = []; } -let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = - let generics = ctx.fun_decl.signature.generics in +let bs_ctx_to_pure_fmt_env (ctx : bs_ctx) : PrintPure.fmt_env = let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls - ctx.trait_decls_ctx ctx.trait_impls_ctx generics.types - generics.const_generics + let trait_decls = ctx.trait_decls_ctx in + let trait_impls = ctx.trait_impls_ctx in + let generics = ctx.sg.generics in + { + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + generics; + locals = []; + } let ctx_generic_args_to_string (ctx : bs_ctx) (args : T.generic_args) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_type_formatter fmt in - Print.PT.generic_args_to_string fmt args + let env = bs_ctx_to_fmt_env ctx in + Print.Types.generic_args_to_string env args + +let name_to_string (ctx : bs_ctx) = + Print.Types.name_to_string (bs_ctx_to_fmt_env ctx) let symbolic_value_to_string (ctx : bs_ctx) (sv : V.symbolic_value) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_type_formatter fmt in - Print.PV.symbolic_value_to_string fmt sv + let env = bs_ctx_to_fmt_env ctx in + Print.Values.symbolic_value_to_string env sv let typed_value_to_string (ctx : bs_ctx) (v : V.typed_value) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - Print.PV.typed_value_to_string fmt v + let env = bs_ctx_to_fmt_env ctx in + Print.Values.typed_value_to_string env v let pure_ty_to_string (ctx : bs_ctx) (ty : ty) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - let fmt = PrintPure.ast_to_type_formatter fmt in - PrintPure.ty_to_string fmt false ty + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.ty_to_string env false ty let ty_to_string (ctx : bs_ctx) (ty : T.ty) : string = - let fmt = bs_ctx_to_ctx_formatter ctx in - let fmt = Print.PC.ctx_to_type_formatter fmt in - Print.PT.ty_to_string fmt ty + let env = bs_ctx_to_fmt_env ctx in + Print.Types.ty_to_string env ty let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = - let type_decls = ctx.type_context.llbc_type_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_type_formatter type_decls global_decls ctx.trait_decls_ctx - ctx.trait_impls_ctx def.generics.types def.generics.const_generics - in - PrintPure.type_decl_to_string fmt def + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.type_decl_to_string env def let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - PrintPure.texpression_to_string fmt false "" " " e + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.texpression_to_string env false "" " " e let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = - let type_params = sg.generics.types in - let cg_params = sg.generics.const_generics in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls - ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params - in - PrintPure.fun_sig_to_string fmt sg + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.fun_sig_to_string env sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = - let generics = def.signature.generics in - let type_params = generics.types in - let cg_params = generics.const_generics in - let type_decls = ctx.type_context.llbc_type_decls in - let fun_decls = ctx.fun_context.llbc_fun_decls in - let global_decls = ctx.global_context.llbc_global_decls in - let fmt = - PrintPure.mk_ast_formatter type_decls fun_decls global_decls - ctx.trait_decls_ctx ctx.trait_impls_ctx type_params cg_params - in - PrintPure.fun_decl_to_string fmt def + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.fun_decl_to_string env def let typed_pattern_to_string (ctx : bs_ctx) (p : Pure.typed_pattern) : string = - let fmt = bs_ctx_to_pp_ast_formatter ctx in - PrintPure.typed_pattern_to_string fmt p + let env = bs_ctx_to_pure_fmt_env ctx in + PrintPure.typed_pattern_to_string env p (* TODO: move *) let abs_to_string (ctx : bs_ctx) (abs : V.abs) : string = - let fmt = bs_ctx_to_ast_formatter ctx in - let fmt = Print.Contexts.ast_to_value_formatter fmt in + let env = bs_ctx_to_fmt_env ctx in let verbose = false in let indent = "" in let indent_incr = " " in - Print.Values.abs_to_string fmt verbose indent indent_incr abs + Print.Values.abs_to_string env verbose indent indent_incr abs let get_instantiated_fun_sig (fun_id : A.fun_id) (back_id : T.RegionGroupId.id option) (generics : generic_args) @@ -421,7 +401,7 @@ let rec translate_sty (ty : T.ty) : ty = | TNever -> raise (Failure "Unreachable") | TRef (_, rty, _) -> translate rty | TRawPtr (ty, rkind) -> - let mut = match rkind with Mut -> Mut | Shared -> Const in + let mut = match rkind with RMut -> Mut | RShared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in TAdt (TAssumed (TRawPtr mut), generics) @@ -481,21 +461,24 @@ let translate_variant (v : T.variant) : variant = let translate_variants (vl : T.variant list) : variant list = List.map translate_variant vl -(** Translate a type def kind to IM *) +(** Translate a type def kind from LLBC *) let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = match kind with | T.Struct fields -> Struct (translate_fields fields) | T.Enum variants -> Enum (translate_variants variants) | T.Opaque -> Opaque -(** Translate a type definition from IM +(** Translate a type definition from LLBC - TODO: this is not symbolic to pure but IM to pure. Still, I don't see the - point of moving this definition for now. + Remark: this is not symbolic to pure but LLBC to pure. Still, + I don't see the point of moving this definition for now. *) -let translate_type_decl (def : T.type_decl) : type_decl = +let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : + type_decl = + let env = Print.Contexts.decls_ctx_to_fmt_env ctx in let def_id = def.T.def_id in - let name = def.name in + let llbc_name = def.name in + let name = Print.Types.name_to_string env def.name in let { T.regions; types; const_generics; trait_clauses } = def.generics in (* Can't translate types with regions for now *) assert (regions = []); @@ -503,7 +486,7 @@ let translate_type_decl (def : T.type_decl) : type_decl = let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.T.kind in let preds = translate_predicates def.preds in - { def_id; name; generics; kind; preds } + { def_id; llbc_name; name; generics; kind; preds } let translate_type_id (id : T.type_id) : type_id = match id with @@ -564,7 +547,7 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = | TLiteral lty -> TLiteral lty | TRef (_, rty, _) -> translate rty | TRawPtr (ty, rkind) -> - let mut = match rkind with Mut -> Mut | Shared -> Const in + let mut = match rkind with RMut -> Mut | RShared -> Const in let ty = translate ty in let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in TAdt (TAssumed (TRawPtr mut), generics) @@ -655,10 +638,10 @@ let rec translate_back_ty (type_infos : TA.type_infos) | TLiteral lty -> wrap (TLiteral lty) | TRef (r, rty, rkind) -> ( match rkind with - | T.Shared -> + | RShared -> (* Ignore shared references, unless we are below a mutable borrow *) if inside_mut then translate rty else None - | T.Mut -> + | RMut -> (* Dive in, remembering the fact that we are inside a mutable borrow *) let inside_mut = true in if keep_region r then @@ -1034,7 +1017,7 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) effect_info; } in - let preds = translate_predicates sg.A.preds in + let preds = translate_predicates sg.preds in let sg = { generics; preds; inputs; output; doutputs; info } in { sg; output_names } @@ -1795,7 +1778,7 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) log#ldebug (lazy ("translate_end_abstraction_synth_input:" ^ "\n- function: " - ^ Print.name_to_string ctx.fun_decl.name + ^ name_to_string ctx ctx.fun_decl.name ^ "\n- rg_id: " ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " @@ -2109,7 +2092,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) (* Actually the same case as [SynthInput] *) translate_end_abstraction_synth_input ectx abs e ctx rg_id | V.LoopCall -> - let fun_id = E.FRegular ctx.fun_decl.A.def_id in + let fun_id = E.FRegular ctx.fun_decl.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fun_id) (Some vloop_id) (Some rg_id) @@ -2336,7 +2319,7 @@ and translate_expansion (p : S.mplace option) (sv : V.symbolic_value) (* We don't need to update the context: we don't introduce any * new values/variables *) let branch = translate_expression branch_e ctx in - let pat = mk_typed_pattern_from_literal (PV.VScalar v) in + let pat = mk_typed_pattern_from_literal (VScalar v) in { pat; branch } in let branches = List.map translate_branch branches in @@ -2569,7 +2552,7 @@ and translate_forward_end (ectx : C.eval_ctx) let org_args = args in (* Lookup the effect info for the loop function *) - let fid = E.FRegular ctx.fun_decl.A.def_id in + let fid = E.FRegular ctx.fun_decl.def_id in let effect_info = get_fun_effect_info ctx.fun_context.fun_infos (FunId fid) None ctx.bid in @@ -2918,14 +2901,15 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = log#ldebug (lazy ("SymbolicToPure.translate_fun_decl: " - ^ Print.fun_name_to_string def.A.name + ^ name_to_string ctx def.name ^ " (" ^ Print.option_to_string T.RegionGroupId.to_string bid ^ ")\n")); (* Translate the declaration *) - let def_id = def.A.def_id in - let basename = def.name in + let def_id = def.def_id in + let llbc_name = def.name in + let name = name_to_string ctx llbc_name in (* Retrieve the signature *) let signature = ctx.sg in let regions_hierarchy = @@ -2999,7 +2983,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = log#ldebug (lazy ("SymbolicToPure.translate_fun_decl: " - ^ Print.fun_name_to_string def.A.name + ^ name_to_string ctx def.name ^ " (" ^ Print.option_to_string T.RegionGroupId.to_string bid ^ ")" ^ "\n- forward_inputs: " @@ -3030,14 +3014,15 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let loop_id = None in (* Assemble the declaration *) - let def = + let def : fun_decl = { def_id; kind = def.kind; num_loops; loop_id; back_id = bid; - basename; + llbc_name; + name; signature; is_global_decl_body = def.is_global_decl_body; body; @@ -3051,8 +3036,9 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (* return *) def -let translate_type_decls (type_decls : T.type_decl list) : type_decl list = - List.map translate_type_decl type_decls +let translate_type_decls (ctx : Contexts.decls_ctx) + (type_decls : T.type_decl list) : type_decl list = + List.map (translate_type_decl ctx) type_decls (** Translates function signatures. @@ -3105,11 +3091,11 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) (fun m (id, sg) -> RegularFunIdNotLoopMap.add id sg m) RegularFunIdNotLoopMap.empty translated -let translate_trait_decl (type_infos : TA.type_infos) - (trait_decl : A.trait_decl) : trait_decl = +let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) + : trait_decl = let { def_id; - name; + name = llbc_name; generics; preds; parent_clauses; @@ -3120,6 +3106,12 @@ let translate_trait_decl (type_infos : TA.type_infos) } : A.trait_decl = trait_decl in + let type_infos = ctx.type_ctx.type_infos in + let name = + Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env ctx) + llbc_name + in let generics = translate_generic_params generics in let preds = translate_predicates preds in let parent_clauses = List.map translate_trait_clause parent_clauses in @@ -3138,6 +3130,7 @@ let translate_trait_decl (type_infos : TA.type_infos) in { def_id; + llbc_name; name; generics; preds; @@ -3148,11 +3141,11 @@ let translate_trait_decl (type_infos : TA.type_infos) provided_methods; } -let translate_trait_impl (type_infos : TA.type_infos) - (trait_impl : A.trait_impl) : trait_impl = +let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) + : trait_impl = let { A.def_id; - name; + name = llbc_name; impl_trait; generics; preds; @@ -3164,9 +3157,15 @@ let translate_trait_impl (type_infos : TA.type_infos) } = trait_impl in + let type_infos = ctx.type_ctx.type_infos in let impl_trait = translate_trait_decl_ref (translate_fwd_ty type_infos) impl_trait in + let name = + Print.Types.name_to_string + (Print.Contexts.decls_ctx_to_fmt_env ctx) + llbc_name + in let generics = translate_generic_params generics in let preds = translate_predicates preds in let parent_trait_refs = List.map translate_strait_ref parent_trait_refs in @@ -3185,6 +3184,7 @@ let translate_trait_impl (type_infos : TA.type_infos) in { def_id; + llbc_name; name; impl_trait; generics; diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index ddb9d681..38efc53a 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -1,57 +1,52 @@ -module C = Collections -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module A = LlbcAst +open Types +open TypesUtils +open PrimitiveValues +open Expressions +open Values open SymbolicAst -let mk_mplace (p : E.place) (ctx : Contexts.eval_ctx) : mplace = +let mk_mplace (p : place) (ctx : Contexts.eval_ctx) : mplace = let bv = Contexts.ctx_lookup_var_binder ctx p.var_id in { bv; projection = p.projection } -let mk_opt_mplace (p : E.place option) (ctx : Contexts.eval_ctx) : mplace option - = +let mk_opt_mplace (p : place option) (ctx : Contexts.eval_ctx) : mplace option = Option.map (fun p -> mk_mplace p ctx) p -let mk_opt_place_from_op (op : E.operand) (ctx : Contexts.eval_ctx) : +let mk_opt_place_from_op (op : operand) (ctx : Contexts.eval_ctx) : mplace option = - match op with - | E.Copy p | E.Move p -> Some (mk_mplace p ctx) - | E.Constant _ -> None + match op with Copy p | Move p -> Some (mk_mplace p ctx) | Constant _ -> None let mk_meta (m : meta) (e : expression) : expression = Meta (m, e) -let synthesize_symbolic_expansion (sv : V.symbolic_value) - (place : mplace option) (seel : V.symbolic_expansion option list) - (el : expression list option) : expression option = +let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) + (seel : symbolic_expansion option list) (el : expression list option) : + expression option = match el with | None -> None | Some el -> let ls = List.combine seel el in (* Match on the symbolic value type to know which can of expansion happened *) let expansion = - match sv.V.sv_ty with - | T.TLiteral PV.TBool -> ( + match sv.sv_ty with + | TLiteral TBool -> ( (* Boolean expansion: there should be two branches *) match ls with | [ - (Some (V.SeLiteral (PV.VBool true)), true_exp); - (Some (V.SeLiteral (PV.VBool false)), false_exp); + (Some (SeLiteral (VBool true)), true_exp); + (Some (SeLiteral (VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) | _ -> raise (Failure "Ill-formed boolean expansion")) - | T.TLiteral (PV.TInteger int_ty) -> + | TLiteral (TInteger int_ty) -> (* Switch over an integer: split between the "regular" branches and the "otherwise" branch (which should be the last branch) *) - let branches, otherwise = C.List.pop_last ls in + let branches, otherwise = Collections.List.pop_last ls in (* For all the regular branches, the symbolic value should have * been expanded to a constant *) - let get_scalar (see : V.symbolic_expansion option) : V.scalar_value - = + let get_scalar (see : symbolic_expansion option) : scalar_value = match see with - | Some (V.SeLiteral (PV.VScalar cv)) -> - assert (cv.PV.int_ty = int_ty); + | Some (SeLiteral (VScalar cv)) -> + assert (cv.int_ty = int_ty); cv | _ -> raise (Failure "Unreachable") in @@ -64,12 +59,12 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) assert (otherwise_see = None); (* Return *) ExpandInt (int_ty, branches, otherwise) - | T.TAdt (_, _) -> + | TAdt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) - let get_variant (see : V.symbolic_expansion option) : - T.VariantId.id option * V.symbolic_value list = + let get_variant (see : symbolic_expansion option) : + VariantId.id option * symbolic_value list = match see with - | Some (V.SeAdt (vid, fields)) -> (vid, fields) + | Some (SeAdt (vid, fields)) -> (vid, fields) | _ -> raise (Failure "Ill-formed branching ADT expansion") in let exp = @@ -80,29 +75,28 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) ls in ExpandAdt exp - | T.TRef (_, _, _) -> ( + | TRef (_, _, _) -> ( (* Reference expansion: there should be one branch *) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> raise (Failure "Ill-formed borrow expansion")) - | T.TVar _ - | T.TLiteral TChar - | TNever | T.TTraitType _ | T.TArrow _ | T.TRawPtr _ -> + | TVar _ | TLiteral TChar | TNever | TTraitType _ | TArrow _ | TRawPtr _ + -> raise (Failure "Ill-formed symbolic expansion") in Some (Expansion (place, sv, expansion)) -let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) - (place : mplace option) (see : V.symbolic_expansion) (e : expression option) - : expression option = +let synthesize_symbolic_expansion_no_branching (sv : symbolic_value) + (place : mplace option) (see : symbolic_expansion) (e : expression option) : + expression option = let el = Option.map (fun e -> [ e ]) e in synthesize_symbolic_expansion sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (generics : T.generic_args) - (args : V.typed_value list) (args_places : mplace option list) - (dest : V.symbolic_value) (dest_place : mplace option) - (e : expression option) : expression option = + (abstractions : AbstractionId.id list) (generics : generic_args) + (args : typed_value list) (args_places : mplace option list) + (dest : symbolic_value) (dest_place : mplace option) (e : expression option) + : expression option = Option.map (fun e -> let call = @@ -120,58 +114,56 @@ let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) FunCall (call, e)) e -let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) +let synthesize_global_eval (gid : GlobalDeclId.id) (dest : symbolic_value) (e : expression option) : expression option = Option.map (fun e -> EvalGlobal (gid, dest, e)) e -let synthesize_regular_function_call (fun_id : A.fun_id_or_trait_method_ref) - (call_id : V.FunCallId.id) (ctx : Contexts.eval_ctx) - (abstractions : V.AbstractionId.id list) (generics : T.generic_args) - (args : V.typed_value list) (args_places : mplace option list) - (dest : V.symbolic_value) (dest_place : mplace option) - (e : expression option) : expression option = +let synthesize_regular_function_call (fun_id : fun_id_or_trait_method_ref) + (call_id : FunCallId.id) (ctx : Contexts.eval_ctx) + (abstractions : AbstractionId.id list) (generics : generic_args) + (args : typed_value list) (args_places : mplace option list) + (dest : symbolic_value) (dest_place : mplace option) (e : expression option) + : expression option = synthesize_function_call (Fun (fun_id, call_id)) ctx abstractions generics args args_places dest dest_place e -let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : E.unop) - (arg : V.typed_value) (arg_place : mplace option) (dest : V.symbolic_value) +let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : unop) + (arg : typed_value) (arg_place : mplace option) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - let generics = TypesUtils.mk_empty_generic_args in + let generics = empty_generic_args in synthesize_function_call (Unop unop) ctx [] generics [ arg ] [ arg_place ] dest dest_place e -let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : E.binop) - (arg0 : V.typed_value) (arg0_place : mplace option) (arg1 : V.typed_value) - (arg1_place : mplace option) (dest : V.symbolic_value) +let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : binop) + (arg0 : typed_value) (arg0_place : mplace option) (arg1 : typed_value) + (arg1_place : mplace option) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = - let generics = TypesUtils.mk_empty_generic_args in + let generics = empty_generic_args in synthesize_function_call (Binop binop) ctx [] generics [ arg0; arg1 ] [ arg0_place; arg1_place ] dest dest_place e -let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : V.abs) +let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : abs) (e : expression option) : expression option = Option.map (fun e -> EndAbstraction (ctx, abs, e)) e let synthesize_assignment (ctx : Contexts.eval_ctx) (lplace : mplace) - (rvalue : V.typed_value) (rplace : mplace option) (e : expression option) : + (rvalue : typed_value) (rplace : mplace option) (e : expression option) : expression option = Option.map (fun e -> Meta (Assignment (ctx, lplace, rvalue, rplace), e)) e -let synthesize_assertion (ctx : Contexts.eval_ctx) (v : V.typed_value) +let synthesize_assertion (ctx : Contexts.eval_ctx) (v : typed_value) (e : expression option) = Option.map (fun e -> Assertion (ctx, v, e)) e let synthesize_forward_end (ctx : Contexts.eval_ctx) - (loop_input_values : V.typed_value V.SymbolicValueId.Map.t option) - (e : expression) (el : expression T.RegionGroupId.Map.t) = + (loop_input_values : typed_value SymbolicValueId.Map.t option) + (e : expression) (el : expression RegionGroupId.Map.t) = Some (ForwardEnd (ctx, loop_input_values, e, el)) -let synthesize_loop (loop_id : V.LoopId.id) - (input_svalues : V.symbolic_value list) - (fresh_svalues : V.SymbolicValueId.Set.t) - (rg_to_given_back_tys : - (T.RegionId.Set.t * T.ty list) T.RegionGroupId.Map.t) +let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) + (fresh_svalues : SymbolicValueId.Set.t) + (rg_to_given_back_tys : (RegionId.Set.t * ty list) RegionGroupId.Map.t) (end_expr : expression option) (loop_expr : expression option) : expression option = match (end_expr, loop_expr) with diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index 3427fd43..a148175d 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -1,16 +1,11 @@ (** Some utilities for the translation *) -open InterpreterStatements -module L = Logging -module T = Types -module A = LlbcAst -module SA = SymbolicAst -module FA = FunsAnalysis +open Contexts (** The local logger *) -let log = L.translate_log +let log = Logging.translate_log -type trans_ctx = C.decls_ctx [@@deriving show] +type trans_ctx = decls_ctx [@@deriving show] type fun_and_loops = { f : Pure.fun_decl; loops : Pure.fun_decl list } type pure_fun_translation_no_loops = Pure.fun_decl * Pure.fun_decl list @@ -26,53 +21,8 @@ type pure_fun_translation = { backs : fun_and_loops list; } -let trans_ctx_to_type_formatter (ctx : trans_ctx) - (type_params : Pure.type_var list) - (const_generic_params : Pure.const_generic_var list) : - PrintPure.type_formatter = - let type_decls = ctx.type_ctx.type_decls in - let global_decls = ctx.global_ctx.global_decls in - let trait_decls = ctx.trait_decls_ctx.trait_decls in - let trait_impls = ctx.trait_impls_ctx.trait_impls in - PrintPure.mk_type_formatter type_decls global_decls trait_decls trait_impls - type_params const_generic_params +let trans_ctx_to_fmt_env (ctx : trans_ctx) : Print.fmt_env = + Print.Contexts.decls_ctx_to_fmt_env ctx -let type_decl_to_string (ctx : trans_ctx) (def : Pure.type_decl) : string = - let generics = def.generics in - let fmt = - trans_ctx_to_type_formatter ctx generics.types generics.const_generics - in - PrintPure.type_decl_to_string fmt def - -let type_id_to_string (ctx : trans_ctx) (id : Pure.TypeDeclId.id) : string = - Print.fun_name_to_string - (Pure.TypeDeclId.Map.find id ctx.type_ctx.type_decls).name - -let trans_ctx_to_ast_formatter (ctx : trans_ctx) - (type_params : Pure.type_var list) - (const_generic_params : Pure.const_generic_var list) : - PrintPure.ast_formatter = - let type_decls = ctx.type_ctx.type_decls in - let fun_decls = ctx.fun_ctx.fun_decls in - let global_decls = ctx.global_ctx.global_decls in - let trait_decls = ctx.trait_decls_ctx.trait_decls in - let trait_impls = ctx.trait_impls_ctx.trait_impls in - PrintPure.mk_ast_formatter type_decls fun_decls global_decls trait_decls - trait_impls type_params const_generic_params - -let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = - let generics = sg.generics in - let fmt = - trans_ctx_to_ast_formatter ctx generics.types generics.const_generics - in - PrintPure.fun_sig_to_string fmt sg - -let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = - let generics = def.signature.generics in - let fmt = - trans_ctx_to_ast_formatter ctx generics.types generics.const_generics - in - PrintPure.fun_decl_to_string fmt def - -let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = - Print.fun_name_to_string (A.FunDeclId.Map.find id ctx.fun_ctx.fun_decls).name +let trans_ctx_to_pure_fmt_env (ctx : trans_ctx) : PrintPure.fmt_env = + PrintPure.decls_ctx_to_fmt_env ctx diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index eddc1e42..659eac59 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -163,7 +163,7 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) let expl_info = { under_borrow = true; - under_mut_borrow = expl_info.under_mut_borrow || rkind = Mut; + under_mut_borrow = expl_info.under_mut_borrow || rkind = RMut; } in (* Continue exploring *) diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml index 54a12023..52e12b9a 100644 --- a/compiler/TypesUtils.ml +++ b/compiler/TypesUtils.ml @@ -1,7 +1,6 @@ open Types open Utils include Charon.TypesUtils -module TA = TypesAnalysis (** Retuns true if the type contains borrows. @@ -9,9 +8,9 @@ module TA = TypesAnalysis we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, and when a type uses 'static this region doesn't appear in the region parameters. *) -let ty_has_borrows (infos : TA.type_infos) (ty : ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_borrow +let ty_has_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = + let info = TypesAnalysis.analyze_ty infos ty in + info.TypesAnalysis.contains_borrow (** Retuns true if the type contains nested borrows. @@ -19,14 +18,15 @@ let ty_has_borrows (infos : TA.type_infos) (ty : ty) : bool = we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, and when a type uses 'static this region doesn't appear in the region parameters. *) -let ty_has_nested_borrows (infos : TA.type_infos) (ty : ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_nested_borrows +let ty_has_nested_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = + let info = TypesAnalysis.analyze_ty infos ty in + info.TypesAnalysis.contains_nested_borrows (** Retuns true if the type contains a borrow under a mutable borrow *) -let ty_has_borrow_under_mut (infos : TA.type_infos) (ty : ty) : bool = - let info = TA.analyze_ty infos ty in - info.TA.contains_borrow_under_mut +let ty_has_borrow_under_mut (infos : TypesAnalysis.type_infos) (ty : ty) : bool + = + let info = TypesAnalysis.analyze_ty infos ty in + info.TypesAnalysis.contains_borrow_under_mut (** Small helper *) let raise_if_erased_ty_visitor = diff --git a/compiler/Values.ml b/compiler/Values.ml index 932530ff..6b1a782c 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -1,6 +1,5 @@ open Identifiers open Types -module PrimitiveValues = PrimitiveValues (* TODO(SH): I often write "abstract" (value, borrow content, etc.) while I should * write "abstraction" (because those values are not abstract, they simply are diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 7880fc3a..0d3533c2 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -2,7 +2,6 @@ open Utils open TypesUtils open Types open Values -module TA = TypesAnalysis include PrimitiveValuesUtils (** Utility exception *) @@ -144,8 +143,9 @@ let outer_loans_in_value (v : typed_value) : bool = false with Found -> true -let find_first_primitively_copyable_sv_with_borrows (type_infos : TA.type_infos) - (v : typed_value) : symbolic_value option = +let find_first_primitively_copyable_sv_with_borrows + (type_infos : TypesAnalysis.type_infos) (v : typed_value) : + symbolic_value option = (* The visitor *) let obj = object @@ -175,8 +175,8 @@ let rec value_strip_shared_loans (v : typed_value) : typed_value = | _ -> v (** Check if a symbolic value has borrows *) -let symbolic_value_has_borrows (infos : TA.type_infos) (sv : symbolic_value) : - bool = +let symbolic_value_has_borrows (infos : TypesAnalysis.type_infos) + (sv : symbolic_value) : bool = ty_has_borrows infos sv.sv_ty (** Check if a value has borrows in **a general sense**. @@ -185,7 +185,7 @@ let symbolic_value_has_borrows (infos : TA.type_infos) (sv : symbolic_value) : - there are concrete borrows - there are symbolic values which may contain borrows *) -let value_has_borrows (infos : TA.type_infos) (v : value) : bool = +let value_has_borrows (infos : TypesAnalysis.type_infos) (v : value) : bool = let obj = object inherit [_] iter_typed_value @@ -226,7 +226,8 @@ let value_has_loans (v : value) : bool = - there are symbolic values which may contain borrows (symbolic values can't contain loans). *) -let value_has_loans_or_borrows (infos : TA.type_infos) (v : value) : bool = +let value_has_loans_or_borrows (infos : TypesAnalysis.type_infos) (v : value) : + bool = let obj = object inherit [_] iter_typed_value diff --git a/compiler/dune b/compiler/dune index bc3cc718..8a1edd02 100644 --- a/compiler/dune +++ b/compiler/dune @@ -47,7 +47,6 @@ LlbcOfJson Logging Meta - Names PrePasses Print PrintPure -- cgit v1.2.3 From 15f13494becbb3cf4afe8fee51b5cef50f807b52 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 15 Nov 2023 22:06:58 +0100 Subject: Do more cleanup --- compiler/InterpreterLoops.ml | 67 ++++++++++++++++++++----------------------- compiler/InterpreterLoops.mli | 5 ++-- 2 files changed, 34 insertions(+), 38 deletions(-) diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 30b9316d..f88fc977 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -1,12 +1,7 @@ -module T = Types -module PV = PrimitiveValues -module V = Values -module E = Expressions -module C = Contexts -module Subst = Substitute -module A = LlbcAst +open Types +open Values +open Contexts open ValuesUtils -module Inv = Invariants module S = SynthesizeSymbolic open Cps open InterpreterUtils @@ -22,7 +17,7 @@ let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = fun cf ctx -> (* We need a loop id for the [LoopReturn]. In practice it won't be used (it is useful only for the symbolic execution *) - let loop_id = C.fresh_loop_id () in + let loop_id = fresh_loop_id () in (* Continuation for after we evaluate the loop body: depending the result of doing one loop iteration: - redoes a loop iteration @@ -65,7 +60,7 @@ let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = eval_loop_body reeval_loop_body ctx (** Evaluate a loop in symbolic mode *) -let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : +let eval_loop_symbolic (config : config) (eval_loop_body : st_cm_fun) : st_cm_fun = fun cf ctx -> (* Debug *) @@ -73,7 +68,7 @@ let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : (lazy ("eval_loop_symbolic:\nContext:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); (* Generate a fresh loop id *) - let loop_id = C.fresh_loop_id () in + let loop_id = fresh_loop_id () in (* Compute the fixed point at the loop entrance *) let fp_ctx, fixed_ids, rg_to_abs = @@ -88,7 +83,7 @@ let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : (* Compute the loop input parameters *) let fresh_sids, input_svalues = compute_fp_ctx_symbolic_values ctx fp_ctx in - let fp_input_svalues = List.map (fun sv -> sv.V.sv_id) input_svalues in + let fp_input_svalues = List.map (fun sv -> sv.sv_id) input_svalues in (* Synthesize the end of the function - we simply match the context at the loop entry with the fixed point: in the synthesized code, the function @@ -139,9 +134,9 @@ let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : ^ "\n- fixed point:\n" ^ eval_ctx_to_string_no_filter fp_ctx ^ "\n- fixed_sids: " - ^ V.SymbolicValueId.Set.show fixed_ids.sids + ^ SymbolicValueId.Set.show fixed_ids.sids ^ "\n- fresh_sids: " - ^ V.SymbolicValueId.Set.show fresh_sids + ^ SymbolicValueId.Set.show fresh_sids ^ "\n- input_svalues: " ^ Print.list_to_string (symbolic_value_to_string ctx) input_svalues ^ "\n\n")); @@ -154,9 +149,9 @@ let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : is important in {!SymbolicToPure}, where we expect the given back values to have a specific order. *) - let compute_abs_given_back_tys (abs : V.abs) : T.RegionId.Set.t * T.rty list = - let is_borrow (av : V.typed_avalue) : bool = - match av.V.value with + let compute_abs_given_back_tys (abs : abs) : RegionId.Set.t * rty list = + let is_borrow (av : typed_avalue) : bool = + match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> raise (Failure "Unreachable") @@ -165,25 +160,25 @@ let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : let borrows = List.filter_map - (fun av -> - match av.V.value with - | V.ABorrow (V.AMutBorrow (bid, child_av)) -> - assert (is_aignored child_av.V.value); - Some (bid, child_av.V.ty) - | V.ABorrow (V.ASharedBorrow _) -> None + (fun (av : typed_avalue) -> + match av.value with + | ABorrow (AMutBorrow (bid, child_av)) -> + assert (is_aignored child_av.value); + Some (bid, child_av.ty) + | ABorrow (ASharedBorrow _) -> None | _ -> raise (Failure "Unreachable")) borrows in - let borrows = ref (V.BorrowId.Map.of_list borrows) in + let borrows = ref (BorrowId.Map.of_list borrows) in let loan_ids = List.filter_map - (fun av -> - match av.V.value with - | V.ALoan (V.AMutLoan (bid, child_av)) -> - assert (is_aignored child_av.V.value); + (fun (av : typed_avalue) -> + match av.value with + | ALoan (AMutLoan (bid, child_av)) -> + assert (is_aignored child_av.value); Some bid - | V.ALoan (V.ASharedLoan _) -> None + | ALoan (ASharedLoan _) -> None | _ -> raise (Failure "Unreachable")) loans in @@ -193,28 +188,28 @@ let eval_loop_symbolic (config : C.config) (eval_loop_body : st_cm_fun) : List.map (fun lid -> let bid = - V.BorrowId.InjSubst.find lid fp_bl_corresp.loan_to_borrow_id_map + BorrowId.InjSubst.find lid fp_bl_corresp.loan_to_borrow_id_map in - let ty = V.BorrowId.Map.find bid !borrows in - borrows := V.BorrowId.Map.remove bid !borrows; + let ty = BorrowId.Map.find bid !borrows in + borrows := BorrowId.Map.remove bid !borrows; ty) loan_ids in - assert (V.BorrowId.Map.is_empty !borrows); + assert (BorrowId.Map.is_empty !borrows); (abs.regions, given_back_tys) in let rg_to_given_back = - T.RegionGroupId.Map.map compute_abs_given_back_tys rg_to_abs + RegionGroupId.Map.map compute_abs_given_back_tys rg_to_abs in (* Put together *) S.synthesize_loop loop_id input_svalues fresh_sids rg_to_given_back end_expr loop_expr -let eval_loop (config : C.config) (eval_loop_body : st_cm_fun) : st_cm_fun = +let eval_loop (config : config) (eval_loop_body : st_cm_fun) : st_cm_fun = fun cf ctx -> - match config.C.mode with + match config.mode with | ConcreteMode -> eval_loop_concrete eval_loop_body cf ctx | SymbolicMode -> (* We want to make sure the loop will *not* manipulate shared avalues diff --git a/compiler/InterpreterLoops.mli b/compiler/InterpreterLoops.mli index 7395739b..320e4bcb 100644 --- a/compiler/InterpreterLoops.mli +++ b/compiler/InterpreterLoops.mli @@ -56,7 +56,8 @@ From here, we deduce that [abs@fp { MB l0, ML l1}] is the loop abstraction. *) -module C = Contexts +open Contexts +open Cps (** Evaluate a loop *) -val eval_loop : C.config -> Cps.st_cm_fun -> Cps.st_cm_fun +val eval_loop : config -> st_cm_fun -> st_cm_fun -- cgit v1.2.3 From e0351ad287332d5d1c71cee6a834f775db98966d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 15 Nov 2023 22:08:36 +0100 Subject: Do more cleanup --- compiler/AssociatedTypes.ml | 3 +-- compiler/FunsAnalysis.ml | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 06c7827a..2442f93a 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -12,10 +12,9 @@ open Values open LlbcAst open Contexts module Subst = Substitute -module L = Logging (** The local logger *) -let log = L.associated_types_log +let log = Logging.associated_types_log let trait_type_ref_substitute (subst : Subst.subst) (r : trait_type_ref) : trait_type_ref = diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index d6898e96..57aa9e12 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -8,7 +8,7 @@ *) open LlbcAst -module EU = ExpressionsUtils +open ExpressionsUtils (** Various information about a function. @@ -85,9 +85,9 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method! visit_rvalue _env rv = match rv with | Use _ | RvRef _ | Global _ | Discriminant _ | Aggregate _ -> () - | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail + | UnaryOp (uop, _) -> can_fail := unop_can_fail uop || !can_fail | BinaryOp (bop, _, _) -> - can_fail := EU.binop_can_fail bop || !can_fail + can_fail := binop_can_fail bop || !can_fail method! visit_Call env call = (match call.func.func with -- cgit v1.2.3 From a27efd1ed08bc9583752445d9eda7a693c0c7379 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 16 Nov 2023 10:13:28 +0100 Subject: Finish propagating the changes to the names and cleaning --- compiler/Contexts.ml | 2 +- compiler/Driver.ml | 21 +++--- compiler/Extract.ml | 40 +++++------ compiler/ExtractTypes.ml | 155 +++++++++++++++++++++++++++++------------- compiler/FunsAnalysis.ml | 4 +- compiler/Print.ml | 1 - compiler/Pure.ml | 1 + compiler/PureMicroPasses.ml | 29 ++++---- compiler/SymbolicToPure.ml | 6 +- compiler/Translate.ml | 159 ++++++++++++++++++++++---------------------- compiler/TranslateCore.ml | 3 + compiler/TypesAnalysis.ml | 2 +- 12 files changed, 244 insertions(+), 179 deletions(-) diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index 41c84141..a2ae4f16 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -525,7 +525,7 @@ let ctx_set_abs_can_end (ctx : eval_ctx) (abs_id : AbstractionId.id) let ctx_type_decl_is_rec (ctx : eval_ctx) (id : TypeDeclId.id) : bool = let decl_group = TypeDeclId.Map.find id ctx.type_context.type_decls_groups in - match decl_group with Rec _ -> true | NonRec _ -> false + match decl_group with RecGroup _ -> true | NonRecGroup _ -> false (** Visitor to iterate over the values in the *current* frame *) class ['self] iter_frame = diff --git a/compiler/Driver.ml b/compiler/Driver.ml index aa293469..94e50a08 100644 --- a/compiler/Driver.ml +++ b/compiler/Driver.ml @@ -1,15 +1,10 @@ open Aeneas.LlbcOfJson open Aeneas.Logging -module T = Aeneas.Types -module A = Aeneas.LlbcAst -module I = Aeneas.Interpreter +open Aeneas.LlbcAst +open Aeneas.Interpreter module EL = Easy_logging.Logging -module TA = Aeneas.TypesAnalysis -module Micro = Aeneas.PureMicroPasses -module Print = Aeneas.Print -module PrePasses = Aeneas.PrePasses -module Translate = Aeneas.Translate open Aeneas.Config +open Aeneas (** The local logger *) let log = main_log @@ -227,7 +222,9 @@ let () = if !backend = Lean && !extract_decreases_clauses && List.exists - (function Aeneas.LlbcAst.Fun (Rec (_ :: _)) -> true | _ -> false) + (function + | Aeneas.LlbcAst.FunGroup (RecGroup (_ :: _)) -> true + | _ -> false) m.declarations then ( log#error @@ -237,15 +234,15 @@ let () = fail ()); (* Apply the pre-passes *) - let m = PrePasses.apply_passes m in + let m = Aeneas.PrePasses.apply_passes m in (* Some options for the execution *) (* Test the unit functions with the concrete interpreter *) - if !test_unit_functions then I.Test.test_unit_functions m; + if !test_unit_functions then Test.test_unit_functions m; (* Translate the functions *) - Translate.translate_crate filename dest_dir m; + Aeneas.Translate.translate_crate filename dest_dir m; (* Print total elapsed time *) log#linfo diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 04f6c2c3..cd62c15c 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -27,7 +27,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) let builtin = let open ExtractBuiltin in let funs_map = builtin_funs_map () in - let sname = name_to_simple_name def.fwd.f.basename in + let sname = name_to_simple_name def.fwd.f.llbc_name in SimpleNameMap.find_opt sname funs_map in (* Use the builtin names if necessary *) @@ -65,7 +65,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) raise (Failure ("Not found: " - ^ Names.name_to_string f.basename + ^ name_to_string ctx f.llbc_name ^ ", " ^ Print.option_to_string Pure.show_loop_id f.loop_id ^ Print.option_to_string Pure.show_region_group_id @@ -212,7 +212,7 @@ let fun_builtin_filter_types (id : FunDeclId.id) (types : 'a list) 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 + ^ name_to_string ctx decl.fwd.f.llbc_name ^ ": " ^ string_of_int (List.length filter) ^ " filtering arguments provided for " @@ -1137,7 +1137,7 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) extract_comment fmt - [ "[" ^ Print.fun_name_to_string def.basename ^ "]: decreases clause" ]; + [ "[" ^ name_to_string ctx def.llbc_name ^ "]: decreases clause" ]; F.pp_print_space fmt (); (* Open a box for the definition, so that whenever possible it gets printed on * one line *) @@ -1199,7 +1199,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) extract_comment fmt - [ "[" ^ Print.fun_name_to_string def.basename ^ "]: termination measure" ]; + [ "[" ^ name_to_string ctx def.llbc_name ^ "]: termination measure" ]; F.pp_print_space fmt (); (* Open a box for the definition, so that whenever possible it gets printed on * one line *) @@ -1253,7 +1253,7 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (* syntax term ... term : tactic *) F.pp_print_break fmt 0 0; extract_comment fmt - [ "[" ^ Print.fun_name_to_string def.basename ^ "]: decreases_by tactic" ]; + [ "[" ^ name_to_string ctx def.llbc_name ^ "]: decreases_by tactic" ]; F.pp_print_space fmt (); F.pp_open_hvbox fmt 0; F.pp_print_string fmt "syntax \""; @@ -1289,7 +1289,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) (Pure.FunId (FRegular def.def_id), def.loop_id, def.back_id) ctx.fun_name_info in - let comment_pre = "[" ^ Print.fun_name_to_string def.basename ^ "]: " in + let comment_pre = "[" ^ name_to_string ctx def.llbc_name ^ "]: " in let comment = let loop_comment = match def.loop_id with @@ -1766,13 +1766,13 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; - extract_comment fmt [ "[" ^ Print.global_name_to_string global.name ^ "]" ]; + extract_comment fmt [ "[" ^ name_to_string ctx global.name ^ "]" ]; F.pp_print_space fmt (); let decl_name = ctx_get_global global.def_id ctx in let body_name = ctx_get_function - (FromLlbc (Pure.FunId (FRegular global.body_id), None, None)) + (FromLlbc (Pure.FunId (FRegular global.body), None, None)) ctx in @@ -1958,8 +1958,10 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) = (* 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 llbc_name : Types.name = + [ Types.PeIdent (item_name, Disambiguator.zero) ] + in + let f = { f with llbc_name } 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 *) @@ -1991,7 +1993,7 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) | None -> let err = "Ill-formed builtin information for trait decl \"" - ^ Names.name_to_string trait_decl.name + ^ name_to_string ctx trait_decl.llbc_name ^ "\", method \"" ^ item_name ^ "\": could not find name for region " ^ Print.option_to_string Pure.show_region_group_id @@ -2022,7 +2024,7 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) (trait_decl : trait_decl) : extraction_ctx = (* Lookup the information if this is a builtin trait *) let open ExtractBuiltin in - let sname = name_to_simple_name trait_decl.name in + let sname = name_to_simple_name trait_decl.llbc_name in let builtin_info = SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) in @@ -2059,8 +2061,8 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) (* 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 + let type_sname = name_to_simple_name trait_impl.llbc_name in + let trait_sname = name_to_simple_name trait_decl.llbc_name in SimpleNamePairMap.find_opt (type_sname, trait_sname) (builtin_trait_impls_map ()) in @@ -2185,7 +2187,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0; (* Print a comment to link the extracted type to its original rust definition *) extract_comment fmt - [ "Trait declaration: [" ^ Print.name_to_string decl.name ^ "]" ]; + [ "Trait declaration: [" ^ name_to_string ctx decl.llbc_name ^ "]" ]; F.pp_print_break fmt 0 0; (* Open two outer boxes for the definition, so that whenever possible it gets printed on one line and indents are correct. @@ -2466,14 +2468,14 @@ 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)); + log#ldebug (lazy ("extract_trait_impl: " ^ name_to_string ctx impl.llbc_name)); (* Retrieve the impl name *) 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 *) extract_comment fmt - [ "Trait implementation: [" ^ Print.name_to_string impl.name ^ "]" ]; + [ "Trait implementation: [" ^ name_to_string ctx impl.llbc_name ^ "]" ]; F.pp_print_break fmt 0 0; (* Open two outer boxes for the definition, so that whenever possible it gets printed on @@ -2640,7 +2642,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_break fmt 0 0; (* Print a comment *) extract_comment fmt - [ "Unit test for [" ^ Print.fun_name_to_string def.basename ^ "]" ]; + [ "Unit test for [" ^ name_to_string ctx def.llbc_name ^ "]" ]; F.pp_print_space fmt (); (* Open a box for the test *) F.pp_open_hovbox fmt ctx.indent_incr; diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 553d5863..e4617d2c 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -309,7 +309,6 @@ let assumed_llbc_functions () : (SliceIndexShared, None, "slice_index_usize"); (SliceIndexMut, None, "slice_index_usize"); (SliceIndexMut, rg0, "slice_update_usize"); - (SliceLen, None, "slice_len"); ] | Lean -> [ @@ -323,7 +322,6 @@ let assumed_llbc_functions () : (SliceIndexShared, None, "Slice.index_usize"); (SliceIndexMut, None, "Slice.index_usize"); (SliceIndexMut, rg0, "Slice.update_usize"); - (SliceLen, None, "Slice.len"); ] let assumed_pure_functions () : (pure_assumed_fun_id * string) list = @@ -538,6 +536,11 @@ let type_keyword () = | Coq | Lean -> "Type" | HOL4 -> raise (Failure "Unexpected") +let name_last_elem_as_ident (n : llbc_name) : string = + match Collections.List.last n with + | PeIdent (s, _) -> s + | PeImpl _ -> 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 @@ -579,34 +582,90 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) 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 = + The first id elem is always the crate: if it is the local crate, + we remove it. We ignore disambiguators (there may be collisions, but we + check if there are). + *) + let rec name_to_simple_name (name : llbc_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 + | (PeIdent (crate, _) as id) :: name -> + let name = if crate = crate_name then name else id :: name in + let open Types in let name = List.map (function - | Names.Ident s -> s - | Disambiguator d -> Names.Disambiguator.to_string d) + | PeIdent (s, _) -> s + | PeImpl impl -> impl_elem_to_simple_name impl) name in name | _ -> - raise (Failure ("Unexpected name shape: " ^ Print.name_to_string name)) + raise + (Failure + ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx name)) + and impl_elem_to_simple_name (impl : Types.impl_elem) : string = + (* We do something simple for now. + TODO: we might want to do something different for impl elements which are + actually trait implementations, in order to prevent name collisions (it + is possible to define several times the same trait for the same type, + but with different instantiations of the type, or different trait + requirements *) + ty_to_simple_name impl.generics impl.ty + and ty_to_simple_name (generics : Types.generic_params) (ty : Types.ty) : + string = + (* We do something simple for now. + TODO: find a more principled way of converting types to names. + In particular, we might want to do something different for impl elements which are + actually trait implementations, in order to prevent name collisions (it + is possible to define several times the same trait for the same type, + but with different instantiations of the type, or different trait + requirements *) + match ty with + | TAdt (id, args) -> ( + match id with + | TAdtId id -> + let def = TypeDeclId.Map.find id ctx.type_ctx.type_decls in + name_last_elem_as_ident def.name + | TTuple -> + (* TODO *) + "Tuple" + ^ String.concat "" + (List.map (ty_to_simple_name generics) args.types) + | TAssumed id -> Types.show_assumed_ty id) + | TVar vid -> + (* Use the variable name *) + (List.find (fun (v : type_var) -> v.index = vid) generics.types).name + | TLiteral lty -> + StringUtils.capitalize_first_letter + (Print.Types.literal_type_to_string lty) + | TNever -> raise (Failure "Unreachable") + | TRef (_, rty, rk) -> ( + let rty = ty_to_simple_name generics rty in + match rk with + | RMut -> "MutBorrow" ^ rty + | RShared -> "SharedBorrow" ^ rty) + | TRawPtr (rty, rk) -> ( + let rty = ty_to_simple_name generics rty in + match rk with RMut -> "MutPtr" ^ rty | RShared -> "ConstPtr" ^ rty) + | TTraitType (tr, _, name) -> + (* TODO: this is way too simple *) + let trait_decl = + TraitDeclId.Map.find tr.trait_decl_ref.trait_decl_id + ctx.trait_decls_ctx.trait_decls + in + name_last_elem_as_ident trait_decl.name ^ name + | TArrow (inputs, output) -> + "Arrow" + ^ String.concat "" + (List.map (ty_to_simple_name generics) (inputs @ [ output ])) in let flatten_name (name : string list) : string = match !backend with | FStar | Coq | HOL4 -> String.concat "_" name | Lean -> String.concat "." name in + let get_name name : string list = name_to_simple_name name in let get_type_name = get_name in let get_type_name_no_suffix name = match !backend with @@ -620,7 +679,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | 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) + let field_name (def_name : llbc_name) (field_id : FieldId.id) (field_name : string option) : string = let field_name_s = match field_name with @@ -639,7 +698,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | Lean | HOL4 -> def_name | Coq | FStar -> StringUtils.lowercase_first_letter def_name in - let variant_name (def_name : name) (variant : string) : string = + let variant_name (def_name : llbc_name) (variant : string) : string = match !backend with | FStar | Coq | HOL4 -> let variant = to_camel_case variant in @@ -649,7 +708,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) else variant | Lean -> variant in - let struct_constructor (basename : name) : string = + let struct_constructor (basename : llbc_name) : string = let tname = type_name basename in ExtractBuiltin.mk_struct_constructor tname in @@ -661,15 +720,15 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter fname | Lean -> fname in - let global_name (name : global_name) : string = + let global_name (name : llbc_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 fun_name (fname : llbc_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 @@ -678,7 +737,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) in let trait_decl_name (trait_decl : trait_decl) : string = - type_name trait_decl.name + type_name trait_decl.llbc_name in let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : @@ -686,12 +745,14 @@ let mk_formatter (ctx : trans_ctx) (crate_name : 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 + let name = trait_decl.llbc_name in let name = get_type_name_no_suffix name ^ "Inst" in (* Remove the occurrences of '.' *) String.concat "" (String.split_on_char '.' name) in - let name = flatten_name (get_type_name trait_impl.name @ [ trait_decl ]) in + let name = + flatten_name (get_type_name trait_impl.llbc_name @ [ trait_decl ]) + in match !backend with | FStar -> StringUtils.lowercase_first_letter name | Coq | HOL4 | Lean -> name @@ -745,7 +806,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) ^ TraitClauseId.to_string clause.clause_id in - let termination_measure_name (_fid : A.FunDeclId.id) (fname : fun_name) + let termination_measure_name (_fid : A.FunDeclId.id) (fname : llbc_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 @@ -760,7 +821,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) fname ^ lp_suffix ^ suffix in - let decreases_proof_name (_fid : A.FunDeclId.id) (fname : fun_name) + let decreases_proof_name (_fid : A.FunDeclId.id) (fname : llbc_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 @@ -815,12 +876,12 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) | TAdtId 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" - *) + 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)) + let cl = Collections.List.last def.name in + name_from_type_ident (TypesUtils.as_ident cl)) | TVar _ -> ( (* TODO: use "t" also for F* *) match !backend with @@ -866,31 +927,31 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) match cv with | VScalar sv -> ( match !backend with - | FStar -> F.pp_print_string fmt (Z.to_string sv.PV.value) + | FStar -> F.pp_print_string fmt (Z.to_string sv.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_string fmt ("int_to_" ^ int_name sv.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) + if sv.value >= Z.of_int 0 then + F.pp_print_string fmt (Z.to_string sv.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 ^ ")"); + ("(-(" ^ Z.to_string (Z.neg sv.value) ^ ":Int))") + else F.pp_print_string fmt ("(" ^ Z.to_string sv.value ^ ")"); (match !backend with | Coq -> - let iname = int_name sv.PV.int_ty in + let iname = int_name sv.int_ty in F.pp_print_string fmt ("%" ^ iname) | Lean -> - let iname = String.lowercase_ascii (int_name sv.PV.int_ty) in + let iname = String.lowercase_ascii (int_name sv.int_ty) in F.pp_print_string fmt ("#" ^ iname) | HOL4 -> () | _ -> raise (Failure "Unreachable")); @@ -1426,7 +1487,7 @@ 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 sname = name_to_simple_name def.llbc_name in let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in (* Register the filtering information, if there is *) let ctx = @@ -1442,7 +1503,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (* Compute and register the type def name *) let def_name = match info with - | None -> ctx.fmt.type_name def.name + | None -> ctx.fmt.type_name def.llbc_name | Some info -> info.extract_name in let ctx = ctx_add (TypeId (TAdtId def.def_id)) def_name ctx in @@ -1460,10 +1521,10 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let field_names = FieldId.mapi (fun fid (field : field) -> - (fid, ctx.fmt.field_name def.name fid field.field_name)) + (fid, ctx.fmt.field_name def.llbc_name fid field.field_name)) fields in - let cons_name = ctx.fmt.struct_constructor def.name in + let cons_name = ctx.fmt.struct_constructor def.llbc_name in (field_names, cons_name) | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> let field_names = @@ -1499,12 +1560,12 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : VariantId.mapi (fun variant_id (variant : variant) -> let name = - ctx.fmt.variant_name def.name variant.variant_name + ctx.fmt.variant_name def.llbc_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 + let type_name = ctx.fmt.type_name def.llbc_name in type_name ^ "." ^ name else name in @@ -1648,7 +1709,7 @@ let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) let print_variant _variant_id (v : variant) = (* We don't lookup the name, because it may have a prefix for the type id (in the case of Lean) *) - let cons_name = ctx.fmt.variant_name def.name v.variant_name in + let cons_name = ctx.fmt.variant_name def.llbc_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 @@ -2030,7 +2091,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) 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 ^ "]" ]; + extract_comment fmt [ "[" ^ name_to_string ctx def.llbc_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 diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 57aa9e12..a07ad35a 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -164,7 +164,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let analyze_fun_decl_group (d : fun_declaration_group) : unit = (* Retrieve the function declarations *) - let funs = match d with NonRec id -> [ id ] | Rec ids -> ids in + let funs = match d with NonRecGroup id -> [ id ] | RecGroup ids -> ids in let funs = List.map (fun id -> FunDeclId.Map.find id funs_map) funs in let fun_ids = List.map (fun (d : fun_decl) -> d.def_id) funs in let fun_ids = FunDeclId.Set.of_list fun_ids in @@ -183,7 +183,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) | GlobalGroup id :: decls' -> (* Analyze a global by analyzing its body function *) let global = GlobalDeclId.Map.find id globals_map in - analyze_fun_decl_group (NonRec global.body); + analyze_fun_decl_group (NonRecGroup global.body); analyze_decl_groups decls' in diff --git a/compiler/Print.ml b/compiler/Print.ml index cd83a589..48a5a20b 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -1,6 +1,5 @@ include Charon.PrintUtils include Charon.PrintLlbcAst -open Charon.PrintPrimitiveValues open Charon.PrintTypes open Charon.PrintExpressions open Charon.PrintLlbcAst.Ast diff --git a/compiler/Pure.ml b/compiler/Pure.ml index fa059499..40711e53 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -14,6 +14,7 @@ module GlobalDeclId = A.GlobalDeclId module TraitDeclId = T.TraitDeclId module TraitImplId = T.TraitImplId module TraitClauseId = T.TraitClauseId +module Disambiguator = T.Disambiguator (** We redefine identifiers for loop: in {!Values}, the identifiers are global (they monotonically increase across functions) while in {!module:Pure} we want diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index d2747a4b..2106c206 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -3,10 +3,13 @@ open Pure open PureUtils open TranslateCore -module V = Values (** The local logger *) -let log = L.pure_micro_passes_log +let log = Logging.pure_micro_passes_log + +let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = + let fmt = trans_ctx_to_pure_fmt_env ctx in + PrintPure.fun_decl_to_string fmt def (** Small utility. @@ -597,8 +600,8 @@ let intro_struct_updates (ctx : trans_ctx) (def : fun_decl) : fun_decl = match TypeDeclId.Map.find adt_id ctx.type_ctx.type_decls_groups with - | NonRec _ -> false - | Rec _ -> true + | NonRecGroup _ -> false + | RecGroup _ -> true in (* Convert, if possible - note that for now for Lean and Coq we don't support the structure syntax on recursive structures *) @@ -1420,14 +1423,15 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_body = { inputs; inputs_lvs; body = loop_body } in - let loop_def = + let loop_def : fun_decl = { def_id = def.def_id; kind = def.kind; num_loops; loop_id = Some loop.loop_id; back_id = def.back_id; - basename = def.basename; + llbc_name = def.llbc_name; + name = def.name; signature = loop_sig; is_global_decl_body = def.is_global_decl_body; body = Some loop_body; @@ -1539,10 +1543,12 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = mk_unit_rvalue | ( ( SliceIndexShared | SliceIndexMut | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared | ArrayToSliceMut - | ArrayRepeat | SliceLen ), + | ArrayRepeat ), _ ) -> super#visit_texpression env e) - | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> ( + | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> + failwith "TODO" + (* (* Lookup the function name *) let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in match @@ -1570,7 +1576,8 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = | _ -> raise (Failure "Unreachable") in mk_apps arg args - | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e + *) | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e end @@ -1918,9 +1925,7 @@ let apply_passes_to_def (ctx : trans_ctx) (def : fun_decl) : (* Debug *) log#ldebug (lazy - ("PureMicroPasses.apply_passes_to_def: " - ^ Print.fun_name_to_string def.basename - ^ " (" + ("PureMicroPasses.apply_passes_to_def: " ^ def.name ^ " (" ^ Print.option_to_string T.RegionGroupId.to_string def.back_id ^ ")")); diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 2460e040..4e12d31e 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -3036,9 +3036,9 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = (* return *) def -let translate_type_decls (ctx : Contexts.decls_ctx) - (type_decls : T.type_decl list) : type_decl list = - List.map (translate_type_decl ctx) type_decls +let translate_type_decls (ctx : Contexts.decls_ctx) : type_decl list = + List.map (translate_type_decl ctx) + (TypeDeclId.Map.values ctx.type_ctx.type_decls) (** Translates function signatures. diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 2aedb544..cf23fd44 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -1,11 +1,11 @@ -open InterpreterStatements open Interpreter -module L = Logging -module T = Types -module A = LlbcAst +open Expressions +open Types +open Values +open LlbcAst +open Contexts module SA = SymbolicAst module Micro = PureMicroPasses -module C = Contexts open PureUtils open TranslateCore @@ -16,18 +16,17 @@ let log = TranslateCore.log - the list of symbolic values used for the input values - the generated symbolic AST *) -type symbolic_fun_translation = V.symbolic_value list * SA.expression +type symbolic_fun_translation = symbolic_value list * SA.expression (** Execute the symbolic interpreter on a function to generate a list of symbolic ASTs, for the forward function and the backward functions. *) -let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : A.fun_decl) - : symbolic_fun_translation option = +let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : fun_decl) : + symbolic_fun_translation option = (* Debug *) log#ldebug (lazy - ("translate_function_to_symbolics: " - ^ Print.fun_name_to_string fdef.A.name)); + ("translate_function_to_symbolics: " ^ name_to_string trans_ctx fdef.name)); match fdef.body with | None -> None @@ -45,12 +44,11 @@ let translate_function_to_symbolics (trans_ctx : trans_ctx) (fdef : A.fun_decl) *) let translate_function_to_pure (trans_ctx : trans_ctx) (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdNotLoopMap.t) - (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) - : pure_fun_translation_no_loops = + (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : fun_decl) : + pure_fun_translation_no_loops = (* Debug *) log#ldebug - (lazy - ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); + (lazy ("translate_function_to_pure: " ^ name_to_string trans_ctx fdef.name)); let def_id = fdef.def_id in @@ -61,22 +59,24 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (* Initialize the context *) let forward_sig = - RegularFunIdNotLoopMap.find (E.FRegular def_id, None) fun_sigs + RegularFunIdNotLoopMap.find (FRegular def_id, None) fun_sigs in - let sv_to_var = V.SymbolicValueId.Map.empty in + let sv_to_var = SymbolicValueId.Map.empty in let var_counter = Pure.VarId.generator_zero in let state_var, var_counter = Pure.VarId.fresh var_counter in let back_state_var, var_counter = Pure.VarId.fresh var_counter in let fuel0, var_counter = Pure.VarId.fresh var_counter in let fuel, var_counter = Pure.VarId.fresh var_counter in - let calls = V.FunCallId.Map.empty in - let abstractions = V.AbstractionId.Map.empty in + let calls = FunCallId.Map.empty in + let abstractions = AbstractionId.Map.empty in let recursive_type_decls = - T.TypeDeclId.Set.of_list + TypeDeclId.Set.of_list (List.filter_map (fun (tid, g) -> - match g with Charon.GAst.NonRec _ -> None | Rec _ -> Some tid) - (T.TypeDeclId.Map.bindings trans_ctx.type_ctx.type_decls_groups)) + match g with + | Charon.GAst.NonRecGroup _ -> None + | RecGroup _ -> Some tid) + (TypeDeclId.Map.bindings trans_ctx.type_ctx.type_decls_groups)) in let type_context = { @@ -104,9 +104,9 @@ let translate_function_to_pure (trans_ctx : trans_ctx) *) let loop_ids_map = match symbolic_trans with - | None -> V.LoopId.Map.empty + | None -> LoopId.Map.empty | Some (_, ast) -> - let m = ref V.LoopId.Map.empty in + let m = ref LoopId.Map.empty in let _, fresh_loop_id = Pure.LoopId.fresh_stateful_generator () in let visitor = @@ -115,10 +115,9 @@ let translate_function_to_pure (trans_ctx : trans_ctx) method! visit_loop env loop = let _ = - match V.LoopId.Map.find_opt loop.loop_id !m with + match LoopId.Map.find_opt loop.loop_id !m with | Some _ -> () - | None -> - m := V.LoopId.Map.add loop.loop_id (fresh_loop_id ()) !m + | None -> m := LoopId.Map.add loop.loop_id (fresh_loop_id ()) !m in super#visit_loop env loop end @@ -148,9 +147,9 @@ let translate_function_to_pure (trans_ctx : trans_ctx) fun_decl = fdef; forward_inputs = []; (* Empty for now *) - backward_inputs = T.RegionGroupId.Map.empty; + backward_inputs = RegionGroupId.Map.empty; (* Empty for now *) - backward_outputs = T.RegionGroupId.Map.empty; + backward_outputs = RegionGroupId.Map.empty; loop_backward_outputs = None; (* Empty for now *) calls; @@ -171,7 +170,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) | Some body, Some (input_svs, _) -> let forward_input_vars = LlbcAstUtils.fun_body_get_input_vars body in let forward_input_varnames = - List.map (fun (v : A.var) -> v.name) forward_input_vars + List.map (fun (v : var) -> v.name) forward_input_vars in let input_svs = List.combine forward_input_varnames input_svs in let ctx, forward_inputs = @@ -189,7 +188,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) in (* Translate the backward functions *) - let translate_backward (rg : T.region_group) : Pure.fun_decl = + let translate_backward (rg : region_group) : Pure.fun_decl = (* For the backward inputs/outputs initialization: we use the fact that * there are no nested borrows for now, and so that the region groups * can't have parents *) @@ -244,10 +243,10 @@ let translate_function_to_pure (trans_ctx : trans_ctx) SymbolicToPure.fresh_vars backward_outputs ctx in let backward_inputs = - T.RegionGroupId.Map.singleton back_id backward_inputs + RegionGroupId.Map.singleton back_id backward_inputs in let backward_outputs = - T.RegionGroupId.Map.singleton back_id backward_outputs + RegionGroupId.Map.singleton back_id backward_outputs in (* Put everything in the context *) @@ -274,7 +273,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) (pure_forward, pure_backwards) (* TODO: factor out the return type *) -let translate_crate_to_pure (crate : A.crate) : +let translate_crate_to_pure (crate : crate) : trans_ctx * Pure.type_decl list * pure_fun_translation list @@ -287,9 +286,7 @@ let translate_crate_to_pure (crate : A.crate) : let trans_ctx = compute_contexts crate in (* Translate all the type definitions *) - let type_decls = - SymbolicToPure.translate_type_decls (T.TypeDeclId.Map.values crate.types) - in + let type_decls = SymbolicToPure.translate_type_decls trans_ctx in (* Compute the type definition map *) let type_decls_map = @@ -301,24 +298,24 @@ let translate_crate_to_pure (crate : A.crate) : let assumed_sigs = List.map (fun (info : Assumed.assumed_fun_info) -> - ( E.FAssumed info.fun_id, + ( FAssumed info.fun_id, List.map (fun _ -> None) info.fun_sig.inputs, info.fun_sig )) Assumed.assumed_fun_infos in let local_sigs = List.map - (fun (fdef : A.fun_decl) -> + (fun (fdef : fun_decl) -> let input_names = match fdef.body with | None -> List.map (fun _ -> None) fdef.signature.inputs | Some body -> List.map - (fun (v : A.var) -> v.name) + (fun (v : var) -> v.name) (LlbcAstUtils.fun_body_get_input_vars body) in - (E.FRegular fdef.def_id, input_names, fdef.signature)) - (A.FunDeclId.Map.values crate.functions) + (FRegular fdef.def_id, input_names, fdef.signature)) + (FunDeclId.Map.values crate.fun_decls) in let sigs = List.append assumed_sigs local_sigs in let fun_sigs = SymbolicToPure.translate_fun_signatures trans_ctx sigs in @@ -327,22 +324,21 @@ let translate_crate_to_pure (crate : A.crate) : let pure_translations = List.map (translate_function_to_pure trans_ctx fun_sigs type_decls_map) - (A.FunDeclId.Map.values crate.functions) + (FunDeclId.Map.values crate.fun_decls) in (* Translate the trait declarations *) - 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_ctx.trait_decls) + (SymbolicToPure.translate_trait_decl trans_ctx) + (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_ctx.trait_impls) + (SymbolicToPure.translate_trait_impl trans_ctx) + (TraitImplId.Map.values trans_ctx.trait_impls_ctx.trait_impls) in (* Apply the micro-passes *) @@ -401,9 +397,9 @@ let crate_has_opaque_non_builtin_decls (ctx : gen_ctx) (filter_assumed : bool) : log#ldebug (lazy ("Opaque decls:" ^ "\n- types:\n" - ^ String.concat ",\n" (List.map T.show_type_decl types) + ^ String.concat ",\n" (List.map show_type_decl types) ^ "\n- functions:\n" - ^ String.concat ",\n" (List.map A.show_fun_decl funs))); + ^ String.concat ",\n" (List.map show_fun_decl funs))); (types <> [], funs <> []) (** Export a type declaration. @@ -481,7 +477,7 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) let types_map = builtin_types_map () in List.map (fun (def : Pure.type_decl) -> - let sname = name_to_simple_name def.name in + let sname = name_to_simple_name def.llbc_name in SimpleNameMap.find_opt sname types_map <> None) defs in @@ -531,10 +527,10 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) TODO: check correct behavior with opaque globals. *) let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) - (id : A.GlobalDeclId.id) : unit = + (id : GlobalDeclId.id) : unit = 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 + let global = GlobalDeclId.Map.find id global_decls in + let trans = FunDeclId.Map.find global.body ctx.trans_funs in assert (trans.fwd.loops = []); assert (trans.backs = []); let body = trans.fwd.f in @@ -665,7 +661,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) 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 + let sname = name_to_simple_name trans.fwd.f.llbc_name in SimpleNameMap.find_opt sname funs_map <> None) pure_ls in @@ -756,10 +752,10 @@ 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) (extract_decl : bool) (extract_extra_info : bool) : unit = - let trait_decl = T.TraitDeclId.Map.find trait_decl_id ctx.trans_trait_decls in + let trait_decl = 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 + let sname = name_to_simple_name trait_decl.llbc_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 if extract_decl then Extract.extract_trait_decl ctx fmt trait_decl; @@ -771,7 +767,7 @@ 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 = (* Lookup the definition *) - let trait_impl = T.TraitImplId.Map.find trait_impl_id ctx.trans_trait_impls in + let trait_impl = TraitImplId.Map.find trait_impl_id ctx.trans_trait_impls in let trait_decl = Pure.TraitDeclId.Map.find trait_impl.impl_trait.trait_decl_id ctx.trans_trait_decls @@ -779,8 +775,8 @@ let export_trait_impl (fmt : Format.formatter) (_config : gen_config) (* 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 + let type_sname = name_to_simple_name trait_impl.llbc_name in + let trait_sname = name_to_simple_name trait_decl.llbc_name in SimpleNamePairMap.find_opt (type_sname, trait_sname) (builtin_trait_impls_map ()) in @@ -817,14 +813,15 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) Extract.extract_state_type fmt ctx kind in - let export_decl_group (dg : A.declaration_group) : unit = + let export_decl_group (dg : declaration_group) : unit = match dg with - | Type (NonRec id) -> + | TypeGroup (NonRecGroup 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) -> ( + | TypeGroup (RecGroup ids) -> + if config.extract_types then export_types_group true ids + | FunGroup (NonRecGroup id) -> ( (* Lookup *) - let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in + let pure_fun = FunDeclId.Map.find id ctx.trans_funs in (* 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 @@ -834,21 +831,21 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) | _ -> (* Translate *) export_functions_group [ pure_fun ]) - | Fun (Rec ids) -> + | FunGroup (RecGroup ids) -> (* General case of mutually recursive functions *) (* Lookup *) let pure_funs = - List.map (fun id -> A.FunDeclId.Map.find id ctx.trans_funs) ids + List.map (fun id -> FunDeclId.Map.find id ctx.trans_funs) ids in (* Translate *) export_functions_group pure_funs - | Global id -> export_global id - | TraitDecl id -> + | GlobalGroup id -> export_global id + | TraitDeclGroup 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 -> + | TraitImplGroup id -> if config.extract_trait_impls && config.extract_transparent then export_trait_impl id in @@ -986,7 +983,7 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) close_out out (** Translate a crate and write the synthesized code to an output file. *) -let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : +let translate_crate (filename : string) (dest_dir : string) (crate : crate) : unit = (* Translate the module to the pure AST *) let trans_ctx, trans_types, trans_funs, trans_trait_decls, trans_trait_impls = @@ -1036,8 +1033,8 @@ 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 : pure_fun_translation A.FunDeclId.Map.t = - A.FunDeclId.Map.of_list + let trans_funs : pure_fun_translation FunDeclId.Map.t = + FunDeclId.Map.of_list (List.map (fun (trans : pure_fun_translation) -> (trans.fwd.f.def_id, trans)) trans_funs) @@ -1046,13 +1043,13 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : (* Put everything in the context *) let ctx = let trans_trait_decls = - T.TraitDeclId.Map.of_list + 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 + TraitImplId.Map.of_list (List.map (fun (d : Pure.trait_impl) -> (d.def_id, d)) trans_trait_impls) @@ -1107,12 +1104,12 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : if is_global then ctx else Extract.extract_fun_decl_register_names ctx gen_decr_clause trans) ctx - (A.FunDeclId.Map.values trans_funs) + (FunDeclId.Map.values trans_funs) in let ctx = List.fold_left Extract.extract_global_decl_register_names ctx - (A.GlobalDeclId.Map.values crate.globals) + (GlobalDeclId.Map.values crate.global_decls) in let ctx = @@ -1291,7 +1288,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : namespace; in_namespace = true; crate_name; - rust_module_name = crate.A.name; + rust_module_name = crate.name; module_name = types_module; custom_msg = ": type definitions"; custom_imports = []; @@ -1319,7 +1316,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : namespace; in_namespace = true; crate_name; - rust_module_name = crate.A.name; + rust_module_name = crate.name; module_name = template_clauses_module; custom_msg = ": templates for the decreases clauses"; custom_imports = [ types_module ]; @@ -1369,7 +1366,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : namespace; in_namespace = false; crate_name; - rust_module_name = crate.A.name; + rust_module_name = crate.name; module_name = opaque_module; custom_msg; custom_imports = []; @@ -1408,7 +1405,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : namespace; in_namespace = true; crate_name; - rust_module_name = crate.A.name; + rust_module_name = crate.name; module_name = fun_module; custom_msg = ": function definitions"; custom_imports = []; @@ -1441,7 +1438,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : A.crate) : namespace; in_namespace = true; crate_name; - rust_module_name = crate.A.name; + rust_module_name = crate.name; module_name = crate_name; custom_msg = ""; custom_imports = []; diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index a148175d..a974cdee 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -26,3 +26,6 @@ let trans_ctx_to_fmt_env (ctx : trans_ctx) : Print.fmt_env = let trans_ctx_to_pure_fmt_env (ctx : trans_ctx) : PrintPure.fmt_env = PrintPure.decls_ctx_to_fmt_env ctx + +let name_to_string (ctx : trans_ctx) = + Print.Types.name_to_string (trans_ctx_to_fmt_env ctx) diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 659eac59..5371a3d7 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -283,7 +283,7 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) (infos : type_infos) (decl : A.type_declaration_group) : type_infos = (* Collect the identifiers used in the declaration group *) - let ids = match decl with NonRec id -> [ id ] | Rec ids -> ids in + let ids = match decl with NonRecGroup id -> [ id ] | RecGroup ids -> ids in (* Retrieve the type definitions *) let decl_defs = List.map (fun id -> TypeDeclId.Map.find id type_decls) ids in (* Initialize the type information for the current definitions *) -- cgit v1.2.3 From 4972f21e4b25cc16e0839dc3d4a4a2d0552f872d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 16 Nov 2023 10:17:50 +0100 Subject: Rename Driver.ml to Main.ml --- Makefile | 14 +-- compiler/Driver.ml | 251 ----------------------------------------------------- compiler/Main.ml | 251 +++++++++++++++++++++++++++++++++++++++++++++++++++++ compiler/dune | 6 +- 4 files changed, 261 insertions(+), 261 deletions(-) delete mode 100644 compiler/Driver.ml create mode 100644 compiler/Main.ml diff --git a/Makefile b/Makefile index 4660ac83..e0367d73 100644 --- a/Makefile +++ b/Makefile @@ -58,21 +58,21 @@ build-tests-verify: build tests verify # Build the project .PHONY: build -build: build-driver build-lib build-bin-dir doc +build: build-bin build-lib build-bin-dir doc -.PHONY: build-driver -build-driver: - cd compiler && dune build $(AENEAS_DRIVER) +.PHONY: build-bin +build-bin: + cd compiler && dune build .PHONY: build-lib build-lib: cd compiler && dune build aeneas.cmxs .PHONY: build-bin-dir -build-bin-dir: build-driver build-lib +build-bin-dir: build-bin build-lib mkdir -p bin - cp -f compiler/_build/default/driver.exe bin/aeneas - cp -f compiler/_build/default/driver.exe bin/aeneas.cmxs + cp -f compiler/_build/default/main.exe bin/aeneas + cp -f compiler/_build/default/main.exe bin/aeneas.cmxs mkdir -p bin/backends/fstar mkdir -p bin/backends/coq cp -rf backends/fstar/*.fst* bin/backends/fstar/ diff --git a/compiler/Driver.ml b/compiler/Driver.ml deleted file mode 100644 index 94e50a08..00000000 --- a/compiler/Driver.ml +++ /dev/null @@ -1,251 +0,0 @@ -open Aeneas.LlbcOfJson -open Aeneas.Logging -open Aeneas.LlbcAst -open Aeneas.Interpreter -module EL = Easy_logging.Logging -open Aeneas.Config -open Aeneas - -(** The local logger *) -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. - 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; - regions_hierarchy_log#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; - loops_join_ctxs_log#set_level EL.Info; - loops_fixed_point_log#set_level EL.Info; - loops_log#set_level EL.Info; - paths_log#set_level EL.Info; - expressions_log#set_level EL.Info; - expansion_log#set_level EL.Info; - projectors_log#set_level EL.Info; - borrows_log#set_level EL.Info; - invariants_log#set_level EL.Info; - pure_utils_log#set_level EL.Info; - symbolic_to_pure_log#set_level EL.Info; - pure_micro_passes_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 - -(* This is necessary to have a backtrace when raising exceptions - for some - * reason, the -g option doesn't work. - * TODO: run with OCAMLRUNPARAM=b=1? *) -let () = Printexc.record_backtrace true - -let usage = - Printf.sprintf - {|Aeneas: verification of Rust programs by translation to pure lambda calculus - -Usage: %s [OPTIONS] FILE -|} - Sys.argv.(0) - -let () = - (* Measure start time *) - let start_time = Unix.gettimeofday () in - - (* Read the command line arguments *) - let dest_dir = ref "" in - - (* Print the imported llbc *) - let print_llbc = ref false in - - let spec = - [ - ( "-backend", - Arg.Symbol (backend_names, set_backend), - " Specify the target backend" ); - ("-dest", Arg.Set_string dest_dir, " Specify the output directory"); - ( "-no-filter-useless-calls", - Arg.Clear filter_useless_monadic_calls, - " Do not filter the useless function calls" ); - ( "-no-filter-useless-funs", - Arg.Clear filter_useless_functions, - " Do not filter the useless forward/backward functions" ); - ( "-test-units", - Arg.Set test_unit_functions, - " Test the unit functions with the concrete (i.e., not symbolic) \ - interpreter" ); - ( "-test-trans-units", - Arg.Set test_trans_unit_functions, - " Test the translated unit functions with the target theorem prover's \ - normalizer" ); - ( "-decreases-clauses", - Arg.Set extract_decreases_clauses, - " Use decreases clauses/termination measures for the recursive \ - definitions" ); - ( "-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" ); - ( "-backward-no-state-update", - Arg.Set backward_no_state_update, - " Forbid backward functions from updating the state" ); - ( "-template-clauses", - Arg.Set extract_template_decreases_clauses, - " Generate templates for the required decreases clauses/termination \ - measures, in a dedicated file. Implies -decreases-clauses" ); - ( "-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 \ - step. Dramatically increases speed." ); - ( "-no-gen-lib-entry", - Arg.Clear generate_lib_entry_point, - " Do not generate the entry point file for the generated library (only \ - valid if the crate is split between different files)" ); - ( "-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 - - let spec = Arg.align spec in - let filenames = ref [] in - let add_filename f = filenames := f :: !filenames in - Arg.parse spec add_filename usage; - let fail () = - print_string usage; - exit 1 - 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); - (* Sanity check: -backward-no-state-update ==> -state *) - assert ((not !backward_no_state_update) || !use_state); - (* Sanity check: the use of decrease clauses is not compatible with the use of fuel *) - assert ( - (not !use_fuel) - || (not !extract_decreases_clauses) - && not !extract_template_decreases_clauses); - (* We have: not generate_lib_entry_point ==> split_files *) - assert (!split_files || !generate_lib_entry_point); - if !lean_gen_lakefile && not (!backend = Lean) then - log#error - "The -lean-default-lakefile option is valid only for the Lean backend"; - - (* Check that the user specified a backend *) - let _ = - match !opt_backend with - | Some b -> backend := b - | None -> - log#error "Backend not specified (use the `-backend` argument)"; - fail () - in - - (* Set some options depending on the backend *) - let _ = - match !backend with - | FStar -> - (* Some patterns are not supported *) - decompose_monadic_let_bindings := 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; - decompose_nested_let_patterns := true - | Lean -> - (* 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"; - fail ()); - (* Lean can disambiguate the field names *) - record_fields_short_names := true - | HOL4 -> - (* We don't support fuel for the HOL4 backend *) - if !use_fuel then ( - log#error "The HOL4 backend doesn't support the -use-fuel option"; - fail ()) - in - - (* Retrieve and check the filename *) - let filename = - match !filenames with - | [ f ] -> - (* TODO: update the extension *) - if not (Filename.check_suffix f ".llbc") then ( - print_string ("Unrecognized file extension: " ^ f ^ "\n"); - fail ()) - else if not (Sys.file_exists f) then ( - print_string ("File not found: " ^ f ^ "\n"); - fail ()) - else f - | _ -> - (* For now, we only process one file at a time *) - print_string usage; - exit 1 - in - (* Check the destination directory *) - let dest_dir = - if !dest_dir = "" then Filename.dirname filename else !dest_dir - in - - (* Load the module *) - let json = Yojson.Basic.from_file filename in - match crate_of_json json with - | Error s -> - log#error "error: %s\n" s; - exit 1 - | Ok m -> - (* Logging *) - log#linfo (lazy ("Imported: " ^ filename)); - log#ldebug (lazy ("\n" ^ Print.Crate.crate_to_string m ^ "\n")); - - (* We don't support mutually recursive definitions with decreases clauses in Lean *) - if - !backend = Lean && !extract_decreases_clauses - && List.exists - (function - | Aeneas.LlbcAst.FunGroup (RecGroup (_ :: _)) -> true - | _ -> false) - m.declarations - then ( - log#error - "The Lean backend doesn't support the use of \ - decreasing_by/termination_by clauses with mutually recursive \ - definitions"; - fail ()); - - (* Apply the pre-passes *) - let m = Aeneas.PrePasses.apply_passes m in - - (* Some options for the execution *) - - (* Test the unit functions with the concrete interpreter *) - if !test_unit_functions then Test.test_unit_functions m; - - (* Translate the functions *) - Aeneas.Translate.translate_crate filename dest_dir m; - - (* Print total elapsed time *) - log#linfo - (lazy - (Printf.sprintf "Total execution time: %f seconds" - (Unix.gettimeofday () -. start_time))) diff --git a/compiler/Main.ml b/compiler/Main.ml new file mode 100644 index 00000000..94e50a08 --- /dev/null +++ b/compiler/Main.ml @@ -0,0 +1,251 @@ +open Aeneas.LlbcOfJson +open Aeneas.Logging +open Aeneas.LlbcAst +open Aeneas.Interpreter +module EL = Easy_logging.Logging +open Aeneas.Config +open Aeneas + +(** The local logger *) +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. + 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; + regions_hierarchy_log#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; + loops_join_ctxs_log#set_level EL.Info; + loops_fixed_point_log#set_level EL.Info; + loops_log#set_level EL.Info; + paths_log#set_level EL.Info; + expressions_log#set_level EL.Info; + expansion_log#set_level EL.Info; + projectors_log#set_level EL.Info; + borrows_log#set_level EL.Info; + invariants_log#set_level EL.Info; + pure_utils_log#set_level EL.Info; + symbolic_to_pure_log#set_level EL.Info; + pure_micro_passes_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 + +(* This is necessary to have a backtrace when raising exceptions - for some + * reason, the -g option doesn't work. + * TODO: run with OCAMLRUNPARAM=b=1? *) +let () = Printexc.record_backtrace true + +let usage = + Printf.sprintf + {|Aeneas: verification of Rust programs by translation to pure lambda calculus + +Usage: %s [OPTIONS] FILE +|} + Sys.argv.(0) + +let () = + (* Measure start time *) + let start_time = Unix.gettimeofday () in + + (* Read the command line arguments *) + let dest_dir = ref "" in + + (* Print the imported llbc *) + let print_llbc = ref false in + + let spec = + [ + ( "-backend", + Arg.Symbol (backend_names, set_backend), + " Specify the target backend" ); + ("-dest", Arg.Set_string dest_dir, " Specify the output directory"); + ( "-no-filter-useless-calls", + Arg.Clear filter_useless_monadic_calls, + " Do not filter the useless function calls" ); + ( "-no-filter-useless-funs", + Arg.Clear filter_useless_functions, + " Do not filter the useless forward/backward functions" ); + ( "-test-units", + Arg.Set test_unit_functions, + " Test the unit functions with the concrete (i.e., not symbolic) \ + interpreter" ); + ( "-test-trans-units", + Arg.Set test_trans_unit_functions, + " Test the translated unit functions with the target theorem prover's \ + normalizer" ); + ( "-decreases-clauses", + Arg.Set extract_decreases_clauses, + " Use decreases clauses/termination measures for the recursive \ + definitions" ); + ( "-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" ); + ( "-backward-no-state-update", + Arg.Set backward_no_state_update, + " Forbid backward functions from updating the state" ); + ( "-template-clauses", + Arg.Set extract_template_decreases_clauses, + " Generate templates for the required decreases clauses/termination \ + measures, in a dedicated file. Implies -decreases-clauses" ); + ( "-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 \ + step. Dramatically increases speed." ); + ( "-no-gen-lib-entry", + Arg.Clear generate_lib_entry_point, + " Do not generate the entry point file for the generated library (only \ + valid if the crate is split between different files)" ); + ( "-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 + + let spec = Arg.align spec in + let filenames = ref [] in + let add_filename f = filenames := f :: !filenames in + Arg.parse spec add_filename usage; + let fail () = + print_string usage; + exit 1 + 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); + (* Sanity check: -backward-no-state-update ==> -state *) + assert ((not !backward_no_state_update) || !use_state); + (* Sanity check: the use of decrease clauses is not compatible with the use of fuel *) + assert ( + (not !use_fuel) + || (not !extract_decreases_clauses) + && not !extract_template_decreases_clauses); + (* We have: not generate_lib_entry_point ==> split_files *) + assert (!split_files || !generate_lib_entry_point); + if !lean_gen_lakefile && not (!backend = Lean) then + log#error + "The -lean-default-lakefile option is valid only for the Lean backend"; + + (* Check that the user specified a backend *) + let _ = + match !opt_backend with + | Some b -> backend := b + | None -> + log#error "Backend not specified (use the `-backend` argument)"; + fail () + in + + (* Set some options depending on the backend *) + let _ = + match !backend with + | FStar -> + (* Some patterns are not supported *) + decompose_monadic_let_bindings := 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; + decompose_nested_let_patterns := true + | Lean -> + (* 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"; + fail ()); + (* Lean can disambiguate the field names *) + record_fields_short_names := true + | HOL4 -> + (* We don't support fuel for the HOL4 backend *) + if !use_fuel then ( + log#error "The HOL4 backend doesn't support the -use-fuel option"; + fail ()) + in + + (* Retrieve and check the filename *) + let filename = + match !filenames with + | [ f ] -> + (* TODO: update the extension *) + if not (Filename.check_suffix f ".llbc") then ( + print_string ("Unrecognized file extension: " ^ f ^ "\n"); + fail ()) + else if not (Sys.file_exists f) then ( + print_string ("File not found: " ^ f ^ "\n"); + fail ()) + else f + | _ -> + (* For now, we only process one file at a time *) + print_string usage; + exit 1 + in + (* Check the destination directory *) + let dest_dir = + if !dest_dir = "" then Filename.dirname filename else !dest_dir + in + + (* Load the module *) + let json = Yojson.Basic.from_file filename in + match crate_of_json json with + | Error s -> + log#error "error: %s\n" s; + exit 1 + | Ok m -> + (* Logging *) + log#linfo (lazy ("Imported: " ^ filename)); + log#ldebug (lazy ("\n" ^ Print.Crate.crate_to_string m ^ "\n")); + + (* We don't support mutually recursive definitions with decreases clauses in Lean *) + if + !backend = Lean && !extract_decreases_clauses + && List.exists + (function + | Aeneas.LlbcAst.FunGroup (RecGroup (_ :: _)) -> true + | _ -> false) + m.declarations + then ( + log#error + "The Lean backend doesn't support the use of \ + decreasing_by/termination_by clauses with mutually recursive \ + definitions"; + fail ()); + + (* Apply the pre-passes *) + let m = Aeneas.PrePasses.apply_passes m in + + (* Some options for the execution *) + + (* Test the unit functions with the concrete interpreter *) + if !test_unit_functions then Test.test_unit_functions m; + + (* Translate the functions *) + Aeneas.Translate.translate_crate filename dest_dir m; + + (* Print total elapsed time *) + log#linfo + (lazy + (Printf.sprintf "Total execution time: %f seconds" + (Unix.gettimeofday () -. start_time))) diff --git a/compiler/dune b/compiler/dune index 8a1edd02..43ce86c8 100644 --- a/compiler/dune +++ b/compiler/dune @@ -1,9 +1,9 @@ (executable - (name driver) - (public_name aeneas_driver) + (name main) + (public_name aeneas_main) (package aeneas) (libraries aeneas) - (modules Driver)) + (modules Main)) (library (name aeneas) ;; The name as used in the project -- cgit v1.2.3 From 9ab6a034aaadacac62d241474af3cf28bf6ac928 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 16 Nov 2023 10:52:28 +0100 Subject: Update SymbolicToPure.eliminate_box_functions --- compiler/PureMicroPasses.ml | 75 +++++++++++++++++++++++++++------------------ 1 file changed, 45 insertions(+), 30 deletions(-) diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 2106c206..50a50815 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1546,38 +1546,53 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ArrayRepeat ), _ ) -> super#visit_texpression env e) - | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> - failwith "TODO" - (* + | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> ( + (* TODO: use a more general matching mechanism *) (* Lookup the function name *) let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in - 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::boxed::Box::deref", Some _ -> - (* [Box::deref] backward is [()] (doesn't give back anything) *) - assert (args = []); - mk_unit_rvalue - | "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::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 - * *) - let arg, args = - match args with - | _ :: given_back :: args -> (given_back, args) - | _ -> raise (Failure "Unreachable") - in - mk_apps arg args - | _ -> super#visit_texpression env e - *) + (* We first need to check if the name is "alloc::boxed::Box::_" *) + match def.name with + | [ + PeIdent ("alloc", _); + PeIdent ("boxed", _); + PeImpl impl; + PeIdent (fname, _); + ] -> ( + match impl.ty with + | TAdt + ( TAssumed TBox, + { + regions = []; + types = [ TVar _ ]; + const_generics = []; + trait_refs = []; + } ) -> ( + match (fname, rg_id) with + | "deref", None -> + (* [Box::deref] forward is the identity *) + let arg, args = Collections.List.pop args in + mk_apps arg args + | "deref", Some _ -> + (* [Box::deref] backward is [()] (doesn't give back anything) *) + assert (args = []); + mk_unit_rvalue + | "deref_mut", None -> + (* [Box::deref_mut] forward is the identity *) + let arg, args = Collections.List.pop args in + mk_apps arg args + | "deref_mut", Some _ -> + (* [Box::deref_mut] back is almost the identity: + * let box_deref_mut (x_init : t) (x_back : t) : t = x_back + * *) + let arg, args = + match args with + | _ :: given_back :: args -> (given_back, args) + | _ -> raise (Failure "Unreachable") + in + mk_apps arg args + | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e) + | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e end -- cgit v1.2.3 From 0757cdee8c6b8a8020d4b96a44a3017944c9a808 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 16 Nov 2023 10:57:08 +0100 Subject: Do more cleanup --- compiler/SymbolicToPure.ml | 25 +++++++++++++------------ compiler/TypesAnalysis.ml | 8 ++++---- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 4e12d31e..7dad54e1 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -3,6 +3,9 @@ open LlbcAstUtils open Pure open PureUtils open PrimitiveValues +open InterpreterUtils +open FunsAnalysis +open TypesAnalysis module T = Types module Id = Identifiers module C = Contexts @@ -10,8 +13,6 @@ module A = LlbcAst module S = SymbolicAst module TA = TypesAnalysis module PP = PrintPure -module FA = FunsAnalysis -module IU = InterpreterUtils (** The local logger *) let log = Logging.symbolic_to_pure_log @@ -24,7 +25,7 @@ type type_context = { This map is empty when we translate the types, then contains all the translated types when we translate the functions. *) - type_infos : TA.type_infos; + type_infos : type_infos; recursive_decls : T.TypeDeclId.Set.t; } [@@deriving show] @@ -47,7 +48,7 @@ type fun_sig_named_outputs = { type fun_context = { llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; fun_sigs : fun_sig_named_outputs RegularFunIdNotLoopMap.t; (** *) - fun_infos : FA.fun_info A.FunDeclId.Map.t; + fun_infos : fun_info A.FunDeclId.Map.t; regions_hierarchies : T.region_groups FunIdMap.t; } [@@deriving show] @@ -513,7 +514,7 @@ let translate_type_id (id : T.type_id) : type_id = TODO: factor out the various translation functions. *) -let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = +let rec translate_fwd_ty (type_infos : type_infos) (ty : T.ty) : ty = let translate = translate_fwd_ty type_infos in match ty with | T.TAdt (type_id, generics) -> ( @@ -557,15 +558,15 @@ let rec translate_fwd_ty (type_infos : TA.type_infos) (ty : T.ty) : ty = TTraitType (trait_ref, generics, type_name) | TArrow _ -> raise (Failure "TODO") -and translate_fwd_generic_args (type_infos : TA.type_infos) +and translate_fwd_generic_args (type_infos : type_infos) (generics : T.generic_args) : generic_args = translate_generic_args (translate_fwd_ty type_infos) generics -and translate_fwd_trait_ref (type_infos : TA.type_infos) (tr : T.trait_ref) : +and translate_fwd_trait_ref (type_infos : type_infos) (tr : T.trait_ref) : trait_ref = translate_trait_ref (translate_fwd_ty type_infos) tr -and translate_fwd_trait_instance_id (type_infos : TA.type_infos) +and translate_fwd_trait_instance_id (type_infos : type_infos) (id : T.trait_instance_id) : trait_instance_id = translate_trait_instance_id (translate_fwd_ty type_infos) id @@ -586,7 +587,7 @@ let ctx_translate_fwd_generic_args (ctx : bs_ctx) (generics : T.generic_args) : [inside_mut]: are we inside a mutable borrow? *) -let rec translate_back_ty (type_infos : TA.type_infos) +let rec translate_back_ty (type_infos : type_infos) (keep_region : T.region -> bool) (inside_mut : bool) (ty : T.ty) : ty option = let translate = translate_back_ty type_infos keep_region inside_mut in @@ -791,7 +792,7 @@ let mk_fuel_input_as_list (ctx : bs_ctx) (info : fun_effect_info) : if function_uses_fuel info then [ mk_fuel_texpression ctx.fuel ] else [] (** Small utility. *) -let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) +let get_fun_effect_info (fun_infos : fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id_or_trait_method_ref) (lid : V.LoopId.id option) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with @@ -1783,8 +1784,8 @@ and translate_end_abstraction_synth_input (ectx : C.eval_ctx) (abs : V.abs) ^ T.RegionGroupId.to_string rg_id ^ "\n- loop_id: " ^ Print.option_to_string Pure.LoopId.to_string ctx.loop_id - ^ "\n- eval_ctx:\n" ^ IU.eval_ctx_to_string ectx ^ "\n- abs:\n" - ^ IU.abs_to_string ectx abs ^ "\n")); + ^ "\n- eval_ctx:\n" ^ eval_ctx_to_string ectx ^ "\n- abs:\n" + ^ abs_to_string ctx abs ^ "\n")); (* When we end an input abstraction, this input abstraction gets back * the borrows which it introduced in the context through the input diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index 5371a3d7..eb0aeea9 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -1,5 +1,5 @@ open Types -module A = LlbcAst +open LlbcAst type subtype_info = { under_borrow : bool; (** Are we inside a borrow? *) @@ -281,7 +281,7 @@ let analyze_type_decl (updated : bool ref) (infos : type_infos) infos let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) - (infos : type_infos) (decl : A.type_declaration_group) : type_infos = + (infos : type_infos) (decl : type_declaration_group) : type_infos = (* Collect the identifiers used in the declaration group *) let ids = match decl with NonRecGroup id -> [ id ] | RecGroup ids -> ids in (* Retrieve the type definitions *) @@ -289,7 +289,7 @@ let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) (* Initialize the type information for the current definitions *) let infos = List.fold_left - (fun infos def -> + (fun infos (def : type_decl) -> TypeDeclId.Map.add def.def_id (initialize_type_decl_info def) infos) infos decl_defs in @@ -315,7 +315,7 @@ let analyze_type_declaration_group (type_decls : type_decl TypeDeclId.Map.t) Rk.: pay attention to the difference between type definitions and types! *) let analyze_type_declarations (type_decls : type_decl TypeDeclId.Map.t) - (decls : A.type_declaration_group list) : type_infos = + (decls : type_declaration_group list) : type_infos = List.fold_left (fun infos decl -> analyze_type_declaration_group type_decls infos decl) TypeDeclId.Map.empty decls -- cgit v1.2.3 From 4a3779de578cebe01143bb18d295457107be1e3a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 16 Nov 2023 11:13:15 +0100 Subject: Fix a minor issue --- compiler/ExtractTypes.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index e4617d2c..de4ec735 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -632,7 +632,12 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) "Tuple" ^ String.concat "" (List.map (ty_to_simple_name generics) args.types) - | TAssumed id -> Types.show_assumed_ty id) + | TAssumed id -> ( + match id with + | Types.TBox -> "Box" + | Types.TArray -> "Array" + | Types.TSlice -> "Slice" + | Types.TStr -> "Str")) | TVar vid -> (* Use the variable name *) (List.find (fun (v : type_var) -> v.index = vid) generics.types).name -- cgit v1.2.3 From 672ceef25203ebd5fcf5a55e294a4ebfe65648d6 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 20 Nov 2023 21:58:25 +0100 Subject: Use the name matcher implemented in Charon --- compiler/Assumed.ml | 2 +- compiler/Extract.ml | 18 +- compiler/ExtractBase.ml | 3 +- compiler/ExtractBuiltin.ml | 394 +++++++++++++------------------------ compiler/ExtractName.ml | 177 +++++++++++++++++ compiler/ExtractTypes.ml | 106 +++------- compiler/FunsAnalysis.ml | 10 +- compiler/Interpreter.ml | 2 +- compiler/InterpreterExpressions.ml | 2 +- compiler/LlbcAstUtils.ml | 15 +- compiler/PrintPure.ml | 6 +- compiler/PureUtils.ml | 2 +- compiler/StringUtils.ml | 112 +---------- compiler/Substitute.ml | 4 +- compiler/SymbolicAst.ml | 2 +- compiler/SymbolicToPure.ml | 4 +- compiler/Translate.ml | 25 +-- compiler/TranslateCore.ml | 48 +++++ compiler/dune | 3 +- 19 files changed, 440 insertions(+), 495 deletions(-) create mode 100644 compiler/ExtractName.ml diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 6aec626a..48b7ee2b 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -42,7 +42,7 @@ module Sig = struct let tvar_id_0 = TypeVarId.of_int 0 let tvar_0 : ty = TVar tvar_id_0 let cgvar_id_0 = ConstGenericVarId.of_int 0 - let cgvar_0 : const_generic = CGVar cgvar_id_0 + let cgvar_0 : const_generic = CgVar cgvar_id_0 (** Region 'a of id 0 *) let region_param_0 : region_var = { index = rvar_id_0; name = Some "'a" } diff --git a/compiler/Extract.ml b/compiler/Extract.ml index cd62c15c..fb3364f4 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -27,8 +27,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) let builtin = let open ExtractBuiltin in let funs_map = builtin_funs_map () in - let sname = name_to_simple_name def.fwd.f.llbc_name in - SimpleNameMap.find_opt sname funs_map + match_name_find_opt ctx.trans_ctx def.fwd.f.llbc_name funs_map in (* Use the builtin names if necessary *) match builtin with @@ -2024,9 +2023,9 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) (trait_decl : trait_decl) : extraction_ctx = (* Lookup the information if this is a builtin trait *) let open ExtractBuiltin in - let sname = name_to_simple_name trait_decl.llbc_name in let builtin_info = - SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) + match_name_find_opt ctx.trans_ctx trait_decl.llbc_name + (builtin_trait_decls_map ()) in let ctx = let trait_name, trait_constructor = @@ -2061,9 +2060,14 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) (* Check if the trait implementation is builtin *) let builtin_info = let open ExtractBuiltin in - let type_sname = name_to_simple_name trait_impl.llbc_name in - let trait_sname = name_to_simple_name trait_decl.llbc_name in - SimpleNamePairMap.find_opt (type_sname, trait_sname) + (* Lookup the original Rust impl to retrieve the original trait ref (we + use it to derive the name)*) + let trait_impl = + TraitImplId.Map.find trait_impl.def_id ctx.crate.trait_impls + in + let decl_ref = trait_impl.impl_trait in + match_name_with_generics_find_opt ctx.trans_ctx trait_decl.llbc_name + decl_ref.decl_generics (builtin_trait_impls_map ()) in (* Register some builtin information (if necessary) *) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index ae5a9a22..f1ba35a2 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1085,8 +1085,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_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 builtin_globals_map with + match match_name_find_opt ctx.trans_ctx def.name builtin_globals_map with | Some name -> (* Yes: register the custom binding *) ctx_add decl name ctx diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index db942ff0..d15905a2 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -5,38 +5,8 @@ *) open Config -open Types - -type simple_name = string list [@@deriving show, ord] - -(* TODO: update *) -let name_to_simple_name (s : name) : simple_name = - (* We simply ignore the disambiguators - TODO: update *) - List.map - (function - | PeIdent (id, _) -> id - | PeImpl i -> - (* TODO *) - show_impl_elem i) - s - -(** Small helper which cuts a string at the occurrences of "::" *) -let string_to_simple_name (s : string) : simple_name = - (* 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) -module SimpleNameSet = Collections.MakeSet (SimpleNameOrd) +open Charon.NameMatcher (* TODO: include? *) +include ExtractName (* TODO: only open? *) (** Small utility to memoize some computations *) let mk_memoized (f : unit -> 'a) : unit -> 'a = @@ -51,6 +21,9 @@ let mk_memoized (f : unit -> 'a) : unit -> 'a = in g +let split_on_separator (s : string) : string list = + Str.split (Str.regexp "::") s + (** Switch between two values depending on the target backend. We often compute the same value (typically: a name) if the target @@ -62,36 +35,36 @@ let backend_choice (fstar_coq_hol4 : 'a) (lean : 'a) : 'a = 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"); + ("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"); + ("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) +let builtin_globals_map : string NameMatcherMap.t = + NameMatcherMap.of_list + (List.map (fun (x, y) -> (parse_pattern x, y)) builtin_globals) type builtin_variant_info = { fields : (string * string) list } [@@deriving show] @@ -111,7 +84,7 @@ type builtin_type_body_info = [@@deriving show] type builtin_type_info = { - rust_name : string list; + rust_name : pattern; extract_name : string; keep_params : bool list option; (** We might want to filter some of the type parameters. @@ -143,11 +116,11 @@ let mk_struct_constructor (type_name : string) : string = 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) + let mk_type (rust_name : string) ?(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 + String.concat sep (split_on_separator rust_name) in let body_info : builtin_type_body_info option = match kind with @@ -166,17 +139,17 @@ let builtin_types () : builtin_type_info list = Some (Struct (constructor, fields)) | KEnum -> raise (Failure "TODO") in + let rust_name = parse_pattern rust_name in { rust_name; extract_name; keep_params; body_info } in [ (* Alloc *) - mk_type [ "alloc"; "alloc"; "Global" ] (); + mk_type "alloc::alloc::Global" (); (* Vec *) - mk_type [ "alloc"; "vec"; "Vec" ] ~keep_params:(Some [ true; false ]) (); + mk_type "alloc::vec::Vec" ~keep_params:(Some [ true; false ]) (); (* Range *) - mk_type - [ "core"; "ops"; "range"; "Range" ] + mk_type "core::ops::range::Range" ~kind:(KStruct [ ("start", "start"); ("end", "end_") ]) (); (* Option @@ -185,7 +158,7 @@ let builtin_types () : builtin_type_info list = the target backend. *) { - rust_name = [ "core"; "option"; "Option" ]; + rust_name = parse_pattern "core::option::Option"; extract_name = (match !backend with | Lean -> "Option" @@ -218,7 +191,7 @@ let builtin_types () : builtin_type_info list = ] let mk_builtin_types_map () = - SimpleNameMap.of_list + NameMatcherMap.of_list (List.map (fun info -> (info.rust_name, info)) (builtin_types ())) let builtin_types_map = mk_memoized mk_builtin_types_map @@ -235,15 +208,22 @@ 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 list * bool list option * builtin_fun_info list) list = +let builtin_funs () : (pattern * 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) + let mk_fun (rust_name : string) (extract_name : string option) (filter : bool list option) (with_back : bool) (back_no_suffix : bool) : - string list * bool list option * builtin_fun_info list = + pattern * bool list option * builtin_fun_info list = + let rust_name = + try parse_pattern rust_name + with Failure _ -> + raise (Failure ("Could not parse pattern: " ^ rust_name)) + in let extract_name = - match extract_name with None -> name | Some name -> name + match extract_name with + | None -> pattern_to_fun_extract_name rust_name + | Some name -> split_on_separator name in let basename = match !backend with @@ -257,103 +237,55 @@ let builtin_funs () : if with_back then [ { rg = rg0; extract_name = basename ^ back_suffix } ] else [] in - (name, filter, fwd @ back) + (rust_name, filter, fwd @ back) in [ - 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 + mk_fun "core::mem::replace" None None true false; + mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::new" None None false false; + mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::push" None (Some [ true; false ]) true true; - mk_fun - [ "alloc"; "vec"; "Vec"; "insert" ] - None + mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::insert" None (Some [ true; false ]) true true; - mk_fun - [ "alloc"; "vec"; "Vec"; "len" ] - None + mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::len" None (Some [ true; false ]) true false; - mk_fun - [ "alloc"; "vec"; "Vec"; "index" ] - None + mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::index" None (Some [ true; true; false ]) true false; - mk_fun - [ "alloc"; "vec"; "Vec"; "index_mut" ] - None + mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::index_mut" None (Some [ true; true; false ]) true false; - mk_fun - [ "alloc"; "boxed"; "Box"; "deref" ] - None + mk_fun "alloc::boxed::{Box<@T>}::deref" None (Some [ true; false ]) true false; - mk_fun - [ "alloc"; "boxed"; "Box"; "deref_mut" ] - None + mk_fun "alloc::boxed::{Box<@T>}::deref_mut" None (Some [ true; false ]) true false; - (* TODO: fix the same like "[T]" below *) - 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; + mk_fun "core::slice::index::{[@T]}::index" None None true false; + mk_fun "core::slice::index::{[@T]}::index_mut" None None true false; + mk_fun "core::array::{[@T; @C]}::index" None None true false; + mk_fun "core::array::{[@T; @C]}::index_mut" None None true false; + mk_fun "core::slice::index::{Range<@T>}::get" None None true false; + mk_fun "core::slice::index::{Range<@T>}::get_mut" None None true false; + mk_fun "core::slice::index::{Range<@T>}::index" None None true false; + mk_fun "core::slice::index::{Range<@T>}::index_mut" None None true false; + mk_fun "core::slice::index::{Range<@T>}::get_unchecked" None None false + false; + mk_fun "core::slice::index::{Range<@T>}::get_unchecked_mut" None None false + false; + mk_fun "core::slice::index::{usize}::get" None None true false; + mk_fun "core::slice::index::{usize}::get_mut" None None true false; + mk_fun "core::slice::index::{usize}::get_unchecked" None None false false; + mk_fun "core::slice::index::{usize}::get_unchecked_mut" None None false + false; + mk_fun "core::slice::index::{usize}::index" None None true false; + mk_fun "core::slice::index::{usize}::index_mut" None None true false; ] let mk_builtin_funs_map () = - SimpleNameMap.of_list + NameMatcherMap.of_list (List.map (fun (name, filter, info) -> (name, (filter, info))) (builtin_funs ())) @@ -385,17 +317,22 @@ let builtin_fun_effects = let int_funs = List.map (fun int_name -> - List.map (fun op -> "core::num::" ^ int_name ^ "::" ^ op) int_ops) + List.map + (fun op -> + "core::num::" ^ "{" + ^ StringUtils.capitalize_first_letter int_name + ^ "}::" ^ op) + int_ops) int_names in 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"; - "alloc::boxed::Box::deref_mut"; + "alloc::vec::{alloc::vec::Vec<@T>}::new"; + "alloc::vec::{alloc::vec::Vec<@T>}::len"; + "alloc::boxed::{Box<@T>}::deref"; + "alloc::boxed::{Box<@T>}::deref_mut"; "core::mem::replace"; "core::mem::take"; ] @@ -409,10 +346,10 @@ let builtin_fun_effects = 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"; + "alloc::vec::{alloc::vec::Vec<@T>}::push"; + "alloc::vec::{alloc::vec::Vec<@T>}::index"; + "alloc::vec::{alloc::vec::Vec<@T>}::index_mut"; + "alloc::vec::{alloc::vec::Vec<@T>}::index_mut_back"; ] in let no_state_funs = @@ -421,11 +358,11 @@ let builtin_fun_effects = no_fail_no_state_funs @ no_state_funs let builtin_fun_effects_map = - SimpleNameMap.of_list - (List.map (fun (n, x) -> (string_to_simple_name n, x)) builtin_fun_effects) + NameMatcherMap.of_list + (List.map (fun (n, x) -> (parse_pattern n, x)) builtin_fun_effects) type builtin_trait_decl_info = { - rust_name : string; + rust_name : pattern; extract_name : string; constructor : string; parent_clauses : string list; @@ -441,13 +378,15 @@ type builtin_trait_decl_info = { let builtin_trait_decls_info () = let rg0 = Some Types.RegionGroupId.zero in - let mk_trait (rust_name : string list) ?(extract_name : string option = None) + let mk_trait (rust_name : string) ?(extract_name : string option = None) ?(parent_clauses : string list = []) ?(types : string list = []) ?(methods : (string * bool) list = []) () : builtin_trait_decl_info = + let rust_name = parse_pattern rust_name in let extract_name = match extract_name with | Some n -> n | None -> ( + let rust_name = pattern_to_fun_extract_name rust_name in match !backend with | Coq | FStar | HOL4 -> String.concat "_" rust_name | Lean -> String.concat "." rust_name) @@ -487,7 +426,6 @@ let builtin_trait_decls_info () = in List.map mk_method methods in - let rust_name = String.concat "::" rust_name in { rust_name; extract_name; @@ -500,34 +438,27 @@ let builtin_trait_decls_info () = in [ (* Deref *) - mk_trait - [ "core"; "ops"; "deref"; "Deref" ] - ~types:[ "Target" ] + mk_trait "core::ops::deref::Deref" ~types:[ "Target" ] ~methods:[ ("deref", true) ] (); (* DerefMut *) - mk_trait - [ "core"; "ops"; "deref"; "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" ] + mk_trait "core::ops::index::Index" ~types:[ "Output" ] ~methods:[ ("index", true) ] (); (* IndexMut *) - mk_trait - [ "core"; "ops"; "index"; "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" ] (); + mk_trait "core::slice::index::private_slice_index::Sealed" (); (* SliceIndex *) - mk_trait - [ "core"; "slice"; "index"; "SliceIndex" ] + mk_trait "core::slice::index::SliceIndex" ~parent_clauses:[ backend_choice "sealed_inst" "sealedInst" ] ~types:[ "Output" ] ~methods: @@ -543,113 +474,56 @@ let builtin_trait_decls_info () = ] let mk_builtin_trait_decls_map () = - SimpleNameMap.of_list + NameMatcherMap.of_list (List.map - (fun info -> (string_to_simple_name info.rust_name, info)) + (fun info -> (info.rust_name, info)) (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) * (bool list option * string)) list = - 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 builtin_trait_impls_info () : (pattern * (bool list option * string)) list = + let fmt (rust_name : string) ?(filter : bool list option = None) () : + pattern * (bool list option * string) = + let rust_name = parse_pattern rust_name in let name = - let trait_name = String.concat "" trait_name ^ "Inst" in + let name = pattern_to_trait_impl_extract_name rust_name 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 + String.concat sep name in - ((type_name, trait_name), (filter, name)) + (rust_name, (filter, name)) in - (* TODO: fix the names like "[T]" below *) [ (* core::ops::Deref> *) - fmt [ "alloc"; "boxed"; "Box" ] [ "core"; "ops"; "deref"; "Deref" ] (); - (* core::ops::DerefMut> *) - fmt [ "alloc"; "boxed"; "Box" ] [ "core"; "ops"; "deref"; "DerefMut" ] (); + fmt "core::ops::Deref>" (); + (* core::ops::Deref> *) + fmt "core::ops::Deref>" (); (* core::ops::index::Index<[T], I> *) - fmt - [ "core"; "slice"; "index"; "[T]" ] - ~extract_type_name:(Some [ "core"; "slice"; "index"; "Slice" ]) - [ "core"; "ops"; "index"; "Index" ] - (); + fmt "core::ops::index::Index<[@T], @I>" (); (* core::ops::index::IndexMut<[T], I> *) - fmt - [ "core"; "slice"; "index"; "[T]" ] - ~extract_type_name:(Some [ "core"; "slice"; "index"; "Slice" ]) - [ "core"; "ops"; "index"; "IndexMut" ] - (); + fmt "core::ops::index::IndexMut<[@T], @I>" (); (* core::slice::index::private_slice_index::Sealed> *) - fmt - [ "core"; "slice"; "index"; "private_slice_index"; "Range" ] - [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] - (); + fmt "core::slice::index::private_slice_index::Sealed>" (); (* core::slice::index::SliceIndex, [T]> *) - fmt - [ "core"; "slice"; "index"; "Range" ] - [ "core"; "slice"; "index"; "SliceIndex" ] - (); + fmt "core::slice::index::SliceIndex, [@T]>" (); (* core::ops::index::Index<[T; N], I> *) - fmt - [ "core"; "array"; "[T; N]" ] - ~extract_type_name:(Some [ "core"; "array"; "Array" ]) - [ "core"; "ops"; "index"; "Index" ] - (); + fmt "core::ops::index::Index<[@T; @N], @I>" (); (* core::ops::index::IndexMut<[T; N], I> *) - fmt - [ "core"; "array"; "[T; N]" ] - ~extract_type_name:(Some [ "core"; "array"; "Array" ]) - [ "core"; "ops"; "index"; "IndexMut" ] - (); + fmt "core::ops::index::IndexMut<[@T; @N], @I>" (); (* core::slice::index::private_slice_index::Sealed *) - fmt - [ "core"; "slice"; "index"; "private_slice_index"; "usize" ] - [ "core"; "slice"; "index"; "private_slice_index"; "Sealed" ] - (); + fmt "core::slice::index::private_slice_index::Sealed" (); (* core::slice::index::SliceIndex *) - fmt - [ "core"; "slice"; "index"; "usize" ] - [ "core"; "slice"; "index"; "SliceIndex" ] - (); - (* core::ops::index::Index, T> *) - fmt [ "alloc"; "vec"; "Vec" ] - [ "core"; "ops"; "index"; "Index" ] + fmt "core::slice::index::SliceIndex" (); + (* core::ops::index::Index, T> *) + fmt "core::ops::index::Index, @T>" ~filter:(Some [ true; true; false ]) (); - (* core::ops::index::IndexMut, T> *) - fmt [ "alloc"; "vec"; "Vec" ] - [ "core"; "ops"; "index"; "IndexMut" ] + (* core::ops::index::IndexMut, T> *) + fmt "core::ops::index::IndexMut, @T>" ~filter:(Some [ true; true; false ]) (); ] let mk_builtin_trait_impls_map () = - SimpleNamePairMap.of_list (builtin_trait_impls_info ()) + NameMatcherMap.of_list (builtin_trait_impls_info ()) let builtin_trait_impls_map = mk_memoized mk_builtin_trait_impls_map diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml new file mode 100644 index 00000000..4f5ca0d1 --- /dev/null +++ b/compiler/ExtractName.ml @@ -0,0 +1,177 @@ +(** Utilities for extracting names *) + +open Charon.NameMatcher + +module NameMatcherMap = struct + type 'a t = (pattern * 'a) list + + let config = { map_vars_to_vars = true } + + let find_opt (ctx : ctx) (name : Types.name) (m : 'a t) : 'a option = + match List.find_opt (fun (pat, _) -> match_name ctx config pat name) m with + | None -> None + | Some (_, v) -> Some v + + let find_with_generics_opt (ctx : ctx) (name : Types.name) + (g : Types.generic_args) (m : 'a t) : 'a option = + match + List.find_opt + (fun (pat, _) -> match_name_with_generics ctx config pat name g) + m + with + | None -> None + | Some (_, v) -> Some v + + let mem (ctx : ctx) (name : Types.name) (m : 'a t) : bool = + find_opt ctx name m <> None + + let of_list (ls : (pattern * 'a) list) : 'a t = ls +end + +(** Helper to convert name patterns to names for extraction. + + For impl blocks, we simply use the name of the type (without its arguments) + if all the arguments are variables. + *) +let pattern_to_extract_name (is_trait_impl : bool) (name : pattern) : + string list = + let c = { tgt_kind = TkName } in + let is_var (g : generic_arg) : bool = + match g with + | GExpr (EVar _) -> true + | GRegion (RVar _) -> true + | _ -> false + in + let all_vars = List.for_all is_var in + let elem_to_string (e : pattern_elem) : string = + match e with + | PIdent _ -> pattern_elem_to_string c e + | PImpl ty -> ( + match ty with + | EComp id -> ( + (* Retrieve the last ident *) + let id = Collections.List.last id in + match id with + | PIdent (s, g) -> + if all_vars g then s else pattern_elem_to_string c id + | PImpl _ -> raise (Failure "Unreachable")) + | EPrimAdt (adt, g) -> + if all_vars g then + match adt with + | TTuple -> + let l = List.length g in + if l = 2 then "Pair" else expr_to_string c ty + | TArray -> "Array" + | TSlice -> "Slice" + else expr_to_string c ty + | ERef _ | EVar _ -> raise (Failure "")) + in + let rec pattern_to_string (n : pattern) : string list = + match n with + | [] -> raise (Failure "Unreachable") + | [ e ] -> + let e = elem_to_string e in + if is_trait_impl then [ e ^ "Inst" ] else [ e ] + | e :: n -> elem_to_string e :: pattern_to_string n + in + pattern_to_string name + +let pattern_to_fun_extract_name = pattern_to_extract_name false +let pattern_to_trait_impl_extract_name = pattern_to_extract_name true + +(* TODO: this is provisional. We just want to make sure that the extraction + names we derive from the patterns (for the builtin definitions) are + consistent with the extraction names we derive from the Rust names *) +let name_to_simple_name (ctx : ctx) (n : Types.name) : string list = + pattern_to_extract_name false (name_to_pattern ctx n) + +let name_with_generics_to_simple_name (ctx : ctx) (n : Types.name) + (p : Types.generic_params) (g : Types.generic_args) : string list = + pattern_to_extract_name true (name_with_generics_to_pattern ctx n p g) + +(* + (* Prepare a name. + The first id elem is always the crate: if it is the local crate, + we remove it. We ignore disambiguators (there may be collisions, but we + check if there are). + *) + let rec name_to_simple_name (name : llbc_name) : string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + match name with + | (PeIdent (crate, _) as id) :: name -> + let name = if crate = crate_name then name else id :: name in + let open Types in + let name = + List.map + (function + | PeIdent (s, _) -> s + | PeImpl impl -> impl_elem_to_simple_name impl) + name + in + name + | _ -> + raise + (Failure + ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx name)) + and impl_elem_to_simple_name (impl : Types.impl_elem) : string = + (* We do something simple for now. + TODO: we might want to do something different for impl elements which are + actually trait implementations, in order to prevent name collisions (it + is possible to define several times the same trait for the same type, + but with different instantiations of the type, or different trait + requirements *) + ty_to_simple_name impl.generics impl.ty + and ty_to_simple_name (generics : Types.generic_params) (ty : Types.ty) : + string = + (* We do something simple for now. + TODO: find a more principled way of converting types to names. + In particular, we might want to do something different for impl elements which are + actually trait implementations, in order to prevent name collisions (it + is possible to define several times the same trait for the same type, + but with different instantiations of the type, or different trait + requirements *) + match ty with + | TAdt (id, args) -> ( + match id with + | TAdtId id -> + let def = TypeDeclId.Map.find id ctx.type_ctx.type_decls in + name_last_elem_as_ident def.name + | TTuple -> + (* TODO *) + "Tuple" + ^ String.concat "" + (List.map (ty_to_simple_name generics) args.types) + | TAssumed id -> ( + match id with + | Types.TBox -> "Box" + | Types.TArray -> "Array" + | Types.TSlice -> "Slice" + | Types.TStr -> "Str")) + | TVar vid -> + (* Use the variable name *) + (List.find (fun (v : type_var) -> v.index = vid) generics.types).name + | TLiteral lty -> + StringUtils.capitalize_first_letter + (Print.Types.literal_type_to_string lty) + | TNever -> raise (Failure "Unreachable") + | TRef (_, rty, rk) -> ( + let rty = ty_to_simple_name generics rty in + match rk with + | RMut -> "MutBorrow" ^ rty + | RShared -> "SharedBorrow" ^ rty) + | TRawPtr (rty, rk) -> ( + let rty = ty_to_simple_name generics rty in + match rk with RMut -> "MutPtr" ^ rty | RShared -> "ConstPtr" ^ rty) + | TTraitType (tr, _, name) -> + (* TODO: this is way too simple *) + let trait_decl = + TraitDeclId.Map.find tr.trait_decl_ref.trait_decl_id + ctx.trait_decls_ctx.trait_decls + in + name_last_elem_as_ident trait_decl.name ^ name + | TArrow (inputs, output) -> + "Arrow" + ^ String.concat "" + (List.map (ty_to_simple_name generics) (inputs @ [ output ])) + in +*) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index de4ec735..a74bd532 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -586,84 +586,16 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) we remove it. We ignore disambiguators (there may be collisions, but we check if there are). *) - let rec name_to_simple_name (name : llbc_name) : string list = + let name_to_simple_name (name : llbc_name) : string list = (* Rmk.: initially we only filtered the disambiguators equal to 0 *) match name with | (PeIdent (crate, _) as id) :: name -> let name = if crate = crate_name then name else id :: name in - let open Types in - let name = - List.map - (function - | PeIdent (s, _) -> s - | PeImpl impl -> impl_elem_to_simple_name impl) - name - in - name + name_to_simple_name ctx name | _ -> raise (Failure ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx name)) - and impl_elem_to_simple_name (impl : Types.impl_elem) : string = - (* We do something simple for now. - TODO: we might want to do something different for impl elements which are - actually trait implementations, in order to prevent name collisions (it - is possible to define several times the same trait for the same type, - but with different instantiations of the type, or different trait - requirements *) - ty_to_simple_name impl.generics impl.ty - and ty_to_simple_name (generics : Types.generic_params) (ty : Types.ty) : - string = - (* We do something simple for now. - TODO: find a more principled way of converting types to names. - In particular, we might want to do something different for impl elements which are - actually trait implementations, in order to prevent name collisions (it - is possible to define several times the same trait for the same type, - but with different instantiations of the type, or different trait - requirements *) - match ty with - | TAdt (id, args) -> ( - match id with - | TAdtId id -> - let def = TypeDeclId.Map.find id ctx.type_ctx.type_decls in - name_last_elem_as_ident def.name - | TTuple -> - (* TODO *) - "Tuple" - ^ String.concat "" - (List.map (ty_to_simple_name generics) args.types) - | TAssumed id -> ( - match id with - | Types.TBox -> "Box" - | Types.TArray -> "Array" - | Types.TSlice -> "Slice" - | Types.TStr -> "Str")) - | TVar vid -> - (* Use the variable name *) - (List.find (fun (v : type_var) -> v.index = vid) generics.types).name - | TLiteral lty -> - StringUtils.capitalize_first_letter - (Print.Types.literal_type_to_string lty) - | TNever -> raise (Failure "Unreachable") - | TRef (_, rty, rk) -> ( - let rty = ty_to_simple_name generics rty in - match rk with - | RMut -> "MutBorrow" ^ rty - | RShared -> "SharedBorrow" ^ rty) - | TRawPtr (rty, rk) -> ( - let rty = ty_to_simple_name generics rty in - match rk with RMut -> "MutPtr" ^ rty | RShared -> "ConstPtr" ^ rty) - | TTraitType (tr, _, name) -> - (* TODO: this is way too simple *) - let trait_decl = - TraitDeclId.Map.find tr.trait_decl_ref.trait_decl_id - ctx.trait_decls_ctx.trait_decls - in - name_last_elem_as_ident trait_decl.name ^ name - | TArrow (inputs, output) -> - "Arrow" - ^ String.concat "" - (List.map (ty_to_simple_name generics) (inputs @ [ output ])) in let flatten_name (name : string list) : string = match !backend with @@ -747,17 +679,22 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) 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.llbc_name in - let name = get_type_name_no_suffix name ^ "Inst" in - (* Remove the occurrences of '.' *) - String.concat "" (String.split_on_char '.' name) - in + (* We derive the trait impl name from the implemented trait. + For instance, if this implementation is an instance of `trait::Trait` + for ``, we generate the name: "trait.TraitFooFooU32Inst". + Importantly, it is to be noted that the name is independent of the place + where the instance has been defined (it is indepedent of the file, etc.). + *) let name = - flatten_name (get_type_name trait_impl.llbc_name @ [ trait_decl ]) + (* We need to lookup the LLBC definitions, to have the original instantiation *) + let trait_impl = + TraitImplId.Map.find trait_impl.def_id ctx.trait_impls_ctx.trait_impls + in + let params = trait_impl.generics in + let args = trait_impl.impl_trait.decl_generics in + name_with_generics_to_simple_name ctx trait_decl.llbc_name params args in + let name = flatten_name name in match !backend with | FStar -> StringUtils.lowercase_first_letter name | Coq | HOL4 | Lean -> name @@ -1185,11 +1122,11 @@ let extract_arrow (fmt : F.formatter) () : unit = let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (cg : const_generic) : unit = match cg with - | CGGlobal id -> + | CgGlobal id -> let s = ctx_get_global id ctx in F.pp_print_string fmt s - | CGValue v -> ctx.fmt.extract_literal fmt inside v - | CGVar id -> + | CgValue v -> ctx.fmt.extract_literal fmt inside v + | CgVar id -> let s = ctx_get_const_generic_var id ctx in F.pp_print_string fmt s @@ -1492,8 +1429,9 @@ 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.llbc_name in - let info = SimpleNameMap.find_opt sname (builtin_types_map ()) in + let info = + match_name_find_opt ctx.trans_ctx def.llbc_name (builtin_types_map ()) + in (* Register the filtering information, if there is *) let ctx = match info with diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index a07ad35a..9ae6ce86 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -58,6 +58,13 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) let can_diverge = ref false in let is_rec = ref false in let group_has_builtin_info = ref false in + let name_matcher_ctx : Charon.NameMatcher.ctx = + { + type_decls = m.type_decls; + global_decls = m.global_decls; + trait_decls = m.trait_decls; + } + 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 @@ -65,8 +72,7 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) way. *) let get_builtin_info (f : fun_decl) : ExtractBuiltin.effect_info option = let open ExtractBuiltin in - let name = name_to_simple_name f.name in - SimpleNameMap.find_opt name builtin_fun_effects_map + NameMatcherMap.find_opt name_matcher_ctx f.name builtin_fun_effects_map in (* JP: Why not use a reduce visitor here with a tuple of the values to be diff --git a/compiler/Interpreter.ml b/compiler/Interpreter.ml index 5b2db90d..c2e47da9 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -80,7 +80,7 @@ let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) let regions = List.map (fun _ -> RErased) regions in let types = List.map (fun (v : type_var) -> TVar v.index) types in let const_generics = - List.map (fun (v : const_generic_var) -> CGVar v.index) const_generics + List.map (fun (v : const_generic_var) -> CgVar v.index) const_generics in (* Annoying that we have to generate this substitution here *) let r_subst _ = raise (Failure "Unexpected region") in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 1e28fd4b..38620be0 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -321,7 +321,7 @@ let eval_operand_no_reorganize (config : config) (op : operand) ( ctx0, None, value_as_symbolic v.value, - SymbolicAst.VaCGValue vid, + SymbolicAst.VaCgValue vid, e ))) | CFnPtr _ -> raise (Failure "TODO")) | Copy p -> diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index 01216157..ffdce481 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -31,21 +31,26 @@ let lookup_fun_sig (fun_id : fun_id) (fun_decls : fun_decl FunDeclId.Map.t) : let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : type_decl list * fun_decl list = let open ExtractBuiltin in + let ctx : Charon.NameMatcher.ctx = + { + type_decls = k.type_decls; + global_decls = k.global_decls; + trait_decls = k.trait_decls; + } + in let is_opaque_fun (d : fun_decl) : bool = - let sname = name_to_simple_name d.name in 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 builtin_globals_map)) - && not (SimpleNameMap.mem sname (builtin_funs_map ()))) + || (not (NameMatcherMap.mem ctx d.name builtin_globals_map)) + && not (NameMatcherMap.mem ctx d.name (builtin_funs_map ()))) in let is_opaque_type (d : type_decl) : bool = - let sname = name_to_simple_name d.name in d.kind = Opaque && ((not filter_assumed) - || not (SimpleNameMap.mem sname (builtin_types_map ()))) + || not (NameMatcherMap.mem ctx d.name (builtin_types_map ()))) in (* Note that by checking the function bodies we also the globals *) ( List.filter is_opaque_type (TypeDeclId.Map.values k.type_decls), diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index e6686951..a7ec9336 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -128,9 +128,9 @@ let type_id_to_string (env : fmt_env) (id : type_id) : string = (* TODO: duplicates Charon.PrintTypes.const_generic_to_string *) let const_generic_to_string (env : fmt_env) (cg : const_generic) : string = match cg with - | CGGlobal id -> global_decl_id_to_string env id - | CGVar id -> const_generic_var_id_to_string env id - | CGValue lit -> literal_to_string lit + | CgGlobal id -> global_decl_id_to_string env id + | CgVar id -> const_generic_var_id_to_string env id + | CgValue lit -> literal_to_string lit let rec ty_to_string (env : fmt_env) (inside : bool) (ty : ty) : string = match ty with diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 5f92d18a..06270621 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -111,7 +111,7 @@ let ty_substitute (subst : subst) (ty : ty) : ty = object inherit [_] map_ty method! visit_TVar _ var_id = subst.ty_subst var_id - method! visit_CGVar _ var_id = subst.cg_subst var_id + method! visit_CgVar _ var_id = subst.cg_subst var_id method! visit_Clause _ id = subst.tr_subst id method! visit_Self _ = subst.tr_self end diff --git a/compiler/StringUtils.ml b/compiler/StringUtils.ml index 161df27b..3ab4e808 100644 --- a/compiler/StringUtils.ml +++ b/compiler/StringUtils.ml @@ -1,111 +1 @@ -(** Utilities to work on strings, character per character. - - They operate on ASCII strings, and are used by the project to convert - Rust names: Rust names are not fancy, so it shouldn't be a problem. - - Rk.: the poor support of OCaml for char manipulation is really annoying... - *) - -let code_0 = 48 -let code_9 = 57 -let code_A = 65 -let code_Z = 90 -let code_a = 97 -let code_z = 122 - -let is_lowercase_ascii (c : char) : bool = - let c = Char.code c in - code_a <= c && c <= code_z - -let is_uppercase_ascii (c : char) : bool = - let c = Char.code c in - code_A <= c && c <= code_Z - -let is_letter_ascii (c : char) : bool = - is_lowercase_ascii c || is_uppercase_ascii c - -let is_digit_ascii (c : char) : bool = - let c = Char.code c in - code_0 <= c && c <= code_9 - -let lowercase_ascii = Char.lowercase_ascii -let uppercase_ascii = Char.uppercase_ascii - -(** Using buffers as per: - {{: https://stackoverflow.com/questions/29957418/how-to-convert-char-list-to-string-in-ocaml} stackoverflow} - *) -let string_of_chars (chars : char list) : string = - let buf = Buffer.create (List.length chars) in - List.iter (Buffer.add_char buf) chars; - Buffer.contents buf - -let string_to_chars (s : string) : char list = - let length = String.length s in - let rec apply i = - if i = length then [] else String.get s i :: apply (i + 1) - in - apply 0 - -(** This operates on ASCII *) -let to_camel_case (s : string) : string = - (* Note that we rebuild the string in reverse order *) - let apply ((prev_is_under, acc) : bool * char list) (c : char) : - bool * char list = - if c = '_' then (true, acc) - else - let c = if prev_is_under then uppercase_ascii c else c in - (false, c :: acc) - in - let _, chars = List.fold_left apply (true, []) (string_to_chars s) in - string_of_chars (List.rev chars) - -(** This operates on ASCII *) -let to_snake_case (s : string) : string = - (* Note that we rebuild the string in reverse order *) - let apply ((prev_is_low, prev_is_digit, acc) : bool * bool * char list) - (c : char) : bool * bool * char list = - let acc = - if c = '_' then acc - else if prev_is_digit then if is_letter_ascii c then '_' :: acc else acc - else if prev_is_low then - if (is_lowercase_ascii c || is_digit_ascii c) && c <> '_' then acc - else '_' :: acc - else acc - in - let prev_is_low = is_lowercase_ascii c in - let prev_is_digit = is_digit_ascii c in - let c = lowercase_ascii c in - (prev_is_low, prev_is_digit, c :: acc) - in - let _, _, chars = - List.fold_left apply (false, false, []) (string_to_chars s) - in - string_of_chars (List.rev chars) - -(** Applies a map operation. - - This is very inefficient, but shouldn't be used much. - *) -let map (f : char -> string) (s : string) : string = - let sl = List.map f (string_to_chars s) in - let sl = List.map string_to_chars sl in - string_of_chars (List.concat sl) - -let capitalize_first_letter (s : string) : string = - let s = string_to_chars s in - let s = match s with [] -> s | c :: s' -> uppercase_ascii c :: s' in - string_of_chars s - -let lowercase_first_letter (s : string) : string = - let s = string_to_chars s in - let s = match s with [] -> s | c :: s' -> lowercase_ascii c :: s' in - string_of_chars s - -(** Unit tests *) -let _ = - assert (to_camel_case "hello_world" = "HelloWorld"); - assert (to_snake_case "HelloWorld36Hello" = "hello_world36_hello"); - assert (to_snake_case "HELLO" = "hello"); - assert (to_snake_case "T1" = "t1"); - assert (to_camel_case "list" = "List"); - assert (to_snake_case "is_cons" = "is_cons") +include Charon.StringUtils diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 01509dec..73e7f71d 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -29,7 +29,7 @@ let st_substitute_visitor (subst : subst) = (* We should never get here because we reimplemented [visit_TypeVar] *) raise (Failure "Unexpected") - method! visit_CGVar _ id = subst.cg_subst id + method! visit_CgVar _ id = subst.cg_subst id method! visit_const_generic_var_id _ _ = (* We should never get here because we reimplemented [visit_Var] *) @@ -71,7 +71,7 @@ let erase_regions_subst : subst = { r_subst = (fun _ -> RErased); ty_subst = (fun vid -> TVar vid); - cg_subst = (fun id -> CGVar id); + cg_subst = (fun id -> CgVar id); tr_subst = (fun id -> Clause id); tr_self = Self; } diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index 7c5d28a7..c9820ba5 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -240,7 +240,7 @@ and value_aggregate = | VaSingleValue of typed_value (** Regular case *) | VaArray of typed_value list (** This is used when introducing array aggregates *) - | VaCGValue of const_generic_var_id + | VaCgValue of const_generic_var_id (** This is used when evaluating a const generic value: in the interpreter, we introduce a fresh symbolic value. *) | VaTraitConstValue of trait_ref * generic_args * string diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 7dad54e1..69ff4df1 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2475,7 +2475,7 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) { struct_id = TAssumed TArray; init = None; updates = values } in { e = StructUpdate su; ty = var.ty } - | VaCGValue cg_id -> { e = CVar cg_id; ty = var.ty } + | VaCgValue cg_id -> { e = CVar cg_id; ty = var.ty } | VaTraitConstValue (trait_ref, generics, const_name) -> let type_infos = ctx.type_context.type_infos in let trait_ref = translate_fwd_trait_ref type_infos trait_ref in @@ -2726,7 +2726,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let types = List.map (fun (ty : T.type_var) -> TVar ty.T.index) types in let const_generics = List.map - (fun (cg : T.const_generic_var) -> T.CGVar cg.T.index) + (fun (cg : T.const_generic_var) -> T.CgVar cg.T.index) const_generics in let trait_refs = diff --git a/compiler/Translate.ml b/compiler/Translate.ml index cf23fd44..271d19ad 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -477,8 +477,7 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) let types_map = builtin_types_map () in List.map (fun (def : Pure.type_decl) -> - let sname = name_to_simple_name def.llbc_name in - SimpleNameMap.find_opt sname types_map <> None) + match_name_find_opt ctx.trans_ctx def.llbc_name types_map <> None) defs in @@ -545,9 +544,9 @@ let export_global (fmt : Format.formatter) (config : gen_config) (ctx : gen_ctx) (* 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 ExtractBuiltin in - let sname = name_to_simple_name global.name in let extract = - extract && SimpleNameMap.find_opt sname builtin_globals_map = None + extract + && match_name_find_opt ctx.trans_ctx global.name builtin_globals_map = None in if extract then (* We don't wrap global declaration groups between calls to functions @@ -661,8 +660,7 @@ let export_functions_group (fmt : Format.formatter) (config : gen_config) let funs_map = builtin_funs_map () in List.map (fun (trans : pure_fun_translation) -> - let sname = name_to_simple_name trans.fwd.f.llbc_name in - SimpleNameMap.find_opt sname funs_map <> None) + match_name_find_opt ctx.trans_ctx trans.fwd.f.llbc_name funs_map <> None) pure_ls in @@ -755,8 +753,11 @@ let export_trait_decl (fmt : Format.formatter) (_config : gen_config) let trait_decl = 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.llbc_name in - if SimpleNameMap.find_opt sname (builtin_trait_decls_map ()) = None then ( + if + match_name_find_opt ctx.trans_ctx trait_decl.llbc_name + (builtin_trait_decls_map ()) + = None + then ( let ctx = { ctx with trait_decl_id = Some trait_decl.def_id } in if extract_decl then Extract.extract_trait_decl ctx fmt trait_decl; if extract_extra_info then @@ -775,9 +776,11 @@ let export_trait_impl (fmt : Format.formatter) (_config : gen_config) (* Check if the trait implementation is builtin *) let builtin_info = let open ExtractBuiltin in - let type_sname = name_to_simple_name trait_impl.llbc_name in - let trait_sname = name_to_simple_name trait_decl.llbc_name in - SimpleNamePairMap.find_opt (type_sname, trait_sname) + let trait_impl = + TraitImplId.Map.find trait_impl.def_id ctx.crate.trait_impls + in + match_name_with_generics_find_opt ctx.trans_ctx trait_decl.llbc_name + trait_impl.impl_trait.decl_generics (builtin_trait_impls_map ()) in match builtin_info with diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index a974cdee..f251e169 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -1,6 +1,7 @@ (** Some utilities for the translation *) open Contexts +open ExtractName (** The local logger *) let log = Logging.translate_log @@ -29,3 +30,50 @@ let trans_ctx_to_pure_fmt_env (ctx : trans_ctx) : PrintPure.fmt_env = let name_to_string (ctx : trans_ctx) = Print.Types.name_to_string (trans_ctx_to_fmt_env ctx) + +let match_name_find_opt (ctx : trans_ctx) (name : Types.name) + (m : 'a NameMatcherMap.t) : 'a option = + let open Charon.NameMatcher in + let open ExtractBuiltin in + let mctx : ctx = + { + type_decls = ctx.type_ctx.type_decls; + global_decls = ctx.global_ctx.global_decls; + trait_decls = ctx.trait_decls_ctx.trait_decls; + } + in + NameMatcherMap.find_opt mctx name m + +let match_name_with_generics_find_opt (ctx : trans_ctx) (name : Types.name) + (generics : Types.generic_args) (m : 'a NameMatcherMap.t) : 'a option = + let open Charon.NameMatcher in + let open ExtractBuiltin in + let mctx : ctx = + { + type_decls = ctx.type_ctx.type_decls; + global_decls = ctx.global_ctx.global_decls; + trait_decls = ctx.trait_decls_ctx.trait_decls; + } + in + NameMatcherMap.find_with_generics_opt mctx name generics m + +let name_to_simple_name (ctx : trans_ctx) (n : Types.name) : string list = + let mctx : Charon.NameMatcher.ctx = + { + type_decls = ctx.type_ctx.type_decls; + global_decls = ctx.global_ctx.global_decls; + trait_decls = ctx.trait_decls_ctx.trait_decls; + } + in + name_to_simple_name mctx n + +let name_with_generics_to_simple_name (ctx : trans_ctx) (n : Types.name) + (p : Types.generic_params) (g : Types.generic_args) : string list = + let mctx : Charon.NameMatcher.ctx = + { + type_decls = ctx.type_ctx.type_decls; + global_decls = ctx.global_ctx.global_decls; + trait_decls = ctx.trait_decls_ctx.trait_decls; + } + in + name_with_generics_to_simple_name mctx n p g diff --git a/compiler/dune b/compiler/dune index 43ce86c8..39ad6260 100644 --- a/compiler/dune +++ b/compiler/dune @@ -10,7 +10,7 @@ (public_name aeneas) ;; The name as revealed to the projects importing this library (preprocess (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) - (libraries charon core_unix unionFind ocamlgraph) + (libraries charon core_unix unionFind ocamlgraph str) (modules AssociatedTypes Assumed @@ -24,6 +24,7 @@ Extract ExtractBase ExtractBuiltin + ExtractName ExtractTypes FunsAnalysis Identifiers -- cgit v1.2.3 From 5aa37b3a0a539f9ae37a119b9ce7c8dee504125e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 20 Nov 2023 22:38:58 +0100 Subject: Fix minor issues --- compiler/ExtractBuiltin.ml | 2 -- compiler/PureMicroPasses.ml | 66 +++++++++------------------------------------ 2 files changed, 13 insertions(+), 55 deletions(-) diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index d15905a2..106451cc 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -331,8 +331,6 @@ let builtin_fun_effects = (* TODO: redundancy with the funs information below *) "alloc::vec::{alloc::vec::Vec<@T>}::new"; "alloc::vec::{alloc::vec::Vec<@T>}::len"; - "alloc::boxed::{Box<@T>}::deref"; - "alloc::boxed::{Box<@T>}::deref_mut"; "core::mem::replace"; "core::mem::take"; ] diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 50a50815..96421925 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1250,6 +1250,7 @@ let filter_if_backward_with_no_outputs (def : fun_decl) : fun_decl option = !Config.filter_useless_functions && Option.is_some def.back_id && def.signature.output = mk_result_ty mk_unit_ty + || def.signature.output = mk_unit_ty then None else Some def @@ -1508,8 +1509,8 @@ let unit_vars_to_unit (def : fun_decl) : fun_decl = let body = Some { body with body = body_exp; inputs_lvs } in { def with body } -(** Eliminate the box functions like [Box::new], [Box::deref], etc. Most of them - are translated to identity, and [Box::free] is translated to [()]. +(** Eliminate the box functions like [Box::new] (which is translated to the + identity) and [Box::free] (which is translated to [()]). Note that the box types have already been eliminated during the translation from symbolic to pure. @@ -1518,7 +1519,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 @@ -1546,53 +1547,6 @@ let eliminate_box_functions (ctx : trans_ctx) (def : fun_decl) : fun_decl = | ArrayRepeat ), _ ) -> super#visit_texpression env e) - | Fun (FromLlbc (FunId (FRegular fid), _lp_id, rg_id)) -> ( - (* TODO: use a more general matching mechanism *) - (* Lookup the function name *) - let def = FunDeclId.Map.find fid ctx.fun_ctx.fun_decls in - (* We first need to check if the name is "alloc::boxed::Box::_" *) - match def.name with - | [ - PeIdent ("alloc", _); - PeIdent ("boxed", _); - PeImpl impl; - PeIdent (fname, _); - ] -> ( - match impl.ty with - | TAdt - ( TAssumed TBox, - { - regions = []; - types = [ TVar _ ]; - const_generics = []; - trait_refs = []; - } ) -> ( - match (fname, rg_id) with - | "deref", None -> - (* [Box::deref] forward is the identity *) - let arg, args = Collections.List.pop args in - mk_apps arg args - | "deref", Some _ -> - (* [Box::deref] backward is [()] (doesn't give back anything) *) - assert (args = []); - mk_unit_rvalue - | "deref_mut", None -> - (* [Box::deref_mut] forward is the identity *) - let arg, args = Collections.List.pop args in - mk_apps arg args - | "deref_mut", Some _ -> - (* [Box::deref_mut] back is almost the identity: - * let box_deref_mut (x_init : t) (x_back : t) : t = x_back - * *) - let arg, args = - match args with - | _ :: given_back :: args -> (given_back, args) - | _ -> raise (Failure "Unreachable") - in - mk_apps arg args - | _ -> super#visit_texpression env e) - | _ -> super#visit_texpression env e) - | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e) | _ -> super#visit_texpression env e end @@ -1966,11 +1920,17 @@ let apply_passes_to_def (ctx : trans_ctx) (def : fun_decl) : * Note that the calls to those functions should already have been removed, * when translating from symbolic to pure. Here, we remove the definitions * altogether, because they are now useless *) - let def = filter_if_backward_with_no_outputs def in + let name = def.name ^ PrintPure.fun_suffix def.loop_id def.back_id in + let opt_def = filter_if_backward_with_no_outputs def in - match def with - | None -> None + match opt_def with + | None -> + log#ldebug (lazy ("filtered (backward with no outputs): " ^ name ^ "\n")); + None | Some def -> + log#ldebug + (lazy ("not filtered (not backward with no outputs): " ^ name ^ "\n")); + (* Extract the loop definitions by removing the {!Loop} node *) let def, loops = decompose_loops def in -- cgit v1.2.3 From db58a6bcc95c66febc70e90af928feae7dddf56c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 20 Nov 2023 22:48:38 +0100 Subject: Fix minor issues --- compiler/ExtractBuiltin.ml | 8 +++++--- compiler/Logging.ml | 3 +++ compiler/Main.ml | 1 + 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 106451cc..2c3c8106 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -8,6 +8,8 @@ open Config open Charon.NameMatcher (* TODO: include? *) include ExtractName (* TODO: only open? *) +let log = Logging.builtin_log + (** Small utility to memoize some computations *) let mk_memoized (f : unit -> 'a) : unit -> 'a = let r = ref None in @@ -492,9 +494,9 @@ let builtin_trait_impls_info () : (pattern * (bool list option * string)) list = in [ (* core::ops::Deref> *) - fmt "core::ops::Deref>" (); - (* core::ops::Deref> *) - fmt "core::ops::Deref>" (); + fmt "core::ops::deref::Deref>" (); + (* core::ops::DerefMut> *) + fmt "core::ops::deref::DerefMut>" (); (* core::ops::index::Index<[T], I> *) fmt "core::ops::index::Index<[@T], @I>" (); (* core::ops::index::IndexMut<[T], I> *) diff --git a/compiler/Logging.ml b/compiler/Logging.ml index f4ad87a9..9c20f32f 100644 --- a/compiler/Logging.ml +++ b/compiler/Logging.ml @@ -27,6 +27,9 @@ let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses" (** Logger for ExtractBase *) let extract_log = L.get_logger "MainLogger.ExtractBase" +(** Logger for ExtractBuiltin *) +let builtin_log = L.get_logger "MainLogger.Builtin" + (** Logger for Interpreter *) let interpreter_log = L.get_logger "MainLogger.Interpreter" diff --git a/compiler/Main.ml b/compiler/Main.ml index 94e50a08..0daf454d 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -38,6 +38,7 @@ let _ = symbolic_to_pure_log#set_level EL.Info; pure_micro_passes_log#set_level EL.Info; extract_log#set_level EL.Info; + builtin_log#set_level EL.Info; translate_log#set_level EL.Info; scc_log#set_level EL.Info; reorder_decls_log#set_level EL.Info -- cgit v1.2.3 From dcd34ceed0c52738b1bb8139e7130db9bad1a774 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 10:22:51 +0100 Subject: Fix issues with the builtin names --- compiler/ExtractBuiltin.ml | 131 +++++++++++++++++++++++++--------------- compiler/ExtractName.ml | 8 ++- tests/lean/NoNestedBorrows.lean | 12 ++-- 3 files changed, 95 insertions(+), 56 deletions(-) diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 2c3c8106..f4f34155 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -24,7 +24,11 @@ let mk_memoized (f : unit -> 'a) : unit -> 'a = g let split_on_separator (s : string) : string list = - Str.split (Str.regexp "::") s + Str.split (Str.regexp "\\(::\\|\\.\\)") s + +let () = + assert (split_on_separator "x::y::z" = [ "x"; "y"; "z" ]); + assert (split_on_separator "x.y.z" = [ "x"; "y"; "z" ]) (** Switch between two values depending on the target backend. @@ -243,20 +247,24 @@ let builtin_funs () : (pattern * bool list option * builtin_fun_info list) list in [ mk_fun "core::mem::replace" None None true false; - mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::new" None None false false; - mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::push" None + mk_fun "core::slice::{[@T]}::len" + (Some (backend_choice "slice::len" "Slice::len")) + None true false; + mk_fun "alloc::vec::{alloc::vec::Vec<@T, alloc::alloc::Global>}::new" + (Some "alloc::vec::Vec::new") None false false; + mk_fun "alloc::vec::{alloc::vec::Vec<@T, @A>}::push" None (Some [ true; false ]) true true; - mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::insert" None + mk_fun "alloc::vec::{alloc::vec::Vec<@T, @A>}::insert" None (Some [ true; false ]) true true; - mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::len" None + mk_fun "alloc::vec::{alloc::vec::Vec<@T, @A>}::len" None (Some [ true; false ]) true false; - mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::index" None + mk_fun "alloc::vec::{alloc::vec::Vec<@T, @A>}::index" None (Some [ true; true; false ]) true false; - mk_fun "alloc::vec::{alloc::vec::Vec<@T>}::index_mut" None + mk_fun "alloc::vec::{alloc::vec::Vec<@T, @A>}::index_mut" None (Some [ true; true; false ]) true false; mk_fun "alloc::boxed::{Box<@T>}::deref" None @@ -269,14 +277,19 @@ let builtin_funs () : (pattern * bool list option * builtin_fun_info list) list mk_fun "core::slice::index::{[@T]}::index_mut" None None true false; mk_fun "core::array::{[@T; @C]}::index" None None true false; mk_fun "core::array::{[@T; @C]}::index_mut" None None true false; - mk_fun "core::slice::index::{Range<@T>}::get" None None true false; - mk_fun "core::slice::index::{Range<@T>}::get_mut" None None true false; - mk_fun "core::slice::index::{Range<@T>}::index" None None true false; - mk_fun "core::slice::index::{Range<@T>}::index_mut" None None true false; - mk_fun "core::slice::index::{Range<@T>}::get_unchecked" None None false - false; - mk_fun "core::slice::index::{Range<@T>}::get_unchecked_mut" None None false - false; + mk_fun "core::slice::index::{core::ops::range::Range}::get" + (Some "core::slice::index::Range::get") None true false; + mk_fun "core::slice::index::{core::ops::range::Range}::get_mut" + (Some "core::slice::index::Range::get_mut") None true false; + mk_fun "core::slice::index::{core::ops::range::Range}::index" + (Some "core::slice::index::Range::index") None true false; + mk_fun "core::slice::index::{core::ops::range::Range}::index_mut" + (Some "core::slice::index::Range::index_mut") None true false; + mk_fun "core::slice::index::{core::ops::range::Range}::get_unchecked" + (Some "core::slice::index::Range::get_unchecked") None false false; + mk_fun + "core::slice::index::{core::ops::range::Range}::get_unchecked_mut" + (Some "core::slice::index::Range::get_unchecked_mut") None false false; mk_fun "core::slice::index::{usize}::get" None None true false; mk_fun "core::slice::index::{usize}::get_mut" None None true false; mk_fun "core::slice::index::{usize}::get_unchecked" None None false false; @@ -330,9 +343,10 @@ 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::{alloc::vec::Vec<@T>}::new"; - "alloc::vec::{alloc::vec::Vec<@T>}::len"; + (* TODO: redundancy with the funs information above *) + "core::slice::{[@T]}::len"; + "alloc::vec::{alloc::vec::Vec<@T, alloc::alloc::Global>}::new"; + "alloc::vec::{alloc::vec::Vec<@T, @A>}::len"; "core::mem::replace"; "core::mem::take"; ] @@ -345,11 +359,11 @@ let builtin_fun_effects = in let no_state_funs = [ - (* TODO: redundancy with the funs information below *) - "alloc::vec::{alloc::vec::Vec<@T>}::push"; - "alloc::vec::{alloc::vec::Vec<@T>}::index"; - "alloc::vec::{alloc::vec::Vec<@T>}::index_mut"; - "alloc::vec::{alloc::vec::Vec<@T>}::index_mut_back"; + (* TODO: redundancy with the funs information above *) + "alloc::vec::{alloc::vec::Vec<@T, @A>}::push"; + "alloc::vec::{alloc::vec::Vec<@T, @A>}::index"; + "alloc::vec::{alloc::vec::Vec<@T, @A>}::index_mut"; + "alloc::vec::{alloc::vec::Vec<@T, @A>}::index_mut_back"; ] in let no_state_funs = @@ -395,10 +409,14 @@ let builtin_trait_decls_info () = let consts = [] in let types = let mk_type item_name = + let type_name = + if !record_fields_short_names then item_name + else extract_name ^ "_" ^ item_name + in let type_name = match !backend with - | Coq | FStar | HOL4 -> extract_name ^ "_" ^ item_name - | Lean -> item_name + | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter type_name + | Lean -> type_name in let clauses = [] in (item_name, (type_name, clauses)) @@ -409,9 +427,8 @@ let builtin_trait_decls_info () = 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 + if !record_fields_short_names then item_name + else extract_name ^ "_" ^ item_name in let back_no_suffix = false in let fwd_suffix = if with_back && back_no_suffix then "_fwd" else "" in @@ -442,8 +459,7 @@ let builtin_trait_decls_info () = ~methods:[ ("deref", true) ] (); (* DerefMut *) - mk_trait "core::ops::deref::DerefMut" - ~parent_clauses:[ backend_choice "deref_inst" "derefInst" ] + mk_trait "core::ops::deref::DerefMut" ~parent_clauses:[ "derefInst" ] ~methods:[ ("deref_mut", true) ] (); (* Index *) @@ -451,15 +467,13 @@ let builtin_trait_decls_info () = ~methods:[ ("index", true) ] (); (* IndexMut *) - mk_trait "core::ops::index::IndexMut" - ~parent_clauses:[ backend_choice "index_inst" "indexInst" ] + mk_trait "core::ops::index::IndexMut" ~parent_clauses:[ "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" ] + mk_trait "core::slice::index::SliceIndex" ~parent_clauses:[ "sealedInst" ] ~types:[ "Output" ] ~methods: [ @@ -482,43 +496,64 @@ let mk_builtin_trait_decls_map () = let builtin_trait_decls_map = mk_memoized mk_builtin_trait_decls_map let builtin_trait_impls_info () : (pattern * (bool list option * string)) list = - let fmt (rust_name : string) ?(filter : bool list option = None) () : + let fmt (rust_name : string) ?(extract_name : string option = None) + ?(filter : bool list option = None) () : pattern * (bool list option * string) = let rust_name = parse_pattern rust_name in let name = - let name = pattern_to_trait_impl_extract_name rust_name in let sep = backend_choice "_" "." in + let name = + match extract_name with + | None -> pattern_to_trait_impl_extract_name rust_name + | Some name -> split_on_separator name + in String.concat sep name in (rust_name, (filter, name)) in [ (* core::ops::Deref> *) - fmt "core::ops::deref::Deref>" (); + fmt "core::ops::deref::Deref>" + ~extract_name:(Some "alloc::boxed::Box::coreopsDerefInst") (); (* core::ops::DerefMut> *) - fmt "core::ops::deref::DerefMut>" (); + fmt "core::ops::deref::DerefMut>" + ~extract_name:(Some "alloc::boxed::Box::coreopsDerefMutInst") (); (* core::ops::index::Index<[T], I> *) - fmt "core::ops::index::Index<[@T], @I>" (); + fmt "core::ops::index::Index<[@T], @I>" + ~extract_name:(Some "core::ops::index::IndexSliceTIInst") (); (* core::ops::index::IndexMut<[T], I> *) - fmt "core::ops::index::IndexMut<[@T], @I>" (); + fmt "core::ops::index::IndexMut<[@T], @I>" + ~extract_name:(Some "core::ops::index::IndexMutSliceTIInst") (); (* core::slice::index::private_slice_index::Sealed> *) - fmt "core::slice::index::private_slice_index::Sealed>" (); + fmt + "core::slice::index::private_slice_index::Sealed>" + ~extract_name: + (Some "core.slice.index.private_slice_index.SealedRangeUsizeInst") (); (* core::slice::index::SliceIndex, [T]> *) - fmt "core::slice::index::SliceIndex, [@T]>" (); + fmt "core::slice::index::SliceIndex, [@T]>" + ~extract_name:(Some "core::slice::index::SliceIndexRangeUsizeSliceTInst") + (); (* core::ops::index::Index<[T; N], I> *) - fmt "core::ops::index::Index<[@T; @N], @I>" (); + fmt "core::ops::index::Index<[@T; @N], @I>" + ~extract_name:(Some "core::ops::index::IndexArrayInst") (); (* core::ops::index::IndexMut<[T; N], I> *) - fmt "core::ops::index::IndexMut<[@T; @N], @I>" (); + fmt "core::ops::index::IndexMut<[@T; @N], @I>" + ~extract_name:(Some "core::ops::index::IndexMutArrayIInst") (); (* core::slice::index::private_slice_index::Sealed *) - fmt "core::slice::index::private_slice_index::Sealed" (); + fmt "core::slice::index::private_slice_index::Sealed" + ~extract_name: + (Some "core::slice::index::private_slice_index::SealedUsizeInst") (); (* core::slice::index::SliceIndex *) - fmt "core::slice::index::SliceIndex" (); + fmt "core::slice::index::SliceIndex" + ~extract_name:(Some "core::slice::index::SliceIndexUsizeSliceTInst") (); (* core::ops::index::Index, T> *) - fmt "core::ops::index::Index, @T>" + fmt "core::ops::index::Index, @T>" + ~extract_name:(Some "alloc::vec::Vec::coreopsindexIndexInst") ~filter:(Some [ true; true; false ]) (); (* core::ops::index::IndexMut, T> *) - fmt "core::ops::index::IndexMut, @T>" + fmt "core::ops::index::IndexMut, @T>" + ~extract_name:(Some "alloc::vec::Vec::coreopsindexIndexMutInst") ~filter:(Some [ true; true; false ]) (); ] diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 4f5ca0d1..6d50ed73 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -35,7 +35,7 @@ end *) let pattern_to_extract_name (is_trait_impl : bool) (name : pattern) : string list = - let c = { tgt_kind = TkName } in + let c = { tgt = TkName } in let is_var (g : generic_arg) : bool = match g with | GExpr (EVar _) -> true @@ -83,11 +83,13 @@ let pattern_to_trait_impl_extract_name = pattern_to_extract_name true names we derive from the patterns (for the builtin definitions) are consistent with the extraction names we derive from the Rust names *) let name_to_simple_name (ctx : ctx) (n : Types.name) : string list = - pattern_to_extract_name false (name_to_pattern ctx n) + let c : to_pat_config = { tgt = TkName } in + pattern_to_extract_name false (name_to_pattern ctx c n) let name_with_generics_to_simple_name (ctx : ctx) (n : Types.name) (p : Types.generic_params) (g : Types.generic_args) : string list = - pattern_to_extract_name true (name_with_generics_to_pattern ctx n p g) + let c : to_pat_config = { tgt = TkName } in + pattern_to_extract_name true (name_with_generics_to_pattern ctx c n p g) (* (* Prepare a name. diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index c4a6a265..79049837 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -151,11 +151,13 @@ def test_list1 : Result Unit := /- [no_nested_borrows::test_box1]: forward function -/ def test_box1 : Result Unit := - let b := 1#i32 - let x := b - if not (x = 1#i32) - then Result.fail Error.panic - else Result.ret () + do + let b := 0#i32 + let b0 ← alloc.boxed.Box.deref_mut_back I32 b 1#i32 + let x ← alloc.boxed.Box.deref I32 b0 + if not (x = 1#i32) + then Result.fail Error.panic + else Result.ret () /- Unit test for [no_nested_borrows::test_box1] -/ #assert (test_box1 == .ret ()) -- cgit v1.2.3 From c3b6ad3685995b3b96dc88789e8512560d3257b3 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 10:23:14 +0100 Subject: Update the standard libraries --- backends/coq/Primitives.v | 56 +++++++++++++++------------ backends/fstar/Primitives.fst | 56 +++++++++++++-------------- backends/lean/Base/Primitives/Alloc.lean | 6 +-- backends/lean/Base/Primitives/ArraySlice.lean | 39 +++++++++---------- backends/lean/Base/Primitives/Vec.lean | 6 +-- 5 files changed, 85 insertions(+), 78 deletions(-) diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 85e38f01..846a5e4b 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -683,22 +683,14 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; core_slice_index_SliceIndex_get := core_slice_index_Range_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; @@ -711,16 +703,24 @@ Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 3297803c..19c4e7a3 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -559,22 +559,14 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; get = core_slice_index_Range_get t; get_mut = core_slice_index_Range_get_mut t; @@ -587,16 +579,24 @@ let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/backends/lean/Base/Primitives/Alloc.lean b/backends/lean/Base/Primitives/Alloc.lean index 34590499..6c89c6bb 100644 --- a/backends/lean/Base/Primitives/Alloc.lean +++ b/backends/lean/Base/Primitives/Alloc.lean @@ -16,16 +16,16 @@ def deref_mut (T : Type) (x : T) : Result T := ret x def deref_mut_back (T : Type) (_ : T) (x : T) : Result T := ret x /-- Trait instance -/ -def coreOpsDerefInst (Self : Type) : +def coreopsDerefInst (Self : Type) : core.ops.deref.Deref Self := { Target := Self deref := deref Self } /-- Trait instance -/ -def coreOpsDerefMutInst (Self : Type) : +def coreopsDerefMutInst (Self : Type) : core.ops.deref.DerefMut Self := { - derefInst := coreOpsDerefInst Self + derefInst := coreopsDerefInst Self deref_mut := deref_mut Self deref_mut_back := deref_mut_back Self } diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean index cfc9a6b2..8bb9a855 100644 --- a/backends/lean/Base/Primitives/ArraySlice.lean +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -439,23 +439,14 @@ def core.array.Array.index_mut_back (a : Array T N) (i : I) (x : inst.indexInst.Output) : Result (Array T N) := sorry -- TODO -/- Trait implementation: [core::slice::index::[T]] -/ -def core.slice.index.Slice.coreopsindexIndexInst (T I : Type) - (inst : core.slice.index.SliceIndex I (Slice T)) : - core.ops.index.Index (Slice T) I := { - Output := inst.Output - index := core.slice.index.Slice.index T I inst -} - /- Trait implementation: [core::slice::index::private_slice_index::Range] -/ -def core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst +def core.slice.index.private_slice_index.SealedRangeUsizeInst : core.slice.index.private_slice_index.Sealed (Range Usize) := {} /- Trait implementation: [core::slice::index::Range] -/ -def core.slice.index.Range.coresliceindexSliceIndexInst (T : Type) : +def core.slice.index.SliceIndexRangeUsizeSliceTInst (T : Type) : core.slice.index.SliceIndex (Range Usize) (Slice T) := { - sealedInst := - core.slice.index.private_slice_index.Range.coresliceindexprivate_slice_indexSealedInst + sealedInst := core.slice.index.private_slice_index.SealedRangeUsizeInst Output := Slice T get := core.slice.index.Range.get T get_mut := core.slice.index.Range.get_mut T @@ -468,16 +459,24 @@ def core.slice.index.Range.coresliceindexSliceIndexInst (T : Type) : } /- Trait implementation: [core::slice::index::[T]] -/ -def core.slice.index.Slice.coreopsindexIndexMutInst (T I : Type) +def core.ops.index.IndexSliceTIInst (T I : Type) + (inst : core.slice.index.SliceIndex I (Slice T)) : + core.ops.index.Index (Slice T) I := { + Output := inst.Output + index := core.slice.index.Slice.index T I inst +} + +/- Trait implementation: [core::slice::index::[T]] -/ +def core.ops.index.IndexMutSliceTIInst (T I : Type) (inst : core.slice.index.SliceIndex I (Slice T)) : core.ops.index.IndexMut (Slice T) I := { - indexInst := core.slice.index.Slice.coreopsindexIndexInst T I inst + indexInst := core.ops.index.IndexSliceTIInst T I inst index_mut := core.slice.index.Slice.index_mut T I inst index_mut_back := core.slice.index.Slice.index_mut_back T I inst } /- Trait implementation: [core::array::[T; N]] -/ -def core.array.Array.coreopsindexIndexInst (T I : Type) (N : Usize) +def core.ops.index.IndexArrayIInst (T I : Type) (N : Usize) (inst : core.ops.index.Index (Slice T) I) : core.ops.index.Index (Array T N) I := { Output := inst.Output @@ -485,10 +484,10 @@ def core.array.Array.coreopsindexIndexInst (T I : Type) (N : Usize) } /- Trait implementation: [core::array::[T; N]] -/ -def core.array.Array.coreopsindexIndexMutInst (T I : Type) (N : Usize) +def core.ops.index.IndexMutArrayIInst (T I : Type) (N : Usize) (inst : core.ops.index.IndexMut (Slice T) I) : core.ops.index.IndexMut (Array T N) I := { - indexInst := core.array.Array.coreopsindexIndexInst T I N inst.indexInst + indexInst := core.ops.index.IndexArrayIInst T I N inst.indexInst index_mut := core.array.Array.index_mut T I N inst index_mut_back := core.array.Array.index_mut_back T I N inst } @@ -532,13 +531,13 @@ def core.slice.index.Usize.index_mut_back sorry -- TODO /- Trait implementation: [core::slice::index::private_slice_index::usize] -/ -def core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst +def core.slice.index.private_slice_index.SealedUsizeInst : core.slice.index.private_slice_index.Sealed Usize := {} /- Trait implementation: [core::slice::index::usize] -/ -def core.slice.index.usize.coresliceindexSliceIndexInst (T : Type) : +def core.slice.index.SliceIndexUsizeSliceTInst (T : Type) : core.slice.index.SliceIndex Usize (Slice T) := { - sealedInst := core.slice.index.private_slice_index.usize.coresliceindexprivate_slice_indexSealedInst + sealedInst := core.slice.index.private_slice_index.SealedUsizeInst Output := T get := core.slice.index.Usize.get T get_mut := core.slice.index.Usize.get_mut T diff --git a/backends/lean/Base/Primitives/Vec.lean b/backends/lean/Base/Primitives/Vec.lean index bbed6082..e600a151 100644 --- a/backends/lean/Base/Primitives/Vec.lean +++ b/backends/lean/Base/Primitives/Vec.lean @@ -153,19 +153,19 @@ def Vec.coreopsindexIndexMutInst (T I : Type) @[simp] theorem Vec.index_slice_index {α : Type} (v : Vec α) (i : Usize) : - Vec.index α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i = + Vec.index α Usize (core.slice.index.SliceIndexUsizeSliceTInst α) v i = Vec.index_usize v i := sorry @[simp] theorem Vec.index_mut_slice_index {α : Type} (v : Vec α) (i : Usize) : - Vec.index_mut α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i = + Vec.index_mut α Usize (core.slice.index.SliceIndexUsizeSliceTInst α) v i = Vec.index_usize v i := sorry @[simp] theorem Vec.index_mut_back_slice_index {α : Type} (v : Vec α) (i : Usize) (x : α) : - Vec.index_mut_back α Usize (core.slice.index.usize.coresliceindexSliceIndexInst α) v i x = + Vec.index_mut_back α Usize (core.slice.index.SliceIndexUsizeSliceTInst α) v i x = Vec.update_usize v i x := sorry -- cgit v1.2.3 From 1dbdd9e316e690e5c63de2e1923afad520c76e4d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 10:27:08 +0100 Subject: Update more names --- backends/coq/Primitives.v | 32 +++++++++++++-------------- backends/fstar/Primitives.fst | 32 +++++++++++++-------------- backends/lean/Base/Primitives/ArraySlice.lean | 32 +++++++++++++-------------- compiler/ExtractBuiltin.ml | 13 ++++++----- 4 files changed, 55 insertions(+), 54 deletions(-) diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 846a5e4b..83f860b6 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -692,14 +692,14 @@ Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; |}. (* Trait implementation: [core::slice::index::[T]] *) diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 19c4e7a3..94322ead 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -568,14 +568,14 @@ let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; } // Trait implementation: [core::slice::index::[T]] diff --git a/backends/lean/Base/Primitives/ArraySlice.lean b/backends/lean/Base/Primitives/ArraySlice.lean index 8bb9a855..f68c0846 100644 --- a/backends/lean/Base/Primitives/ArraySlice.lean +++ b/backends/lean/Base/Primitives/ArraySlice.lean @@ -363,23 +363,23 @@ def core.slice.index.Slice.index | some x => ret x /- [core::slice::index::Range:::get]: forward function -/ -def core.slice.index.Range.get (T : Type) (i : Range Usize) (slice : Slice T) : +def core.slice.index.RangeUsize.get (T : Type) (i : Range Usize) (slice : Slice T) : Result (Option (Slice T)) := sorry -- TODO /- [core::slice::index::Range::get_mut]: forward function -/ -def core.slice.index.Range.get_mut +def core.slice.index.RangeUsize.get_mut (T : Type) : Range Usize → Slice T → Result (Option (Slice T)) := sorry -- TODO /- [core::slice::index::Range::get_mut]: backward function 0 -/ -def core.slice.index.Range.get_mut_back +def core.slice.index.RangeUsize.get_mut_back (T : Type) : Range Usize → Slice T → Option (Slice T) → Result (Slice T) := sorry -- TODO /- [core::slice::index::Range::get_unchecked]: forward function -/ -def core.slice.index.Range.get_unchecked +def core.slice.index.RangeUsize.get_unchecked (T : Type) : Range Usize → ConstRawPtr (Slice T) → Result (ConstRawPtr (Slice T)) := -- Don't know what the model should be - for now we always fail to make @@ -387,7 +387,7 @@ def core.slice.index.Range.get_unchecked fun _ _ => fail panic /- [core::slice::index::Range::get_unchecked_mut]: forward function -/ -def core.slice.index.Range.get_unchecked_mut +def core.slice.index.RangeUsize.get_unchecked_mut (T : Type) : Range Usize → MutRawPtr (Slice T) → Result (MutRawPtr (Slice T)) := -- Don't know what the model should be - for now we always fail to make @@ -395,17 +395,17 @@ def core.slice.index.Range.get_unchecked_mut fun _ _ => fail panic /- [core::slice::index::Range::index]: forward function -/ -def core.slice.index.Range.index +def core.slice.index.RangeUsize.index (T : Type) : Range Usize → Slice T → Result (Slice T) := sorry -- TODO /- [core::slice::index::Range::index_mut]: forward function -/ -def core.slice.index.Range.index_mut +def core.slice.index.RangeUsize.index_mut (T : Type) : Range Usize → Slice T → Result (Slice T) := sorry -- TODO /- [core::slice::index::Range::index_mut]: backward function 0 -/ -def core.slice.index.Range.index_mut_back +def core.slice.index.RangeUsize.index_mut_back (T : Type) : Range Usize → Slice T → Slice T → Result (Slice T) := sorry -- TODO @@ -448,14 +448,14 @@ def core.slice.index.SliceIndexRangeUsizeSliceTInst (T : Type) : core.slice.index.SliceIndex (Range Usize) (Slice T) := { sealedInst := core.slice.index.private_slice_index.SealedRangeUsizeInst Output := Slice T - get := core.slice.index.Range.get T - get_mut := core.slice.index.Range.get_mut T - get_mut_back := core.slice.index.Range.get_mut_back T - get_unchecked := core.slice.index.Range.get_unchecked T - get_unchecked_mut := core.slice.index.Range.get_unchecked_mut T - index := core.slice.index.Range.index T - index_mut := core.slice.index.Range.index_mut T - index_mut_back := core.slice.index.Range.index_mut_back T + get := core.slice.index.RangeUsize.get T + get_mut := core.slice.index.RangeUsize.get_mut T + get_mut_back := core.slice.index.RangeUsize.get_mut_back T + get_unchecked := core.slice.index.RangeUsize.get_unchecked T + get_unchecked_mut := core.slice.index.RangeUsize.get_unchecked_mut T + index := core.slice.index.RangeUsize.index T + index_mut := core.slice.index.RangeUsize.index_mut T + index_mut_back := core.slice.index.RangeUsize.index_mut_back T } /- Trait implementation: [core::slice::index::[T]] -/ diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index f4f34155..b0a5159f 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -278,18 +278,19 @@ let builtin_funs () : (pattern * bool list option * builtin_fun_info list) list mk_fun "core::array::{[@T; @C]}::index" None None true false; mk_fun "core::array::{[@T; @C]}::index_mut" None None true false; mk_fun "core::slice::index::{core::ops::range::Range}::get" - (Some "core::slice::index::Range::get") None true false; + (Some "core::slice::index::RangeUsize::get") None true false; mk_fun "core::slice::index::{core::ops::range::Range}::get_mut" - (Some "core::slice::index::Range::get_mut") None true false; + (Some "core::slice::index::RangeUsize::get_mut") None true false; mk_fun "core::slice::index::{core::ops::range::Range}::index" - (Some "core::slice::index::Range::index") None true false; + (Some "core::slice::index::RangeUsize::index") None true false; mk_fun "core::slice::index::{core::ops::range::Range}::index_mut" - (Some "core::slice::index::Range::index_mut") None true false; + (Some "core::slice::index::RangeUsize::index_mut") None true false; mk_fun "core::slice::index::{core::ops::range::Range}::get_unchecked" - (Some "core::slice::index::Range::get_unchecked") None false false; + (Some "core::slice::index::RangeUsize::get_unchecked") None false false; mk_fun "core::slice::index::{core::ops::range::Range}::get_unchecked_mut" - (Some "core::slice::index::Range::get_unchecked_mut") None false false; + (Some "core::slice::index::RangeUsize::get_unchecked_mut") None false + false; mk_fun "core::slice::index::{usize}::get" None None true false; mk_fun "core::slice::index::{usize}::get_mut" None None true false; mk_fun "core::slice::index::{usize}::get_unchecked" None None false false; -- cgit v1.2.3 From 00882b8fe6d8ef1d9b7a03cd5949f909d58a2da9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 11:30:43 +0100 Subject: Make a minor modification --- compiler/SymbolicToPure.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 69ff4df1..6983a0e8 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -269,7 +269,11 @@ let ty_to_string (ctx : bs_ctx) (ty : T.ty) : string = let env = bs_ctx_to_fmt_env ctx in Print.Types.ty_to_string env ty -let type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = +let type_decl_to_string (ctx : bs_ctx) (def : T.type_decl) : string = + let env = bs_ctx_to_fmt_env ctx in + Print.Types.type_decl_to_string env def + +let pure_type_decl_to_string (ctx : bs_ctx) (def : type_decl) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.type_decl_to_string env def @@ -476,6 +480,12 @@ let translate_type_decl_kind (kind : T.type_decl_kind) : type_decl_kind = *) let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : type_decl = + log#ldebug + (lazy + (let ctx = Print.Contexts.decls_ctx_to_fmt_env ctx in + "translate_type_decl:\n\n" + ^ Print.Types.type_decl_to_string ctx def + ^ "\n")); let env = Print.Contexts.decls_ctx_to_fmt_env ctx in let def_id = def.T.def_id in let llbc_name = def.name in -- cgit v1.2.3 From 5e92ae6b361f9221f5c5f9a39ab4c28a36597a77 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 11:40:59 +0100 Subject: Regenerate most of the test files --- tests/coq/array/Array.v | 32 +++-- tests/coq/array/Primitives.v | 88 +++++++------- tests/coq/betree/Primitives.v | 88 +++++++------- tests/coq/hashmap/Hashmap_Funs.v | 106 +++++++++-------- tests/coq/hashmap/Primitives.v | 88 +++++++------- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 116 +++++++++--------- tests/coq/hashmap_on_disk/Primitives.v | 88 +++++++------- tests/coq/misc/Constants.v | 2 +- tests/coq/misc/External_Opaque.v | 4 +- tests/coq/misc/Loops.v | 15 +-- tests/coq/misc/NoNestedBorrows.v | 5 +- tests/coq/misc/Primitives.v | 88 +++++++------- tests/coq/traits/Primitives.v | 88 +++++++------- tests/fstar/array/Array.Funs.fst | 32 +++-- tests/fstar/array/Primitives.fst | 88 +++++++------- tests/fstar/betree/Primitives.fst | 88 +++++++------- tests/fstar/betree_back_stateful/Primitives.fst | 88 +++++++------- tests/fstar/hashmap/Hashmap.Clauses.Template.fst | 18 +-- tests/fstar/hashmap/Hashmap.Funs.fst | 130 ++++++++++----------- tests/fstar/hashmap/Primitives.fst | 88 +++++++------- .../HashmapMain.Clauses.Template.fst | 18 +-- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 116 +++++++++--------- tests/fstar/hashmap_on_disk/Primitives.fst | 88 +++++++------- tests/fstar/misc/Constants.fst | 2 +- tests/fstar/misc/External.Opaque.fsti | 4 +- tests/fstar/misc/Loops.Funs.fst | 14 +-- tests/fstar/misc/NoNestedBorrows.fst | 5 +- tests/fstar/misc/Primitives.fst | 88 +++++++------- tests/fstar/traits/Primitives.fst | 88 +++++++------- tests/lean/Array.lean | 32 +++-- tests/lean/Constants.lean | 2 +- tests/lean/External/FunsExternal_Template.lean | 4 +- tests/lean/Hashmap/Funs.lean | 130 ++++++++++----------- tests/lean/HashmapMain/Funs.lean | 115 +++++++++--------- tests/lean/Loops.lean | 15 +-- 35 files changed, 1045 insertions(+), 1016 deletions(-) diff --git a/tests/coq/array/Array.v b/tests/coq/array/Array.v index 825f73e0..256ccd1c 100644 --- a/tests/coq/array/Array.v +++ b/tests/coq/array/Array.v @@ -101,7 +101,7 @@ Definition index_mut_slice_back Definition slice_subslice_shared_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) := core_slice_index_Slice_index u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . @@ -109,7 +109,7 @@ Definition slice_subslice_shared_ Definition slice_subslice_mut_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) := core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . @@ -119,7 +119,7 @@ Definition slice_subslice_mut__back result (slice u32) := core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret . @@ -144,8 +144,8 @@ Definition array_to_slice_mut__back Definition array_subslice_shared_ (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . @@ -153,8 +153,8 @@ Definition array_subslice_shared_ Definition array_subslice_mut_ (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index_mut u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . @@ -164,8 +164,8 @@ Definition array_subslice_mut__back result (array u32 32%usize) := core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret . @@ -309,9 +309,8 @@ Definition update_all : result unit := Definition range_all : result unit := s <- core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) {| core_ops_range_Range_start := 1%usize; @@ -320,9 +319,8 @@ Definition range_all : result unit := s0 <- update_mut_slice s; _ <- core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4%usize - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) (mk_array u32 4%usize [ 0%u32; 0%u32; 0%u32; 0%u32 ]) {| core_ops_range_Range_start := 1%usize; @@ -430,8 +428,8 @@ Definition f2 (i : u32) : result unit := Definition f4 (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index u32 (core_ops_range_Range usize) 32%usize - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . diff --git a/tests/coq/array/Primitives.v b/tests/coq/array/Primitives.v index 85e38f01..83f860b6 100644 --- a/tests/coq/array/Primitives.v +++ b/tests/coq/array/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -683,44 +683,44 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/betree/Primitives.v b/tests/coq/betree/Primitives.v index 85e38f01..83f860b6 100644 --- a/tests/coq/betree/Primitives.v +++ b/tests/coq/betree/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -683,44 +683,44 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index 3ca52a9f..fbed86b5 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -14,7 +14,7 @@ Module Hashmap_Funs. Definition hash_key (k : usize) : result usize := Return k. -(** [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function *) Fixpoint hashMap_allocate_slots_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : result (alloc_vec_Vec (List_t T)) @@ -31,7 +31,7 @@ Fixpoint hashMap_allocate_slots_loop end . -(** [hashmap::HashMap::{0}::allocate_slots]: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: forward function *) Definition hashMap_allocate_slots (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : result (alloc_vec_Vec (List_t T)) @@ -39,7 +39,7 @@ Definition hashMap_allocate_slots hashMap_allocate_slots_loop T n slots n0 . -(** [hashmap::HashMap::{0}::new_with_capacity]: forward function *) +(** [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function *) Definition hashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -58,12 +58,12 @@ Definition hashMap_new_with_capacity |} . -(** [hashmap::HashMap::{0}::new]: forward function *) +(** [hashmap::{hashmap::HashMap}::new]: forward function *) Definition hashMap_new (T : Type) (n : nat) : result (HashMap_t T) := hashMap_new_with_capacity T n 32%usize 4%usize 5%usize . -(** [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashMap_clear_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (i : usize) : @@ -78,14 +78,14 @@ Fixpoint hashMap_clear_loop i1 <- usize_add i 1%usize; slots0 <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) - slots i List_Nil; + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i + List_Nil; hashMap_clear_loop T n0 slots0 i1) else Return slots end . -(** [hashmap::HashMap::{0}::clear]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashMap_clear (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := @@ -99,12 +99,12 @@ Definition hashMap_clear |} . -(** [hashmap::HashMap::{0}::len]: forward function *) +(** [hashmap::{hashmap::HashMap}::len]: forward function *) Definition hashMap_len (T : Type) (self : HashMap_t T) : result usize := Return self.(hashMap_num_entries) . -(** [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function *) Fixpoint hashMap_insert_in_list_loop (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool @@ -122,7 +122,7 @@ Fixpoint hashMap_insert_in_list_loop end . -(** [hashmap::HashMap::{0}::insert_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: forward function *) Definition hashMap_insert_in_list (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool @@ -130,7 +130,7 @@ Definition hashMap_insert_in_list hashMap_insert_in_list_loop T n key value ls . -(** [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) Fixpoint hashMap_insert_in_list_loop_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) @@ -150,7 +150,7 @@ Fixpoint hashMap_insert_in_list_loop_back end . -(** [hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 *) Definition hashMap_insert_in_list_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) @@ -158,7 +158,7 @@ Definition hashMap_insert_in_list_back hashMap_insert_in_list_loop_back T n key value ls . -(** [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashMap_insert_no_resize (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : @@ -169,7 +169,7 @@ Definition hashMap_insert_no_resize hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; inserted <- hashMap_insert_in_list T n key value l; if inserted @@ -178,7 +178,7 @@ Definition hashMap_insert_no_resize l0 <- hashMap_insert_in_list_back T n key value l; v <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod l0; Return {| @@ -191,7 +191,7 @@ Definition hashMap_insert_no_resize l0 <- hashMap_insert_in_list_back T n key value l; v <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod l0; Return {| @@ -202,7 +202,7 @@ Definition hashMap_insert_no_resize |}) . -(** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashMap_move_elements_from_list_loop (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : @@ -220,7 +220,7 @@ Fixpoint hashMap_move_elements_from_list_loop end . -(** [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashMap_move_elements_from_list (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : @@ -229,7 +229,7 @@ Definition hashMap_move_elements_from_list hashMap_move_elements_from_list_loop T n ntable ls . -(** [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashMap_move_elements_loop (T : Type) (n : nat) (ntable : HashMap_t T) @@ -244,22 +244,20 @@ Fixpoint hashMap_move_elements_loop then ( l <- alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) - slots i; + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i; let ls := core_mem_replace (List_t T) l List_Nil in ntable0 <- hashMap_move_elements_from_list T n0 ntable ls; i1 <- usize_add i 1%usize; let l0 := core_mem_replace_back (List_t T) l List_Nil in slots0 <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) - slots i l0; + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i l0; hashMap_move_elements_loop T n0 ntable0 slots0 i1) else Return (ntable, slots) end . -(** [hashmap::HashMap::{0}::move_elements]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashMap_move_elements (T : Type) (n : nat) (ntable : HashMap_t T) @@ -269,7 +267,7 @@ Definition hashMap_move_elements hashMap_move_elements_loop T n ntable slots i . -(** [hashmap::HashMap::{0}::try_resize]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashMap_try_resize (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := @@ -301,7 +299,7 @@ Definition hashMap_try_resize |} . -(** [hashmap::HashMap::{0}::insert]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashMap_insert (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : @@ -314,7 +312,7 @@ Definition hashMap_insert else Return self0 . -(** [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) Fixpoint hashMap_contains_key_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := match n with @@ -330,13 +328,13 @@ Fixpoint hashMap_contains_key_in_list_loop end . -(** [hashmap::HashMap::{0}::contains_key_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function *) Definition hashMap_contains_key_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := hashMap_contains_key_in_list_loop T n key ls . -(** [hashmap::HashMap::{0}::contains_key]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key]: forward function *) Definition hashMap_contains_key (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result bool := hash <- hash_key key; @@ -344,12 +342,12 @@ Definition hashMap_contains_key hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; hashMap_contains_key_in_list T n key l . -(** [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function *) Fixpoint hashMap_get_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := match n with @@ -365,13 +363,13 @@ Fixpoint hashMap_get_in_list_loop end . -(** [hashmap::HashMap::{0}::get_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: forward function *) Definition hashMap_get_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := hashMap_get_in_list_loop T n key ls . -(** [hashmap::HashMap::{0}::get]: forward function *) +(** [hashmap::{hashmap::HashMap}::get]: forward function *) Definition hashMap_get (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := hash <- hash_key key; @@ -379,12 +377,12 @@ Definition hashMap_get hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; hashMap_get_in_list T n key l . -(** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) Fixpoint hashMap_get_mut_in_list_loop (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := match n with @@ -400,13 +398,13 @@ Fixpoint hashMap_get_mut_in_list_loop end . -(** [hashmap::HashMap::{0}::get_mut_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function *) Definition hashMap_get_mut_in_list (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := hashMap_get_mut_in_list_loop T n ls key . -(** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) Fixpoint hashMap_get_mut_in_list_loop_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) @@ -426,7 +424,7 @@ Fixpoint hashMap_get_mut_in_list_loop_back end . -(** [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 *) Definition hashMap_get_mut_in_list_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) @@ -434,7 +432,7 @@ Definition hashMap_get_mut_in_list_back hashMap_get_mut_in_list_loop_back T n ls key ret . -(** [hashmap::HashMap::{0}::get_mut]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut]: forward function *) Definition hashMap_get_mut (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := hash <- hash_key key; @@ -442,12 +440,12 @@ Definition hashMap_get_mut hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; hashMap_get_mut_in_list T n l key . -(** [hashmap::HashMap::{0}::get_mut]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 *) Definition hashMap_get_mut_back (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (ret : T) : result (HashMap_t T) @@ -457,12 +455,12 @@ Definition hashMap_get_mut_back hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; l0 <- hashMap_get_mut_in_list_back T n l key ret; v <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod l0; Return {| @@ -473,7 +471,7 @@ Definition hashMap_get_mut_back |} . -(** [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function *) Fixpoint hashMap_remove_from_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := match n with @@ -495,13 +493,13 @@ Fixpoint hashMap_remove_from_list_loop end . -(** [hashmap::HashMap::{0}::remove_from_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: forward function *) Definition hashMap_remove_from_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := hashMap_remove_from_list_loop T n key ls . -(** [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) Fixpoint hashMap_remove_from_list_loop_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := match n with @@ -525,13 +523,13 @@ Fixpoint hashMap_remove_from_list_loop_back end . -(** [hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 *) Definition hashMap_remove_from_list_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := hashMap_remove_from_list_loop_back T n key ls . -(** [hashmap::HashMap::{0}::remove]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove]: forward function *) Definition hashMap_remove (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result (option T) @@ -541,7 +539,7 @@ Definition hashMap_remove hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; x <- hashMap_remove_from_list T n key l; match x with @@ -551,7 +549,7 @@ Definition hashMap_remove end . -(** [hashmap::HashMap::{0}::remove]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::remove]: backward function 0 *) Definition hashMap_remove_back (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result (HashMap_t T) @@ -561,7 +559,7 @@ Definition hashMap_remove_back hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod; x <- hashMap_remove_from_list T n key l; match x with @@ -569,7 +567,7 @@ Definition hashMap_remove_back l0 <- hashMap_remove_from_list_back T n key l; v <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod l0; Return {| @@ -583,7 +581,7 @@ Definition hashMap_remove_back l0 <- hashMap_remove_from_list_back T n key l; v <- alloc_vec_Vec_index_mut_back (List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) self.(hashMap_slots) hash_mod l0; Return {| diff --git a/tests/coq/hashmap/Primitives.v b/tests/coq/hashmap/Primitives.v index 85e38f01..83f860b6 100644 --- a/tests/coq/hashmap/Primitives.v +++ b/tests/coq/hashmap/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -683,44 +683,44 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index eac78186..6f3848e6 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -16,7 +16,7 @@ Module HashmapMain_Funs. Definition hashmap_hash_key (k : usize) : result usize := Return k. -(** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function *) Fixpoint hashmap_HashMap_allocate_slots_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) : @@ -34,7 +34,7 @@ Fixpoint hashmap_HashMap_allocate_slots_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function *) Definition hashmap_HashMap_allocate_slots (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) : @@ -43,7 +43,7 @@ Definition hashmap_HashMap_allocate_slots hashmap_HashMap_allocate_slots_loop T n slots n0 . -(** [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function *) Definition hashmap_HashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -62,13 +62,13 @@ Definition hashmap_HashMap_new_with_capacity |} . -(** [hashmap_main::hashmap::HashMap::{0}::new]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function *) Definition hashmap_HashMap_new (T : Type) (n : nat) : result (hashmap_HashMap_t T) := hashmap_HashMap_new_with_capacity T n 32%usize 4%usize 5%usize . -(** [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashmap_HashMap_clear_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : @@ -83,14 +83,14 @@ Fixpoint hashmap_HashMap_clear_loop i1 <- usize_add i 1%usize; slots0 <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) slots i Hashmap_List_Nil; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots + i Hashmap_List_Nil; hashmap_HashMap_clear_loop T n0 slots0 i1) else Return slots end . -(** [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashmap_HashMap_clear (T : Type) (n : nat) (self : hashmap_HashMap_t T) : @@ -106,13 +106,13 @@ Definition hashmap_HashMap_clear |} . -(** [hashmap_main::hashmap::HashMap::{0}::len]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function *) Definition hashmap_HashMap_len (T : Type) (self : hashmap_HashMap_t T) : result usize := Return self.(hashmap_HashMap_num_entries) . -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function *) Fixpoint hashmap_HashMap_insert_in_list_loop (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool @@ -130,7 +130,7 @@ Fixpoint hashmap_HashMap_insert_in_list_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function *) Definition hashmap_HashMap_insert_in_list (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool @@ -138,7 +138,7 @@ Definition hashmap_HashMap_insert_in_list hashmap_HashMap_insert_in_list_loop T n key value ls . -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) Fixpoint hashmap_HashMap_insert_in_list_loop_back (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -159,7 +159,7 @@ Fixpoint hashmap_HashMap_insert_in_list_loop_back end . -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 *) Definition hashmap_HashMap_insert_in_list_back (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -167,7 +167,7 @@ Definition hashmap_HashMap_insert_in_list_back hashmap_HashMap_insert_in_list_loop_back T n key value ls . -(** [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashmap_HashMap_insert_no_resize (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : @@ -178,7 +178,7 @@ Definition hashmap_HashMap_insert_no_resize hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; inserted <- hashmap_HashMap_insert_in_list T n key value l; if inserted @@ -187,8 +187,8 @@ Definition hashmap_HashMap_insert_no_resize l0 <- hashmap_HashMap_insert_in_list_back T n key value l; v <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) self.(hashmap_HashMap_slots) hash_mod l0; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod l0; Return {| hashmap_HashMap_num_entries := i0; @@ -201,8 +201,8 @@ Definition hashmap_HashMap_insert_no_resize l0 <- hashmap_HashMap_insert_in_list_back T n key value l; v <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) self.(hashmap_HashMap_slots) hash_mod l0; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod l0; Return {| hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); @@ -213,7 +213,7 @@ Definition hashmap_HashMap_insert_no_resize |}) . -(** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashmap_HashMap_move_elements_from_list_loop (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : @@ -231,7 +231,7 @@ Fixpoint hashmap_HashMap_move_elements_from_list_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashmap_HashMap_move_elements_from_list (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : @@ -240,7 +240,7 @@ Definition hashmap_HashMap_move_elements_from_list hashmap_HashMap_move_elements_from_list_loop T n ntable ls . -(** [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint hashmap_HashMap_move_elements_loop (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) @@ -255,22 +255,22 @@ Fixpoint hashmap_HashMap_move_elements_loop then ( l <- alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) slots i; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots + i; let ls := core_mem_replace (hashmap_List_t T) l Hashmap_List_Nil in ntable0 <- hashmap_HashMap_move_elements_from_list T n0 ntable ls; i1 <- usize_add i 1%usize; let l0 := core_mem_replace_back (hashmap_List_t T) l Hashmap_List_Nil in slots0 <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) slots i l0; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots + i l0; hashmap_HashMap_move_elements_loop T n0 ntable0 slots0 i1) else Return (ntable, slots) end . -(** [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashmap_HashMap_move_elements (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) @@ -280,7 +280,7 @@ Definition hashmap_HashMap_move_elements hashmap_HashMap_move_elements_loop T n ntable slots i . -(** [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashmap_HashMap_try_resize (T : Type) (n : nat) (self : hashmap_HashMap_t T) : @@ -317,7 +317,7 @@ Definition hashmap_HashMap_try_resize |} . -(** [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition hashmap_HashMap_insert (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : @@ -330,7 +330,7 @@ Definition hashmap_HashMap_insert else Return self0 . -(** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) Fixpoint hashmap_HashMap_contains_key_in_list_loop (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := match n with @@ -346,13 +346,13 @@ Fixpoint hashmap_HashMap_contains_key_in_list_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function *) Definition hashmap_HashMap_contains_key_in_list (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := hashmap_HashMap_contains_key_in_list_loop T n key ls . -(** [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function *) Definition hashmap_HashMap_contains_key (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result bool @@ -362,12 +362,12 @@ Definition hashmap_HashMap_contains_key hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; hashmap_HashMap_contains_key_in_list T n key l . -(** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function *) Fixpoint hashmap_HashMap_get_in_list_loop (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := match n with @@ -383,13 +383,13 @@ Fixpoint hashmap_HashMap_get_in_list_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function *) Definition hashmap_HashMap_get_in_list (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := hashmap_HashMap_get_in_list_loop T n key ls . -(** [hashmap_main::hashmap::HashMap::{0}::get]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function *) Definition hashmap_HashMap_get (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := hash <- hashmap_hash_key key; @@ -397,12 +397,12 @@ Definition hashmap_HashMap_get hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; hashmap_HashMap_get_in_list T n key l . -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) Fixpoint hashmap_HashMap_get_mut_in_list_loop (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := match n with @@ -418,13 +418,13 @@ Fixpoint hashmap_HashMap_get_mut_in_list_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function *) Definition hashmap_HashMap_get_mut_in_list (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := hashmap_HashMap_get_mut_in_list_loop T n ls key . -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) Fixpoint hashmap_HashMap_get_mut_in_list_loop_back (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : result (hashmap_List_t T) @@ -444,7 +444,7 @@ Fixpoint hashmap_HashMap_get_mut_in_list_loop_back end . -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 *) Definition hashmap_HashMap_get_mut_in_list_back (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : result (hashmap_List_t T) @@ -452,7 +452,7 @@ Definition hashmap_HashMap_get_mut_in_list_back hashmap_HashMap_get_mut_in_list_loop_back T n ls key ret . -(** [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function *) Definition hashmap_HashMap_get_mut (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := hash <- hashmap_hash_key key; @@ -460,12 +460,12 @@ Definition hashmap_HashMap_get_mut hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; hashmap_HashMap_get_mut_in_list T n l key . -(** [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 *) Definition hashmap_HashMap_get_mut_back (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (ret : T) : result (hashmap_HashMap_t T) @@ -475,12 +475,12 @@ Definition hashmap_HashMap_get_mut_back hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; l0 <- hashmap_HashMap_get_mut_in_list_back T n l key ret; v <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod l0; Return {| @@ -491,7 +491,7 @@ Definition hashmap_HashMap_get_mut_back |} . -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function *) Fixpoint hashmap_HashMap_remove_from_list_loop (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) @@ -516,7 +516,7 @@ Fixpoint hashmap_HashMap_remove_from_list_loop end . -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function *) Definition hashmap_HashMap_remove_from_list (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) @@ -524,7 +524,7 @@ Definition hashmap_HashMap_remove_from_list hashmap_HashMap_remove_from_list_loop T n key ls . -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) Fixpoint hashmap_HashMap_remove_from_list_loop_back (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -551,7 +551,7 @@ Fixpoint hashmap_HashMap_remove_from_list_loop_back end . -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 *) Definition hashmap_HashMap_remove_from_list_back (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -559,7 +559,7 @@ Definition hashmap_HashMap_remove_from_list_back hashmap_HashMap_remove_from_list_loop_back T n key ls . -(** [hashmap_main::hashmap::HashMap::{0}::remove]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function *) Definition hashmap_HashMap_remove (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result (option T) @@ -569,7 +569,7 @@ Definition hashmap_HashMap_remove hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; x <- hashmap_HashMap_remove_from_list T n key l; match x with @@ -579,7 +579,7 @@ Definition hashmap_HashMap_remove end . -(** [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 *) Definition hashmap_HashMap_remove_back (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result (hashmap_HashMap_t T) @@ -589,7 +589,7 @@ Definition hashmap_HashMap_remove_back hash_mod <- usize_rem hash i; l <- alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t T)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) self.(hashmap_HashMap_slots) hash_mod; x <- hashmap_HashMap_remove_from_list T n key l; match x with @@ -597,8 +597,8 @@ Definition hashmap_HashMap_remove_back l0 <- hashmap_HashMap_remove_from_list_back T n key l; v <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) self.(hashmap_HashMap_slots) hash_mod l0; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod l0; Return {| hashmap_HashMap_num_entries := self.(hashmap_HashMap_num_entries); @@ -612,8 +612,8 @@ Definition hashmap_HashMap_remove_back l0 <- hashmap_HashMap_remove_from_list_back T n key l; v <- alloc_vec_Vec_index_mut_back (hashmap_List_t T) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - T)) self.(hashmap_HashMap_slots) hash_mod l0; + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) + self.(hashmap_HashMap_slots) hash_mod l0; Return {| hashmap_HashMap_num_entries := i0; diff --git a/tests/coq/hashmap_on_disk/Primitives.v b/tests/coq/hashmap_on_disk/Primitives.v index 85e38f01..83f860b6 100644 --- a/tests/coq/hashmap_on_disk/Primitives.v +++ b/tests/coq/hashmap_on_disk/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -683,44 +683,44 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index 03653f69..1f2ab812 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -68,7 +68,7 @@ Record Wrap_t (T : Type) := mkWrap_t { wrap_value : T; }. Arguments mkWrap_t { _ }. Arguments wrap_value { _ }. -(** [constants::Wrap::{0}::new]: forward function *) +(** [constants::{constants::Wrap}::new]: forward function *) Definition wrap_new (T : Type) (value : T) : result (Wrap_t T) := Return {| wrap_value := value |} . diff --git a/tests/coq/misc/External_Opaque.v b/tests/coq/misc/External_Opaque.v index 80be37e7..10c05583 100644 --- a/tests/coq/misc/External_Opaque.v +++ b/tests/coq/misc/External_Opaque.v @@ -25,12 +25,12 @@ Axiom core_mem_swap_back1 : forall(T : Type), T -> T -> state -> state -> result (state * T) . -(** [core::num::nonzero::NonZeroU32::{14}::new]: forward function *) +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function *) Axiom core_num_nonzero_NonZeroU32_new : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) . -(** [core::option::Option::{0}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function *) Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index 1c0eab17..e5ff6c8e 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -77,7 +77,7 @@ Fixpoint clear_loop i1 <- usize_add i 1%usize; v0 <- alloc_vec_Vec_index_mut_back u32 usize - (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0%u32; + (core_slice_index_SliceIndexUsizeSliceTInst u32) v i 0%u32; clear_loop n0 v0 i1) else Return v end @@ -209,8 +209,7 @@ Definition get_elem_mut := l <- alloc_vec_Vec_index_mut (List_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) - slots 0%usize; + (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; get_elem_mut_loop n x l . @@ -240,12 +239,11 @@ Definition get_elem_mut_back := l <- alloc_vec_Vec_index_mut (List_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) - slots 0%usize; + (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; l0 <- get_elem_mut_loop_back n x l ret; alloc_vec_Vec_index_mut_back (List_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) slots - 0%usize l0 + (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize + l0 . (** [loops::get_elem_shared]: loop 0: forward function *) @@ -269,8 +267,7 @@ Definition get_elem_shared := l <- alloc_vec_Vec_index (List_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (List_t usize)) - slots 0%usize; + (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; get_elem_shared_loop n x l . diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index c7af496f..376e722c 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -151,8 +151,9 @@ Check (test_list1 )%return. (** [no_nested_borrows::test_box1]: forward function *) Definition test_box1 : result unit := - let b := 1%i32 in - let x := b in + let b := 0%i32 in + b0 <- alloc_boxed_Box_deref_mut_back i32 b 1%i32; + x <- alloc_boxed_Box_deref i32 b0; if negb (x s= 1%i32) then Fail_ Failure else Return tt . diff --git a/tests/coq/misc/Primitives.v b/tests/coq/misc/Primitives.v index 85e38f01..83f860b6 100644 --- a/tests/coq/misc/Primitives.v +++ b/tests/coq/misc/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -683,44 +683,44 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/coq/traits/Primitives.v b/tests/coq/traits/Primitives.v index 85e38f01..83f860b6 100644 --- a/tests/coq/traits/Primitives.v +++ b/tests/coq/traits/Primitives.v @@ -467,14 +467,14 @@ Definition alloc_boxed_Box_deref_mut (T : Type) (x : T) : result T := Return x. Definition alloc_boxed_Box_deref_mut_back (T : Type) (_ : T) (x : T) : result T := Return x. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| +Definition alloc_boxed_Box_coreopsDerefInst (Self : Type) : core_ops_deref_Deref Self := {| core_ops_deref_Deref_target := Self; core_ops_deref_Deref_deref := alloc_boxed_Box_deref Self; |}. (* Trait instance *) -Definition alloc_boxed_Box_coreOpsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| - core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreOpsDerefInst Self; +Definition alloc_boxed_Box_coreopsDerefMutInst (Self : Type) : core_ops_deref_DerefMut Self := {| + core_ops_deref_DerefMut_derefInst := alloc_boxed_Box_coreopsDerefInst Self; core_ops_deref_DerefMut_deref_mut := alloc_boxed_Box_deref_mut Self; core_ops_deref_DerefMut_deref_mut_back := alloc_boxed_Box_deref_mut_back Self; |}. @@ -576,7 +576,7 @@ Definition alloc_vec_Vec_insert (T: Type) (v: alloc_vec_Vec T) (i: usize) (x: T) else Fail_ Failure). (* Helper *) -Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result T. +Axiom alloc_vec_Vec_index_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize), result T. (* Helper *) Axiom alloc_vec_Vec_update_usize : forall {T : Type} (v : alloc_vec_Vec T) (i : usize) (x : T), result (alloc_vec_Vec T). @@ -620,18 +620,18 @@ Definition core_slice_index_Slice_index end. (* [core::slice::index::Range:::get]: forward function *) -Axiom core_slice_index_Range_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). +Axiom core_slice_index_RangeUsize_get : forall (T : Type) (i : core_ops_range_Range usize) (s : slice T), result (option (slice T)). (* [core::slice::index::Range::get_mut]: forward function *) -Axiom core_slice_index_Range_get_mut : +Axiom core_slice_index_RangeUsize_get_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (option (slice T)). (* [core::slice::index::Range::get_mut]: backward function 0 *) -Axiom core_slice_index_Range_get_mut_back : +Axiom core_slice_index_RangeUsize_get_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> option (slice T) -> result (slice T). (* [core::slice::index::Range::get_unchecked]: forward function *) -Definition core_slice_index_Range_get_unchecked +Definition core_slice_index_RangeUsize_get_unchecked (T : Type) : core_ops_range_Range usize -> const_raw_ptr (slice T) -> result (const_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -639,7 +639,7 @@ Definition core_slice_index_Range_get_unchecked fun _ _ => Fail_ Failure. (* [core::slice::index::Range::get_unchecked_mut]: forward function *) -Definition core_slice_index_Range_get_unchecked_mut +Definition core_slice_index_RangeUsize_get_unchecked_mut (T : Type) : core_ops_range_Range usize -> mut_raw_ptr (slice T) -> result (mut_raw_ptr (slice T)) := (* Don't know what the model should be - for now we always fail to make @@ -647,15 +647,15 @@ Definition core_slice_index_Range_get_unchecked_mut fun _ _ => Fail_ Failure. (* [core::slice::index::Range::index]: forward function *) -Axiom core_slice_index_Range_index : +Axiom core_slice_index_RangeUsize_index : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: forward function *) -Axiom core_slice_index_Range_index_mut : +Axiom core_slice_index_RangeUsize_index_mut : forall (T : Type), core_ops_range_Range usize -> slice T -> result (slice T). (* [core::slice::index::Range::index_mut]: backward function 0 *) -Axiom core_slice_index_Range_index_mut_back : +Axiom core_slice_index_RangeUsize_index_mut_back : forall (T : Type), core_ops_range_Range usize -> slice T -> slice T -> result (slice T). (* [core::slice::index::[T]::index_mut]: forward function *) @@ -683,44 +683,44 @@ Axiom core_array_Array_index_mut_back : forall (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) (a : array T N) (i : Idx) (x : inst.(core_ops_index_IndexMut_indexInst).(core_ops_index_Index_Output)), result (array T N). -(* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexInst (T Idx : Type) - (inst : core_slice_index_SliceIndex Idx (slice T)) : - core_ops_index_Index (slice T) Idx := {| - core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); - core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; -|}. - (* Trait implementation: [core::slice::index::private_slice_index::Range] *) -Definition core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) := tt. (* Trait implementation: [core::slice::index::Range] *) -Definition core_slice_index_Range_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexRangeUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedRangeUsizeInst; core_slice_index_SliceIndex_Output := slice T; - core_slice_index_SliceIndex_get := core_slice_index_Range_get T; - core_slice_index_SliceIndex_get_mut := core_slice_index_Range_get_mut T; - core_slice_index_SliceIndex_get_mut_back := core_slice_index_Range_get_mut_back T; - core_slice_index_SliceIndex_get_unchecked := core_slice_index_Range_get_unchecked T; - core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_Range_get_unchecked_mut T; - core_slice_index_SliceIndex_index := core_slice_index_Range_index T; - core_slice_index_SliceIndex_index_mut := core_slice_index_Range_index_mut T; - core_slice_index_SliceIndex_index_mut_back := core_slice_index_Range_index_mut_back T; + core_slice_index_SliceIndex_get := core_slice_index_RangeUsize_get T; + core_slice_index_SliceIndex_get_mut := core_slice_index_RangeUsize_get_mut T; + core_slice_index_SliceIndex_get_mut_back := core_slice_index_RangeUsize_get_mut_back T; + core_slice_index_SliceIndex_get_unchecked := core_slice_index_RangeUsize_get_unchecked T; + core_slice_index_SliceIndex_get_unchecked_mut := core_slice_index_RangeUsize_get_unchecked_mut T; + core_slice_index_SliceIndex_index := core_slice_index_RangeUsize_index T; + core_slice_index_SliceIndex_index_mut := core_slice_index_RangeUsize_index_mut T; + core_slice_index_SliceIndex_index_mut_back := core_slice_index_RangeUsize_index_mut_back T; +|}. + +(* Trait implementation: [core::slice::index::[T]] *) +Definition core_ops_index_IndexSliceTIInst (T Idx : Type) + (inst : core_slice_index_SliceIndex Idx (slice T)) : + core_ops_index_Index (slice T) Idx := {| + core_ops_index_Index_Output := inst.(core_slice_index_SliceIndex_Output); + core_ops_index_Index_index := core_slice_index_Slice_index T Idx inst; |}. (* Trait implementation: [core::slice::index::[T]] *) -Definition core_slice_index_Slice_coreopsindexIndexMutInst (T Idx : Type) +Definition core_ops_index_IndexMutSliceTIInst (T Idx : Type) (inst : core_slice_index_SliceIndex Idx (slice T)) : core_ops_index_IndexMut (slice T) Idx := {| - core_ops_index_IndexMut_indexInst := core_slice_index_Slice_coreopsindexIndexInst T Idx inst; + core_ops_index_IndexMut_indexInst := core_ops_index_IndexSliceTIInst T Idx inst; core_ops_index_IndexMut_index_mut := core_slice_index_Slice_index_mut T Idx inst; core_ops_index_IndexMut_index_mut_back := core_slice_index_Slice_index_mut_back T Idx inst; |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_Index (slice T) Idx) : core_ops_index_Index (array T N) Idx := {| core_ops_index_Index_Output := inst.(core_ops_index_Index_Output); @@ -728,10 +728,10 @@ Definition core_array_Array_coreopsindexIndexInst (T Idx : Type) (N : usize) |}. (* Trait implementation: [core::array::[T; N]] *) -Definition core_array_Array_coreopsindexIndexMutInst (T Idx : Type) (N : usize) +Definition core_ops_index_IndexMutArrayInst (T Idx : Type) (N : usize) (inst : core_ops_index_IndexMut (slice T) Idx) : core_ops_index_IndexMut (array T N) Idx := {| - core_ops_index_IndexMut_indexInst := core_array_Array_coreopsindexIndexInst T Idx N inst.(core_ops_index_IndexMut_indexInst); + core_ops_index_IndexMut_indexInst := core_ops_index_IndexArrayInst T Idx N inst.(core_ops_index_IndexMut_indexInst); core_ops_index_IndexMut_index_mut := core_array_Array_index_mut T Idx N inst; core_ops_index_IndexMut_index_mut_back := core_array_Array_index_mut_back T Idx N inst; |}. @@ -765,13 +765,13 @@ Axiom core_slice_index_usize_index_mut_back : forall (T : Type), usize -> slice T -> T -> result (slice T). (* Trait implementation: [core::slice::index::private_slice_index::usize] *) -Definition core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +Definition core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize := tt. (* Trait implementation: [core::slice::index::usize] *) -Definition core_slice_index_usize_coresliceindexSliceIndexInst (T : Type) : +Definition core_slice_index_SliceIndexUsizeSliceTInst (T : Type) : core_slice_index_SliceIndex usize (slice T) := {| - core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + core_slice_index_SliceIndex_sealedInst := core_slice_index_private_slice_index_SealedUsizeInst; core_slice_index_SliceIndex_Output := T; core_slice_index_SliceIndex_get := core_slice_index_usize_get T; core_slice_index_SliceIndex_get_mut := core_slice_index_usize_get_mut T; @@ -815,8 +815,16 @@ Definition alloc_vec_Vec_coreopsindexIndexMutInst (T Idx : Type) (*** Theorems *) +Axiom alloc_vec_Vec_index_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + +Axiom alloc_vec_Vec_index_mut_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i = + alloc_vec_Vec_index_usize v i. + Axiom alloc_vec_Vec_index_mut_back_eq : forall {a : Type} (v : alloc_vec_Vec a) (i : usize) (x : a), - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x = + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x = alloc_vec_Vec_update_usize v i x. End Primitives. diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index 8f0bfbbd..50fff38d 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -75,14 +75,14 @@ let index_mut_slice_back let slice_subslice_shared_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = core_slice_index_Slice_index u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x { start = y; end_ = z } (** [array::slice_subslice_mut_]: forward function *) let slice_subslice_mut_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x { start = y; end_ = z } (** [array::slice_subslice_mut_]: backward function 0 *) @@ -91,7 +91,7 @@ let slice_subslice_mut__back result (slice u32) = core_slice_index_Slice_index_mut_back u32 (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32) x + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x { start = y; end_ = z } ret (** [array::array_to_slice_shared_]: forward function *) @@ -111,16 +111,16 @@ let array_to_slice_mut__back let array_subslice_shared_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } (** [array::array_subslice_mut_]: forward function *) let array_subslice_mut_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index_mut u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } (** [array::array_subslice_mut_]: backward function 0 *) @@ -129,8 +129,8 @@ let array_subslice_mut__back result (array u32 32) = core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } ret (** [array::index_slice_0]: forward function *) @@ -251,16 +251,14 @@ let update_all : result unit = let range_all : result unit = let* s = core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } in let* s0 = update_mut_slice s in let* _ = core_array_Array_index_mut_back u32 (core_ops_range_Range usize) 4 - (core_slice_index_Slice_coreopsindexIndexMutInst u32 - (core_ops_range_Range usize) - (core_slice_index_Range_coresliceindexSliceIndexInst u32)) + (core_ops_index_IndexMutSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } s0 in Return () @@ -342,8 +340,8 @@ let f2 (i : u32) : result unit = (** [array::f4]: forward function *) let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index u32 (core_ops_range_Range usize) 32 - (core_slice_index_Slice_coreopsindexIndexInst u32 (core_ops_range_Range - usize) (core_slice_index_Range_coresliceindexSliceIndexInst u32)) x + (core_ops_index_IndexSliceTIInst u32 (core_ops_range_Range usize) + (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } (** [array::f3]: forward function *) diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst index a1f81666..d6156720 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst @@ -6,55 +6,55 @@ open Hashmap.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap::HashMap::{0}::allocate_slots]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: decreases clause *) unfold let hashMap_allocate_slots_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : nat = admit () -(** [hashmap::HashMap::{0}::clear]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::clear]: decreases clause *) unfold let hashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () -(** [hashmap::HashMap::{0}::insert_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: decreases clause *) unfold let hashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) (ls : list_t t) : nat = admit () -(** [hashmap::HashMap::{0}::move_elements_from_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: decreases clause *) unfold let hashMap_move_elements_from_list_loop_decreases (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : nat = admit () -(** [hashmap::HashMap::{0}::move_elements]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::move_elements]: decreases clause *) unfold let hashMap_move_elements_loop_decreases (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () -(** [hashmap::HashMap::{0}::contains_key_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: decreases clause *) unfold let hashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () -(** [hashmap::HashMap::{0}::get_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: decreases clause *) unfold let hashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () -(** [hashmap::HashMap::{0}::get_mut_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: decreases clause *) unfold let hashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) (key : usize) : nat = admit () -(** [hashmap::HashMap::{0}::remove_from_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: decreases clause *) unfold let hashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index 0e31e364..77e0b46a 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -11,7 +11,7 @@ include Hashmap.Clauses let hash_key (k : usize) : result usize = Return k -(** [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function *) let rec hashMap_allocate_slots_loop (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : Tot (result (alloc_vec_Vec (list_t t))) @@ -24,14 +24,14 @@ let rec hashMap_allocate_slots_loop hashMap_allocate_slots_loop t slots0 n0 else Return slots -(** [hashmap::HashMap::{0}::allocate_slots]: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: forward function *) let hashMap_allocate_slots (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : result (alloc_vec_Vec (list_t t)) = hashMap_allocate_slots_loop t slots n -(** [hashmap::HashMap::{0}::new_with_capacity]: forward function *) +(** [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function *) let hashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -49,11 +49,11 @@ let hashMap_new_with_capacity slots = slots } -(** [hashmap::HashMap::{0}::new]: forward function *) +(** [hashmap::{hashmap::HashMap}::new]: forward function *) let hashMap_new (t : Type0) : result (hashMap_t t) = hashMap_new_with_capacity t 32 4 5 -(** [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashMap_clear_loop (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : @@ -66,22 +66,22 @@ let rec hashMap_clear_loop let* i1 = usize_add i 1 in let* slots0 = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots - i List_Nil in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i + List_Nil in hashMap_clear_loop t slots0 i1 else Return slots -(** [hashmap::HashMap::{0}::clear]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashMap_clear (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = let* v = hashMap_clear_loop t self.slots 0 in Return { self with num_entries = 0; slots = v } -(** [hashmap::HashMap::{0}::len]: forward function *) +(** [hashmap::{hashmap::HashMap}::len]: forward function *) let hashMap_len (t : Type0) (self : hashMap_t t) : result usize = Return self.num_entries -(** [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function *) let rec hashMap_insert_in_list_loop (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result bool) @@ -95,12 +95,12 @@ let rec hashMap_insert_in_list_loop | List_Nil -> Return true end -(** [hashmap::HashMap::{0}::insert_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: forward function *) let hashMap_insert_in_list (t : Type0) (key : usize) (value : t) (ls : list_t t) : result bool = hashMap_insert_in_list_loop t key value ls -(** [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) let rec hashMap_insert_in_list_loop_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result (list_t t)) @@ -116,12 +116,12 @@ let rec hashMap_insert_in_list_loop_back | List_Nil -> let l = List_Nil in Return (List_Cons key value l) end -(** [hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 *) let hashMap_insert_in_list_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : result (list_t t) = hashMap_insert_in_list_loop_back t key value ls -(** [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashMap_insert_no_resize (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : @@ -132,8 +132,8 @@ let hashMap_insert_no_resize let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in let* inserted = hashMap_insert_in_list t key value l in if inserted then @@ -141,18 +141,18 @@ let hashMap_insert_no_resize let* l0 = hashMap_insert_in_list_back t key value l in let* v = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod l0 in Return { self with num_entries = i0; slots = v } else let* l0 = hashMap_insert_in_list_back t key value l in let* v = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod l0 in Return { self with slots = v } -(** [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashMap_move_elements_from_list_loop (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : @@ -166,13 +166,13 @@ let rec hashMap_move_elements_from_list_loop | List_Nil -> Return ntable end -(** [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashMap_move_elements_from_list (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : result (hashMap_t t) = hashMap_move_elements_from_list_loop t ntable ls -(** [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashMap_move_elements_loop (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) @@ -185,20 +185,18 @@ let rec hashMap_move_elements_loop then let* l = alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots - i in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i in let ls = core_mem_replace (list_t t) l List_Nil in let* ntable0 = hashMap_move_elements_from_list t ntable ls in let* i1 = usize_add i 1 in let l0 = core_mem_replace_back (list_t t) l List_Nil in let* slots0 = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) slots - i l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i l0 in hashMap_move_elements_loop t ntable0 slots0 i1 else Return (ntable, slots) -(** [hashmap::HashMap::{0}::move_elements]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashMap_move_elements (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) @@ -207,7 +205,7 @@ let hashMap_move_elements = hashMap_move_elements_loop t ntable slots i -(** [hashmap::HashMap::{0}::try_resize]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashMap_try_resize (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = @@ -226,7 +224,7 @@ let hashMap_try_resize } else Return { self with max_load_factor = (i, i0) } -(** [hashmap::HashMap::{0}::insert]: merged forward/backward function +(** [hashmap::{hashmap::HashMap}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashMap_insert (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : @@ -236,7 +234,7 @@ let hashMap_insert let* i = hashMap_len t self0 in if i > self0.max_load then hashMap_try_resize t self0 else Return self0 -(** [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) let rec hashMap_contains_key_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result bool) @@ -250,12 +248,12 @@ let rec hashMap_contains_key_in_list_loop | List_Nil -> Return false end -(** [hashmap::HashMap::{0}::contains_key_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function *) let hashMap_contains_key_in_list (t : Type0) (key : usize) (ls : list_t t) : result bool = hashMap_contains_key_in_list_loop t key ls -(** [hashmap::HashMap::{0}::contains_key]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key]: forward function *) let hashMap_contains_key (t : Type0) (self : hashMap_t t) (key : usize) : result bool = let* hash = hash_key key in @@ -263,11 +261,11 @@ let hashMap_contains_key let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in hashMap_contains_key_in_list t key l -(** [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function *) let rec hashMap_get_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result t) (decreases (hashMap_get_in_list_loop_decreases t key ls)) @@ -278,22 +276,22 @@ let rec hashMap_get_in_list_loop | List_Nil -> Fail Failure end -(** [hashmap::HashMap::{0}::get_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: forward function *) let hashMap_get_in_list (t : Type0) (key : usize) (ls : list_t t) : result t = hashMap_get_in_list_loop t key ls -(** [hashmap::HashMap::{0}::get]: forward function *) +(** [hashmap::{hashmap::HashMap}::get]: forward function *) let hashMap_get (t : Type0) (self : hashMap_t t) (key : usize) : result t = let* hash = hash_key key in let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in hashMap_get_in_list t key l -(** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) let rec hashMap_get_mut_in_list_loop (t : Type0) (ls : list_t t) (key : usize) : Tot (result t) (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) @@ -304,12 +302,12 @@ let rec hashMap_get_mut_in_list_loop | List_Nil -> Fail Failure end -(** [hashmap::HashMap::{0}::get_mut_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function *) let hashMap_get_mut_in_list (t : Type0) (ls : list_t t) (key : usize) : result t = hashMap_get_mut_in_list_loop t ls key -(** [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) let rec hashMap_get_mut_in_list_loop_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : Tot (result (list_t t)) @@ -325,23 +323,23 @@ let rec hashMap_get_mut_in_list_loop_back | List_Nil -> Fail Failure end -(** [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 *) let hashMap_get_mut_in_list_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : result (list_t t) = hashMap_get_mut_in_list_loop_back t ls key ret -(** [hashmap::HashMap::{0}::get_mut]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut]: forward function *) let hashMap_get_mut (t : Type0) (self : hashMap_t t) (key : usize) : result t = let* hash = hash_key key in let i = alloc_vec_Vec_len (list_t t) self.slots in let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in hashMap_get_mut_in_list t l key -(** [hashmap::HashMap::{0}::get_mut]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 *) let hashMap_get_mut_back (t : Type0) (self : hashMap_t t) (key : usize) (ret : t) : result (hashMap_t t) @@ -351,16 +349,16 @@ let hashMap_get_mut_back let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in let* l0 = hashMap_get_mut_in_list_back t l key ret in let* v = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod l0 in Return { self with slots = v } -(** [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function *) let rec hashMap_remove_from_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result (option t)) @@ -379,12 +377,12 @@ let rec hashMap_remove_from_list_loop | List_Nil -> Return None end -(** [hashmap::HashMap::{0}::remove_from_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: forward function *) let hashMap_remove_from_list (t : Type0) (key : usize) (ls : list_t t) : result (option t) = hashMap_remove_from_list_loop t key ls -(** [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) let rec hashMap_remove_from_list_loop_back (t : Type0) (key : usize) (ls : list_t t) : Tot (result (list_t t)) @@ -405,12 +403,12 @@ let rec hashMap_remove_from_list_loop_back | List_Nil -> Return List_Nil end -(** [hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 *) let hashMap_remove_from_list_back (t : Type0) (key : usize) (ls : list_t t) : result (list_t t) = hashMap_remove_from_list_loop_back t key ls -(** [hashmap::HashMap::{0}::remove]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove]: forward function *) let hashMap_remove (t : Type0) (self : hashMap_t t) (key : usize) : result (option t) = let* hash = hash_key key in @@ -418,15 +416,15 @@ let hashMap_remove let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in let* x = hashMap_remove_from_list t key l in begin match x with | None -> Return None | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end -(** [hashmap::HashMap::{0}::remove]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::remove]: backward function 0 *) let hashMap_remove_back (t : Type0) (self : hashMap_t t) (key : usize) : result (hashMap_t t) = let* hash = hash_key key in @@ -434,24 +432,24 @@ let hashMap_remove_back let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod in let* x = hashMap_remove_from_list t key l in begin match x with | None -> let* l0 = hashMap_remove_from_list_back t key l in let* v = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod l0 in Return { self with slots = v } | Some x0 -> let* i0 = usize_sub self.num_entries 1 in let* l0 = hashMap_remove_from_list_back t key l in let* v = alloc_vec_Vec_index_mut_back (list_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t t)) - self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) self.slots + hash_mod l0 in Return { self with num_entries = i0; slots = v } end diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst index 61885ac7..106fa94b 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst @@ -6,56 +6,56 @@ open HashmapMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: decreases clause *) unfold let hashmap_HashMap_allocate_slots_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::clear]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: decreases clause *) unfold let hashmap_HashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: decreases clause *) unfold let hashmap_HashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: decreases clause *) unfold let hashmap_HashMap_move_elements_from_list_loop_decreases (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::move_elements]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: decreases clause *) unfold let hashmap_HashMap_move_elements_loop_decreases (t : Type0) (ntable : hashmap_HashMap_t t) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: decreases clause *) unfold let hashmap_HashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: decreases clause *) unfold let hashmap_HashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: decreases clause *) unfold let hashmap_HashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : hashmap_List_t t) (key : usize) : nat = admit () -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: decreases clause *) unfold let hashmap_HashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : nat = diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 5f227596..30bcfb2e 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -12,7 +12,7 @@ include HashmapMain.Clauses let hashmap_hash_key (k : usize) : result usize = Return k -(** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function *) let rec hashmap_HashMap_allocate_slots_loop (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : Tot (result (alloc_vec_Vec (hashmap_List_t t))) @@ -26,14 +26,14 @@ let rec hashmap_HashMap_allocate_slots_loop hashmap_HashMap_allocate_slots_loop t slots0 n0 else Return slots -(** [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function *) let hashmap_HashMap_allocate_slots (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : result (alloc_vec_Vec (hashmap_List_t t)) = hashmap_HashMap_allocate_slots_loop t slots n -(** [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function *) let hashmap_HashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -51,11 +51,11 @@ let hashmap_HashMap_new_with_capacity slots = slots } -(** [hashmap_main::hashmap::HashMap::{0}::new]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function *) let hashmap_HashMap_new (t : Type0) : result (hashmap_HashMap_t t) = hashmap_HashMap_new_with_capacity t 32 4 5 -(** [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashmap_HashMap_clear_loop (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : @@ -68,24 +68,24 @@ let rec hashmap_HashMap_clear_loop let* i1 = usize_add i 1 in let* slots0 = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) slots i Hashmap_List_Nil in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i + Hashmap_List_Nil in hashmap_HashMap_clear_loop t slots0 i1 else Return slots -(** [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashmap_HashMap_clear (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = let* v = hashmap_HashMap_clear_loop t self.slots 0 in Return { self with num_entries = 0; slots = v } -(** [hashmap_main::hashmap::HashMap::{0}::len]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function *) let hashmap_HashMap_len (t : Type0) (self : hashmap_HashMap_t t) : result usize = Return self.num_entries -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function *) let rec hashmap_HashMap_insert_in_list_loop (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : Tot (result bool) @@ -99,12 +99,12 @@ let rec hashmap_HashMap_insert_in_list_loop | Hashmap_List_Nil -> Return true end -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function *) let hashmap_HashMap_insert_in_list (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : result bool = hashmap_HashMap_insert_in_list_loop t key value ls -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) let rec hashmap_HashMap_insert_in_list_loop_back (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : Tot (result (hashmap_List_t t)) @@ -121,14 +121,14 @@ let rec hashmap_HashMap_insert_in_list_loop_back let l = Hashmap_List_Nil in Return (Hashmap_List_Cons key value l) end -(** [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 *) let hashmap_HashMap_insert_in_list_back (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : result (hashmap_List_t t) = hashmap_HashMap_insert_in_list_loop_back t key value ls -(** [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashmap_HashMap_insert_no_resize (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : @@ -139,7 +139,7 @@ let hashmap_HashMap_insert_no_resize let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in let* inserted = hashmap_HashMap_insert_in_list t key value l in if inserted @@ -148,18 +148,18 @@ let hashmap_HashMap_insert_no_resize let* l0 = hashmap_HashMap_insert_in_list_back t key value l in let* v = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) + self.slots hash_mod l0 in Return { self with num_entries = i0; slots = v } else let* l0 = hashmap_HashMap_insert_in_list_back t key value l in let* v = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) + self.slots hash_mod l0 in Return { self with slots = v } -(** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashmap_HashMap_move_elements_from_list_loop (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : @@ -174,7 +174,7 @@ let rec hashmap_HashMap_move_elements_from_list_loop | Hashmap_List_Nil -> Return ntable end -(** [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashmap_HashMap_move_elements_from_list (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : @@ -182,7 +182,7 @@ let hashmap_HashMap_move_elements_from_list = hashmap_HashMap_move_elements_from_list_loop t ntable ls -(** [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec hashmap_HashMap_move_elements_loop (t : Type0) (ntable : hashmap_HashMap_t t) @@ -195,20 +195,20 @@ let rec hashmap_HashMap_move_elements_loop then let* l = alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) slots i in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i + in let ls = core_mem_replace (hashmap_List_t t) l Hashmap_List_Nil in let* ntable0 = hashmap_HashMap_move_elements_from_list t ntable ls in let* i1 = usize_add i 1 in let l0 = core_mem_replace_back (hashmap_List_t t) l Hashmap_List_Nil in let* slots0 = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) slots i l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i + l0 in hashmap_HashMap_move_elements_loop t ntable0 slots0 i1 else Return (ntable, slots) -(** [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashmap_HashMap_move_elements (t : Type0) (ntable : hashmap_HashMap_t t) @@ -217,7 +217,7 @@ let hashmap_HashMap_move_elements = hashmap_HashMap_move_elements_loop t ntable slots i -(** [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashmap_HashMap_try_resize (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = @@ -236,7 +236,7 @@ let hashmap_HashMap_try_resize } else Return { self with max_load_factor = (i, i0) } -(** [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let hashmap_HashMap_insert (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : @@ -248,7 +248,7 @@ let hashmap_HashMap_insert then hashmap_HashMap_try_resize t self0 else Return self0 -(** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) let rec hashmap_HashMap_contains_key_in_list_loop (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result bool) @@ -262,12 +262,12 @@ let rec hashmap_HashMap_contains_key_in_list_loop | Hashmap_List_Nil -> Return false end -(** [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function *) let hashmap_HashMap_contains_key_in_list (t : Type0) (key : usize) (ls : hashmap_List_t t) : result bool = hashmap_HashMap_contains_key_in_list_loop t key ls -(** [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function *) let hashmap_HashMap_contains_key (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result bool = let* hash = hashmap_hash_key key in @@ -275,11 +275,11 @@ let hashmap_HashMap_contains_key let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in hashmap_HashMap_contains_key_in_list t key l -(** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function *) let rec hashmap_HashMap_get_in_list_loop (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result t) @@ -293,12 +293,12 @@ let rec hashmap_HashMap_get_in_list_loop | Hashmap_List_Nil -> Fail Failure end -(** [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function *) let hashmap_HashMap_get_in_list (t : Type0) (key : usize) (ls : hashmap_List_t t) : result t = hashmap_HashMap_get_in_list_loop t key ls -(** [hashmap_main::hashmap::HashMap::{0}::get]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function *) let hashmap_HashMap_get (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = let* hash = hashmap_hash_key key in @@ -306,11 +306,11 @@ let hashmap_HashMap_get let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in hashmap_HashMap_get_in_list t key l -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) let rec hashmap_HashMap_get_mut_in_list_loop (t : Type0) (ls : hashmap_List_t t) (key : usize) : Tot (result t) @@ -324,12 +324,12 @@ let rec hashmap_HashMap_get_mut_in_list_loop | Hashmap_List_Nil -> Fail Failure end -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function *) let hashmap_HashMap_get_mut_in_list (t : Type0) (ls : hashmap_List_t t) (key : usize) : result t = hashmap_HashMap_get_mut_in_list_loop t ls key -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) let rec hashmap_HashMap_get_mut_in_list_loop_back (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : Tot (result (hashmap_List_t t)) @@ -345,14 +345,14 @@ let rec hashmap_HashMap_get_mut_in_list_loop_back | Hashmap_List_Nil -> Fail Failure end -(** [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 *) let hashmap_HashMap_get_mut_in_list_back (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : result (hashmap_List_t t) = hashmap_HashMap_get_mut_in_list_loop_back t ls key ret -(** [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function *) let hashmap_HashMap_get_mut (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = let* hash = hashmap_hash_key key in @@ -360,11 +360,11 @@ let hashmap_HashMap_get_mut let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in hashmap_HashMap_get_mut_in_list t l key -(** [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 *) let hashmap_HashMap_get_mut_back (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (ret : t) : result (hashmap_HashMap_t t) @@ -374,16 +374,16 @@ let hashmap_HashMap_get_mut_back let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in let* l0 = hashmap_HashMap_get_mut_in_list_back t l key ret in let* v = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod l0 in Return { self with slots = v } -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function *) let rec hashmap_HashMap_remove_from_list_loop (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result (option t)) @@ -404,12 +404,12 @@ let rec hashmap_HashMap_remove_from_list_loop | Hashmap_List_Nil -> Return None end -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function *) let hashmap_HashMap_remove_from_list (t : Type0) (key : usize) (ls : hashmap_List_t t) : result (option t) = hashmap_HashMap_remove_from_list_loop t key ls -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) let rec hashmap_HashMap_remove_from_list_loop_back (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result (hashmap_List_t t)) @@ -432,14 +432,14 @@ let rec hashmap_HashMap_remove_from_list_loop_back | Hashmap_List_Nil -> Return Hashmap_List_Nil end -(** [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 *) let hashmap_HashMap_remove_from_list_back (t : Type0) (key : usize) (ls : hashmap_List_t t) : result (hashmap_List_t t) = hashmap_HashMap_remove_from_list_loop_back t key ls -(** [hashmap_main::hashmap::HashMap::{0}::remove]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function *) let hashmap_HashMap_remove (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result (option t) = let* hash = hashmap_hash_key key in @@ -447,7 +447,7 @@ let hashmap_HashMap_remove let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in let* x = hashmap_HashMap_remove_from_list t key l in begin match x with @@ -455,7 +455,7 @@ let hashmap_HashMap_remove | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end -(** [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 *) let hashmap_HashMap_remove_back (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result (hashmap_HashMap_t t) @@ -465,7 +465,7 @@ let hashmap_HashMap_remove_back let* hash_mod = usize_rem hash i in let* l = alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t t)) + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) self.slots hash_mod in let* x = hashmap_HashMap_remove_from_list t key l in begin match x with @@ -473,16 +473,16 @@ let hashmap_HashMap_remove_back let* l0 = hashmap_HashMap_remove_from_list_back t key l in let* v = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) + self.slots hash_mod l0 in Return { self with slots = v } | Some x0 -> let* i0 = usize_sub self.num_entries 1 in let* l0 = hashmap_HashMap_remove_from_list_back t key l in let* v = alloc_vec_Vec_index_mut_back (hashmap_List_t t) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (hashmap_List_t - t)) self.slots hash_mod l0 in + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) + self.slots hash_mod l0 in Return { self with num_entries = i0; slots = v } end diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/fstar/misc/Constants.fst b/tests/fstar/misc/Constants.fst index c21d6a5f..2f2fccdb 100644 --- a/tests/fstar/misc/Constants.fst +++ b/tests/fstar/misc/Constants.fst @@ -55,7 +55,7 @@ let p3_c : pair_t u32 u32 = eval_global p3_body (** [constants::Wrap] *) type wrap_t (t : Type0) = { value : t; } -(** [constants::Wrap::{0}::new]: forward function *) +(** [constants::{constants::Wrap}::new]: forward function *) let wrap_new (t : Type0) (value : t) : result (wrap_t t) = Return { value = value } diff --git a/tests/fstar/misc/External.Opaque.fsti b/tests/fstar/misc/External.Opaque.fsti index 85cf285c..3914a8eb 100644 --- a/tests/fstar/misc/External.Opaque.fsti +++ b/tests/fstar/misc/External.Opaque.fsti @@ -17,11 +17,11 @@ val core_mem_swap_back0 val core_mem_swap_back1 (t : Type0) : t -> t -> state -> state -> result (state & t) -(** [core::num::nonzero::NonZeroU32::{14}::new]: forward function *) +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function *) val core_num_nonzero_NonZeroU32_new : u32 -> state -> result (state & (option core_num_nonzero_NonZeroU32_t)) -(** [core::option::Option::{0}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function *) val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/misc/Loops.Funs.fst b/tests/fstar/misc/Loops.Funs.fst index 0f755351..4dd3a5dd 100644 --- a/tests/fstar/misc/Loops.Funs.fst +++ b/tests/fstar/misc/Loops.Funs.fst @@ -64,7 +64,7 @@ let rec clear_loop let* i1 = usize_add i 1 in let* v0 = alloc_vec_Vec_index_mut_back u32 usize - (core_slice_index_usize_coresliceindexSliceIndexInst u32) v i 0 in + (core_slice_index_SliceIndexUsizeSliceTInst u32) v i 0 in clear_loop v0 i1 else Return v @@ -157,8 +157,7 @@ let get_elem_mut (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = let* l = alloc_vec_Vec_index_mut (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) - slots 0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in get_elem_mut_loop x l (** [loops::get_elem_mut]: loop 0: backward function 0 *) @@ -181,12 +180,10 @@ let get_elem_mut_back = let* l = alloc_vec_Vec_index_mut (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) - slots 0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in let* l0 = get_elem_mut_loop_back x l ret in alloc_vec_Vec_index_mut_back (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) slots - 0 l0 + (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 l0 (** [loops::get_elem_shared]: loop 0: forward function *) let rec get_elem_shared_loop @@ -203,8 +200,7 @@ let get_elem_shared (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = let* l = alloc_vec_Vec_index (list_t usize) usize - (core_slice_index_usize_coresliceindexSliceIndexInst (list_t usize)) - slots 0 in + (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in get_elem_shared_loop x l (** [loops::id_mut]: forward function *) diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index e97927aa..a6269f60 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -129,7 +129,10 @@ let _ = assert_norm (test_list1 = Return ()) (** [no_nested_borrows::test_box1]: forward function *) let test_box1 : result unit = - let b = 1 in let x = b in if not (x = 1) then Fail Failure else Return () + let b = 0 in + let* b0 = alloc_boxed_Box_deref_mut_back i32 b 1 in + let* x = alloc_boxed_Box_deref i32 b0 in + if not (x = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_box1] *) let _ = assert_norm (test_box1 = Return ()) diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/fstar/traits/Primitives.fst b/tests/fstar/traits/Primitives.fst index 3297803c..94322ead 100644 --- a/tests/fstar/traits/Primitives.fst +++ b/tests/fstar/traits/Primitives.fst @@ -351,14 +351,14 @@ let alloc_boxed_Box_deref_mut (t : Type0) (x : t) : result t = Return x let alloc_boxed_Box_deref_mut_back (t : Type) (_ : t) (x : t) : result t = Return x // Trait instance -let alloc_boxed_Box_coreOpsDerefInst (self : Type0) : core_ops_deref_Deref self = { +let alloc_boxed_Box_coreopsDerefInst (self : Type0) : core_ops_deref_Deref self = { target = self; deref = alloc_boxed_Box_deref self; } // Trait instance -let alloc_boxed_Box_coreOpsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { - derefInst = alloc_boxed_Box_coreOpsDerefInst self; +let alloc_boxed_Box_coreopsDerefMutInst (self : Type0) : core_ops_deref_DerefMut self = { + derefInst = alloc_boxed_Box_coreopsDerefInst self; deref_mut = alloc_boxed_Box_deref_mut self; deref_mut_back = alloc_boxed_Box_deref_mut_back self; } @@ -483,23 +483,23 @@ let core_slice_index_Slice_index | Some x -> Return x // [core::slice::index::Range:::get]: forward function -let core_slice_index_Range_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : +let core_slice_index_RangeUsize_get (t : Type0) (i : core_ops_range_Range usize) (s : slice t) : result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: forward function -let core_slice_index_Range_get_mut +let core_slice_index_RangeUsize_get_mut (t : Type0) : core_ops_range_Range usize → slice t → result (option (slice t)) = admit () // TODO // [core::slice::index::Range::get_mut]: backward function 0 -let core_slice_index_Range_get_mut_back +let core_slice_index_RangeUsize_get_mut_back (t : Type0) : core_ops_range_Range usize → slice t → option (slice t) → result (slice t) = admit () // TODO // [core::slice::index::Range::get_unchecked]: forward function -let core_slice_index_Range_get_unchecked +let core_slice_index_RangeUsize_get_unchecked (t : Type0) : core_ops_range_Range usize → const_raw_ptr (slice t) → result (const_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -507,7 +507,7 @@ let core_slice_index_Range_get_unchecked fun _ _ -> Fail Failure // [core::slice::index::Range::get_unchecked_mut]: forward function -let core_slice_index_Range_get_unchecked_mut +let core_slice_index_RangeUsize_get_unchecked_mut (t : Type0) : core_ops_range_Range usize → mut_raw_ptr (slice t) → result (mut_raw_ptr (slice t)) = // Don't know what the model should be - for now we always fail to make @@ -515,17 +515,17 @@ let core_slice_index_Range_get_unchecked_mut fun _ _ -> Fail Failure // [core::slice::index::Range::index]: forward function -let core_slice_index_Range_index +let core_slice_index_RangeUsize_index (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: forward function -let core_slice_index_Range_index_mut +let core_slice_index_RangeUsize_index_mut (t : Type0) : core_ops_range_Range usize → slice t → result (slice t) = admit () // TODO // [core::slice::index::Range::index_mut]: backward function 0 -let core_slice_index_Range_index_mut_back +let core_slice_index_RangeUsize_index_mut_back (t : Type0) : core_ops_range_Range usize → slice t → slice t → result (slice t) = admit () // TODO @@ -559,44 +559,44 @@ let core_array_Array_index_mut_back (a : array t n) (i : idx) (x : inst.indexInst.output) : result (array t n) = admit () // TODO -// Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexInst (t idx : Type0) - (inst : core_slice_index_SliceIndex idx (slice t)) : - core_ops_index_Index (slice t) idx = { - output = inst.output; - index = core_slice_index_Slice_index t idx inst; -} - // Trait implementation: [core::slice::index::private_slice_index::Range] -let core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedRangeUsizeInst : core_slice_index_private_slice_index_Sealed (core_ops_range_Range usize) = () // Trait implementation: [core::slice::index::Range] -let core_slice_index_Range_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexRangeUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex (core_ops_range_Range usize) (slice t) = { - sealedInst = core_slice_index_private_slice_index_Range_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedRangeUsizeInst; output = slice t; - get = core_slice_index_Range_get t; - get_mut = core_slice_index_Range_get_mut t; - get_mut_back = core_slice_index_Range_get_mut_back t; - get_unchecked = core_slice_index_Range_get_unchecked t; - get_unchecked_mut = core_slice_index_Range_get_unchecked_mut t; - index = core_slice_index_Range_index t; - index_mut = core_slice_index_Range_index_mut t; - index_mut_back = core_slice_index_Range_index_mut_back t; + get = core_slice_index_RangeUsize_get t; + get_mut = core_slice_index_RangeUsize_get_mut t; + get_mut_back = core_slice_index_RangeUsize_get_mut_back t; + get_unchecked = core_slice_index_RangeUsize_get_unchecked t; + get_unchecked_mut = core_slice_index_RangeUsize_get_unchecked_mut t; + index = core_slice_index_RangeUsize_index t; + index_mut = core_slice_index_RangeUsize_index_mut t; + index_mut_back = core_slice_index_RangeUsize_index_mut_back t; +} + +// Trait implementation: [core::slice::index::[T]] +let core_ops_index_IndexSliceTIInst (t idx : Type0) + (inst : core_slice_index_SliceIndex idx (slice t)) : + core_ops_index_Index (slice t) idx = { + output = inst.output; + index = core_slice_index_Slice_index t idx inst; } // Trait implementation: [core::slice::index::[T]] -let core_slice_index_Slice_coreopsindexIndexMutInst (t idx : Type0) +let core_ops_index_IndexMutSliceTIInst (t idx : Type0) (inst : core_slice_index_SliceIndex idx (slice t)) : core_ops_index_IndexMut (slice t) idx = { - indexInst = core_slice_index_Slice_coreopsindexIndexInst t idx inst; + indexInst = core_ops_index_IndexSliceTIInst t idx inst; index_mut = core_slice_index_Slice_index_mut t idx inst; index_mut_back = core_slice_index_Slice_index_mut_back t idx inst; } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) +let core_ops_index_IndexArrayInst (t idx : Type0) (n : usize) (inst : core_ops_index_Index (slice t) idx) : core_ops_index_Index (array t n) idx = { output = inst.output; @@ -604,10 +604,10 @@ let core_array_Array_coreopsindexIndexInst (t idx : Type0) (n : usize) } // Trait implementation: [core::array::[T; N]] -let core_array_Array_coreopsindexIndexMutInst (t idx : Type0) (n : usize) +let core_ops_index_IndexMutArrayIInst (t idx : Type0) (n : usize) (inst : core_ops_index_IndexMut (slice t) idx) : core_ops_index_IndexMut (array t n) idx = { - indexInst = core_array_Array_coreopsindexIndexInst t idx n inst.indexInst; + indexInst = core_ops_index_IndexArrayInst t idx n inst.indexInst; index_mut = core_array_Array_index_mut t idx n inst; index_mut_back = core_array_Array_index_mut_back t idx n inst; } @@ -651,13 +651,13 @@ let core_slice_index_usize_index_mut_back admit () // TODO // Trait implementation: [core::slice::index::private_slice_index::usize] -let core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst +let core_slice_index_private_slice_index_SealedUsizeInst : core_slice_index_private_slice_index_Sealed usize = () // Trait implementation: [core::slice::index::usize] -let core_slice_index_usize_coresliceindexSliceIndexInst (t : Type0) : +let core_slice_index_SliceIndexUsizeSliceTInst (t : Type0) : core_slice_index_SliceIndex usize (slice t) = { - sealedInst = core_slice_index_private_slice_index_usize_coresliceindexprivate_slice_indexSealedInst; + sealedInst = core_slice_index_private_slice_index_SealedUsizeInst; output = t; get = core_slice_index_usize_get t; get_mut = core_slice_index_usize_get_mut t; @@ -706,24 +706,24 @@ let alloc_vec_Vec_coreopsindexIndexMutInst (t idx : Type0) let alloc_vec_Vec_index_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) : Lemma ( - alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i == + alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i == alloc_vec_Vec_index_usize v i) - [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i)] + [SMTPat (alloc_vec_Vec_index_mut a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i)] = admit() let alloc_vec_Vec_index_mut_back_eq (#a : Type0) (v : alloc_vec_Vec a) (i : usize) (x : a) : Lemma ( - alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x == + alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x == alloc_vec_Vec_update_usize v i x) - [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_usize_coresliceindexSliceIndexInst a) v i x)] + [SMTPat (alloc_vec_Vec_index_mut_back a usize (core_slice_index_SliceIndexUsizeSliceTInst a) v i x)] = admit() diff --git a/tests/lean/Array.lean b/tests/lean/Array.lean index 20f02e97..5a4e09ab 100644 --- a/tests/lean/Array.lean +++ b/tests/lean/Array.lean @@ -91,14 +91,14 @@ def index_mut_slice_back def slice_subslice_shared_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := core.slice.index.Slice.index U32 (core.ops.range.Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x { start := y, end_ := z } /- [array::slice_subslice_mut_]: forward function -/ def slice_subslice_mut_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := core.slice.index.Slice.index_mut U32 (core.ops.range.Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x { start := y, end_ := z } /- [array::slice_subslice_mut_]: backward function 0 -/ @@ -107,7 +107,7 @@ def slice_subslice_mut__back Result (Slice U32) := core.slice.index.Slice.index_mut_back U32 (core.ops.range.Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32) x + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x { start := y, end_ := z } ret0 /- [array::array_to_slice_shared_]: forward function -/ @@ -127,16 +127,16 @@ def array_to_slice_mut__back def array_subslice_shared_ (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range - Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + (core.ops.index.IndexSliceTIInst U32 (core.ops.range.Range Usize) + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } /- [array::array_subslice_mut_]: forward function -/ def array_subslice_mut_ (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index_mut U32 (core.ops.range.Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range - Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + (core.ops.index.IndexMutSliceTIInst U32 (core.ops.range.Range Usize) + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } /- [array::array_subslice_mut_]: backward function 0 -/ @@ -145,8 +145,8 @@ def array_subslice_mut__back Result (Array U32 32#usize) := core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 (core.ops.range.Range - Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + (core.ops.index.IndexMutSliceTIInst U32 (core.ops.range.Range Usize) + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } ret0 /- [array::index_slice_0]: forward function -/ @@ -288,17 +288,15 @@ def range_all : Result Unit := do let s ← core.array.Array.index_mut U32 (core.ops.range.Range Usize) 4#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 - (core.ops.range.Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (core.ops.index.IndexMutSliceTIInst U32 (core.ops.range.Range Usize) + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) { start := 1#usize, end_ := 3#usize } let s0 ← update_mut_slice s let _ ← core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 4#usize - (core.slice.index.Slice.coreopsindexIndexMutInst U32 - (core.ops.range.Range Usize) - (core.slice.index.Range.coresliceindexSliceIndexInst U32)) + (core.ops.index.IndexMutSliceTIInst U32 (core.ops.range.Range Usize) + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) (Array.make U32 4#usize [ 0#u32, 0#u32, 0#u32, 0#u32 ]) { start := 1#usize, end_ := 3#usize } s0 Result.ret () @@ -392,8 +390,8 @@ def f2 (i : U32) : Result Unit := /- [array::f4]: forward function -/ def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize - (core.slice.index.Slice.coreopsindexIndexInst U32 (core.ops.range.Range - Usize) (core.slice.index.Range.coresliceindexSliceIndexInst U32)) x + (core.ops.index.IndexSliceTIInst U32 (core.ops.range.Range Usize) + (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } /- [array::f3]: forward function -/ diff --git a/tests/lean/Constants.lean b/tests/lean/Constants.lean index bd3a07b7..62e45d76 100644 --- a/tests/lean/Constants.lean +++ b/tests/lean/Constants.lean @@ -58,7 +58,7 @@ def p3_c : Pair U32 U32 := eval_global p3_body (by simp) structure Wrap (T : Type) where value : T -/- [constants::Wrap::{0}::new]: forward function -/ +/- [constants::{constants::Wrap}::new]: forward function -/ def Wrap.new (T : Type) (value : T) : Result (Wrap T) := Result.ret { value := value } diff --git a/tests/lean/External/FunsExternal_Template.lean b/tests/lean/External/FunsExternal_Template.lean index c8bc397f..0fccef86 100644 --- a/tests/lean/External/FunsExternal_Template.lean +++ b/tests/lean/External/FunsExternal_Template.lean @@ -17,11 +17,11 @@ axiom core.mem.swap_back0 axiom core.mem.swap_back1 (T : Type) : T → T → State → State → Result (State × T) -/- [core::num::nonzero::NonZeroU32::{14}::new]: forward function -/ +/- [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function -/ axiom core.num.nonzero.NonZeroU32.new : U32 → State → Result (State × (Option core.num.nonzero.NonZeroU32)) -/- [core::option::Option::{0}::unwrap]: forward function -/ +/- [core::option::{core::option::Option}::unwrap]: forward function -/ axiom core.option.Option.unwrap (T : Type) : Option T → State → Result (State × T) diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index 8464c432..a1cd435e 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -10,7 +10,7 @@ namespace hashmap def hash_key (k : Usize) : Result Usize := Result.ret k -/- [hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function -/ divergent def HashMap.allocate_slots_loop (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : Result (alloc.vec.Vec (List T)) @@ -23,14 +23,14 @@ divergent def HashMap.allocate_slots_loop HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots -/- [hashmap::HashMap::{0}::allocate_slots]: forward function -/ +/- [hashmap::{hashmap::HashMap}::allocate_slots]: forward function -/ def HashMap.allocate_slots (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : Result (alloc.vec.Vec (List T)) := HashMap.allocate_slots_loop T slots n -/- [hashmap::HashMap::{0}::new_with_capacity]: forward function -/ +/- [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function -/ def HashMap.new_with_capacity (T : Type) (capacity : Usize) (max_load_dividend : Usize) (max_load_divisor : Usize) : @@ -49,11 +49,11 @@ def HashMap.new_with_capacity slots := slots } -/- [hashmap::HashMap::{0}::new]: forward function -/ +/- [hashmap::{hashmap::HashMap}::new]: forward function -/ def HashMap.new (T : Type) : Result (HashMap T) := HashMap.new_with_capacity T 32#usize 4#usize 5#usize -/- [hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.clear_loop (T : Type) (slots : alloc.vec.Vec (List T)) (i : Usize) : @@ -66,23 +66,23 @@ divergent def HashMap.clear_loop let i1 ← i + 1#usize let slots0 ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots - i List.Nil + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i + List.Nil HashMap.clear_loop T slots0 i1 else Result.ret slots -/- [hashmap::HashMap::{0}::clear]: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.clear (T : Type) (self : HashMap T) : Result (HashMap T) := do let v ← HashMap.clear_loop T self.slots 0#usize Result.ret { self with num_entries := 0#usize, slots := v } -/- [hashmap::HashMap::{0}::len]: forward function -/ +/- [hashmap::{hashmap::HashMap}::len]: forward function -/ def HashMap.len (T : Type) (self : HashMap T) : Result Usize := Result.ret self.num_entries -/- [hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function -/ divergent def HashMap.insert_in_list_loop (T : Type) (key : Usize) (value : T) (ls : List T) : Result Bool := match ls with @@ -92,12 +92,12 @@ divergent def HashMap.insert_in_list_loop else HashMap.insert_in_list_loop T key value tl | List.Nil => Result.ret true -/- [hashmap::HashMap::{0}::insert_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: forward function -/ def HashMap.insert_in_list (T : Type) (key : Usize) (value : T) (ls : List T) : Result Bool := HashMap.insert_in_list_loop T key value ls -/- [hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 -/ divergent def HashMap.insert_in_list_loop_back (T : Type) (key : Usize) (value : T) (ls : List T) : Result (List T) := match ls with @@ -111,12 +111,12 @@ divergent def HashMap.insert_in_list_loop_back | List.Nil => let l := List.Nil Result.ret (List.Cons key value l) -/- [hashmap::HashMap::{0}::insert_in_list]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 -/ def HashMap.insert_in_list_back (T : Type) (key : Usize) (value : T) (ls : List T) : Result (List T) := HashMap.insert_in_list_loop_back T key value ls -/- [hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.insert_no_resize (T : Type) (self : HashMap T) (key : Usize) (value : T) : @@ -128,8 +128,8 @@ def HashMap.insert_no_resize let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod let inserted ← HashMap.insert_in_list T key value l if inserted then @@ -138,19 +138,19 @@ def HashMap.insert_no_resize let l0 ← HashMap.insert_in_list_back T key value l let v ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod l0 Result.ret { self with num_entries := i0, slots := v } else do let l0 ← HashMap.insert_in_list_back T key value l let v ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod l0 Result.ret { self with slots := v } -/- [hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.move_elements_from_list_loop (T : Type) (ntable : HashMap T) (ls : List T) : Result (HashMap T) := @@ -161,13 +161,13 @@ divergent def HashMap.move_elements_from_list_loop HashMap.move_elements_from_list_loop T ntable0 tl | List.Nil => Result.ret ntable -/- [hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.move_elements_from_list (T : Type) (ntable : HashMap T) (ls : List T) : Result (HashMap T) := HashMap.move_elements_from_list_loop T ntable ls -/- [hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def HashMap.move_elements_loop (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) @@ -180,20 +180,18 @@ divergent def HashMap.move_elements_loop do let l ← alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots - i + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i let ls := core.mem.replace (List T) l List.Nil let ntable0 ← HashMap.move_elements_from_list T ntable ls let i1 ← i + 1#usize let l0 := core.mem.replace_back (List T) l List.Nil let slots0 ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) slots - i l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i l0 HashMap.move_elements_loop T ntable0 slots0 i1 else Result.ret (ntable, slots) -/- [hashmap::HashMap::{0}::move_elements]: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.move_elements (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) @@ -202,7 +200,7 @@ def HashMap.move_elements := HashMap.move_elements_loop T ntable slots i -/- [hashmap::HashMap::{0}::try_resize]: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := do @@ -225,7 +223,7 @@ def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := } else Result.ret { self with max_load_factor := (i, i0) } -/- [hashmap::HashMap::{0}::insert]: merged forward/backward function +/- [hashmap::{hashmap::HashMap}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def HashMap.insert (T : Type) (self : HashMap T) (key : Usize) (value : T) : @@ -238,7 +236,7 @@ def HashMap.insert then HashMap.try_resize T self0 else Result.ret self0 -/- [hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function -/ divergent def HashMap.contains_key_in_list_loop (T : Type) (key : Usize) (ls : List T) : Result Bool := match ls with @@ -248,12 +246,12 @@ divergent def HashMap.contains_key_in_list_loop else HashMap.contains_key_in_list_loop T key tl | List.Nil => Result.ret false -/- [hashmap::HashMap::{0}::contains_key_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function -/ def HashMap.contains_key_in_list (T : Type) (key : Usize) (ls : List T) : Result Bool := HashMap.contains_key_in_list_loop T key ls -/- [hashmap::HashMap::{0}::contains_key]: forward function -/ +/- [hashmap::{hashmap::HashMap}::contains_key]: forward function -/ def HashMap.contains_key (T : Type) (self : HashMap T) (key : Usize) : Result Bool := do @@ -262,11 +260,11 @@ def HashMap.contains_key let hash_mod ← hash % i let l ← alloc.vec.Vec.index (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod HashMap.contains_key_in_list T key l -/- [hashmap::HashMap::{0}::get_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function -/ divergent def HashMap.get_in_list_loop (T : Type) (key : Usize) (ls : List T) : Result T := match ls with @@ -276,11 +274,11 @@ divergent def HashMap.get_in_list_loop else HashMap.get_in_list_loop T key tl | List.Nil => Result.fail Error.panic -/- [hashmap::HashMap::{0}::get_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_in_list]: forward function -/ def HashMap.get_in_list (T : Type) (key : Usize) (ls : List T) : Result T := HashMap.get_in_list_loop T key ls -/- [hashmap::HashMap::{0}::get]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get]: forward function -/ def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key @@ -288,11 +286,11 @@ def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := let hash_mod ← hash % i let l ← alloc.vec.Vec.index (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod HashMap.get_in_list T key l -/- [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function -/ divergent def HashMap.get_mut_in_list_loop (T : Type) (ls : List T) (key : Usize) : Result T := match ls with @@ -302,12 +300,12 @@ divergent def HashMap.get_mut_in_list_loop else HashMap.get_mut_in_list_loop T tl key | List.Nil => Result.fail Error.panic -/- [hashmap::HashMap::{0}::get_mut_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function -/ def HashMap.get_mut_in_list (T : Type) (ls : List T) (key : Usize) : Result T := HashMap.get_mut_in_list_loop T ls key -/- [hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 -/ divergent def HashMap.get_mut_in_list_loop_back (T : Type) (ls : List T) (key : Usize) (ret0 : T) : Result (List T) := match ls with @@ -320,12 +318,12 @@ divergent def HashMap.get_mut_in_list_loop_back Result.ret (List.Cons ckey cvalue tl0) | List.Nil => Result.fail Error.panic -/- [hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 -/ def HashMap.get_mut_in_list_back (T : Type) (ls : List T) (key : Usize) (ret0 : T) : Result (List T) := HashMap.get_mut_in_list_loop_back T ls key ret0 -/- [hashmap::HashMap::{0}::get_mut]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_mut]: forward function -/ def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key @@ -333,11 +331,11 @@ def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod HashMap.get_mut_in_list T l key -/- [hashmap::HashMap::{0}::get_mut]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 -/ def HashMap.get_mut_back (T : Type) (self : HashMap T) (key : Usize) (ret0 : T) : Result (HashMap T) @@ -348,16 +346,16 @@ def HashMap.get_mut_back let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod let l0 ← HashMap.get_mut_in_list_back T l key ret0 let v ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod l0 Result.ret { self with slots := v } -/- [hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function -/ divergent def HashMap.remove_from_list_loop (T : Type) (key : Usize) (ls : List T) : Result (Option T) := match ls with @@ -371,12 +369,12 @@ divergent def HashMap.remove_from_list_loop else HashMap.remove_from_list_loop T key tl | List.Nil => Result.ret none -/- [hashmap::HashMap::{0}::remove_from_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: forward function -/ def HashMap.remove_from_list (T : Type) (key : Usize) (ls : List T) : Result (Option T) := HashMap.remove_from_list_loop T key ls -/- [hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 -/ divergent def HashMap.remove_from_list_loop_back (T : Type) (key : Usize) (ls : List T) : Result (List T) := match ls with @@ -393,12 +391,12 @@ divergent def HashMap.remove_from_list_loop_back Result.ret (List.Cons ckey t tl0) | List.Nil => Result.ret List.Nil -/- [hashmap::HashMap::{0}::remove_from_list]: backward function 1 -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 -/ def HashMap.remove_from_list_back (T : Type) (key : Usize) (ls : List T) : Result (List T) := HashMap.remove_from_list_loop_back T key ls -/- [hashmap::HashMap::{0}::remove]: forward function -/ +/- [hashmap::{hashmap::HashMap}::remove]: forward function -/ def HashMap.remove (T : Type) (self : HashMap T) (key : Usize) : Result (Option T) := do @@ -407,8 +405,8 @@ def HashMap.remove let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod let x ← HashMap.remove_from_list T key l match x with | none => Result.ret none @@ -416,7 +414,7 @@ def HashMap.remove let _ ← self.num_entries - 1#usize Result.ret (some x0) -/- [hashmap::HashMap::{0}::remove]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::remove]: backward function 0 -/ def HashMap.remove_back (T : Type) (self : HashMap T) (key : Usize) : Result (HashMap T) := do @@ -425,8 +423,8 @@ def HashMap.remove_back let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod let x ← HashMap.remove_from_list T key l match x with | none => @@ -434,8 +432,8 @@ def HashMap.remove_back let l0 ← HashMap.remove_from_list_back T key l let v ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod l0 Result.ret { self with slots := v } | some x0 => do @@ -443,8 +441,8 @@ def HashMap.remove_back let l0 ← HashMap.remove_from_list_back T key l let v ← alloc.vec.Vec.index_mut_back (List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List T)) - self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots + hash_mod l0 Result.ret { self with num_entries := i0, slots := v } /- [hashmap::test1]: forward function -/ diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index 74fa8653..5e05a399 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -11,7 +11,7 @@ namespace hashmap_main def hashmap.hash_key (k : Usize) : Result Usize := Result.ret k -/- [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function -/ divergent def hashmap.HashMap.allocate_slots_loop (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : Result (alloc.vec.Vec (hashmap.List T)) @@ -24,14 +24,14 @@ divergent def hashmap.HashMap.allocate_slots_loop hashmap.HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots -/- [hashmap_main::hashmap::HashMap::{0}::allocate_slots]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function -/ def hashmap.HashMap.allocate_slots (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : Result (alloc.vec.Vec (hashmap.List T)) := hashmap.HashMap.allocate_slots_loop T slots n -/- [hashmap_main::hashmap::HashMap::{0}::new_with_capacity]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function -/ def hashmap.HashMap.new_with_capacity (T : Type) (capacity : Usize) (max_load_dividend : Usize) (max_load_divisor : Usize) : @@ -50,11 +50,11 @@ def hashmap.HashMap.new_with_capacity slots := slots } -/- [hashmap_main::hashmap::HashMap::{0}::new]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function -/ def hashmap.HashMap.new (T : Type) : Result (hashmap.HashMap T) := hashmap.HashMap.new_with_capacity T 32#usize 4#usize 5#usize -/- [hashmap_main::hashmap::HashMap::{0}::clear]: loop 0: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.clear_loop (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : @@ -67,12 +67,12 @@ divergent def hashmap.HashMap.clear_loop let i1 ← i + 1#usize let slots0 ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) slots i hashmap.List.Nil + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i + hashmap.List.Nil hashmap.HashMap.clear_loop T slots0 i1 else Result.ret slots -/- [hashmap_main::hashmap::HashMap::{0}::clear]: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.clear (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := @@ -80,11 +80,11 @@ def hashmap.HashMap.clear let v ← hashmap.HashMap.clear_loop T self.slots 0#usize Result.ret { self with num_entries := 0#usize, slots := v } -/- [hashmap_main::hashmap::HashMap::{0}::len]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function -/ def hashmap.HashMap.len (T : Type) (self : hashmap.HashMap T) : Result Usize := Result.ret self.num_entries -/- [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function -/ divergent def hashmap.HashMap.insert_in_list_loop (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result Bool := match ls with @@ -94,12 +94,12 @@ divergent def hashmap.HashMap.insert_in_list_loop else hashmap.HashMap.insert_in_list_loop T key value tl | hashmap.List.Nil => Result.ret true -/- [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function -/ def hashmap.HashMap.insert_in_list (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result Bool := hashmap.HashMap.insert_in_list_loop T key value ls -/- [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: loop 0: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 -/ divergent def hashmap.HashMap.insert_in_list_loop_back (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result (hashmap.List T) @@ -116,14 +116,14 @@ divergent def hashmap.HashMap.insert_in_list_loop_back let l := hashmap.List.Nil Result.ret (hashmap.List.Cons key value l) -/- [hashmap_main::hashmap::HashMap::{0}::insert_in_list]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 -/ def hashmap.HashMap.insert_in_list_back (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result (hashmap.List T) := hashmap.HashMap.insert_in_list_loop_back T key value ls -/- [hashmap_main::hashmap::HashMap::{0}::insert_no_resize]: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.insert_no_resize (T : Type) (self : hashmap.HashMap T) (key : Usize) (value : T) : @@ -135,7 +135,7 @@ def hashmap.HashMap.insert_no_resize let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod let inserted ← hashmap.HashMap.insert_in_list T key value l if inserted @@ -145,19 +145,19 @@ def hashmap.HashMap.insert_no_resize let l0 ← hashmap.HashMap.insert_in_list_back T key value l let v ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) + self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } else do let l0 ← hashmap.HashMap.insert_in_list_back T key value l let v ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } -/- [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: loop 0: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.move_elements_from_list_loop (T : Type) (ntable : hashmap.HashMap T) (ls : hashmap.List T) : @@ -170,7 +170,7 @@ divergent def hashmap.HashMap.move_elements_from_list_loop hashmap.HashMap.move_elements_from_list_loop T ntable0 tl | hashmap.List.Nil => Result.ret ntable -/- [hashmap_main::hashmap::HashMap::{0}::move_elements_from_list]: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.move_elements_from_list (T : Type) (ntable : hashmap.HashMap T) (ls : hashmap.List T) : @@ -178,7 +178,7 @@ def hashmap.HashMap.move_elements_from_list := hashmap.HashMap.move_elements_from_list_loop T ntable ls -/- [hashmap_main::hashmap::HashMap::{0}::move_elements]: loop 0: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def hashmap.HashMap.move_elements_loop (T : Type) (ntable : hashmap.HashMap T) @@ -191,20 +191,19 @@ divergent def hashmap.HashMap.move_elements_loop do let l ← alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) slots i + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i let ls := core.mem.replace (hashmap.List T) l hashmap.List.Nil let ntable0 ← hashmap.HashMap.move_elements_from_list T ntable ls let i1 ← i + 1#usize let l0 := core.mem.replace_back (hashmap.List T) l hashmap.List.Nil let slots0 ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) slots i l0 + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i + l0 hashmap.HashMap.move_elements_loop T ntable0 slots0 i1 else Result.ret (ntable, slots) -/- [hashmap_main::hashmap::HashMap::{0}::move_elements]: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.move_elements (T : Type) (ntable : hashmap.HashMap T) @@ -213,7 +212,7 @@ def hashmap.HashMap.move_elements := hashmap.HashMap.move_elements_loop T ntable slots i -/- [hashmap_main::hashmap::HashMap::{0}::try_resize]: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.try_resize (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := @@ -238,7 +237,7 @@ def hashmap.HashMap.try_resize } else Result.ret { self with max_load_factor := (i, i0) } -/- [hashmap_main::hashmap::HashMap::{0}::insert]: merged forward/backward function +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def hashmap.HashMap.insert (T : Type) (self : hashmap.HashMap T) (key : Usize) (value : T) : @@ -251,7 +250,7 @@ def hashmap.HashMap.insert then hashmap.HashMap.try_resize T self0 else Result.ret self0 -/- [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function -/ divergent def hashmap.HashMap.contains_key_in_list_loop (T : Type) (key : Usize) (ls : hashmap.List T) : Result Bool := match ls with @@ -261,12 +260,12 @@ divergent def hashmap.HashMap.contains_key_in_list_loop else hashmap.HashMap.contains_key_in_list_loop T key tl | hashmap.List.Nil => Result.ret false -/- [hashmap_main::hashmap::HashMap::{0}::contains_key_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function -/ def hashmap.HashMap.contains_key_in_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result Bool := hashmap.HashMap.contains_key_in_list_loop T key ls -/- [hashmap_main::hashmap::HashMap::{0}::contains_key]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function -/ def hashmap.HashMap.contains_key (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result Bool := do @@ -275,11 +274,11 @@ def hashmap.HashMap.contains_key let hash_mod ← hash % i let l ← alloc.vec.Vec.index (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod hashmap.HashMap.contains_key_in_list T key l -/- [hashmap_main::hashmap::HashMap::{0}::get_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function -/ divergent def hashmap.HashMap.get_in_list_loop (T : Type) (key : Usize) (ls : hashmap.List T) : Result T := match ls with @@ -289,12 +288,12 @@ divergent def hashmap.HashMap.get_in_list_loop else hashmap.HashMap.get_in_list_loop T key tl | hashmap.List.Nil => Result.fail Error.panic -/- [hashmap_main::hashmap::HashMap::{0}::get_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function -/ def hashmap.HashMap.get_in_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result T := hashmap.HashMap.get_in_list_loop T key ls -/- [hashmap_main::hashmap::HashMap::{0}::get]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function -/ def hashmap.HashMap.get (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do @@ -303,11 +302,11 @@ def hashmap.HashMap.get let hash_mod ← hash % i let l ← alloc.vec.Vec.index (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod hashmap.HashMap.get_in_list T key l -/- [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function -/ divergent def hashmap.HashMap.get_mut_in_list_loop (T : Type) (ls : hashmap.List T) (key : Usize) : Result T := match ls with @@ -317,12 +316,12 @@ divergent def hashmap.HashMap.get_mut_in_list_loop else hashmap.HashMap.get_mut_in_list_loop T tl key | hashmap.List.Nil => Result.fail Error.panic -/- [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function -/ def hashmap.HashMap.get_mut_in_list (T : Type) (ls : hashmap.List T) (key : Usize) : Result T := hashmap.HashMap.get_mut_in_list_loop T ls key -/- [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: loop 0: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 -/ divergent def hashmap.HashMap.get_mut_in_list_loop_back (T : Type) (ls : hashmap.List T) (key : Usize) (ret0 : T) : Result (hashmap.List T) @@ -337,14 +336,14 @@ divergent def hashmap.HashMap.get_mut_in_list_loop_back Result.ret (hashmap.List.Cons ckey cvalue tl0) | hashmap.List.Nil => Result.fail Error.panic -/- [hashmap_main::hashmap::HashMap::{0}::get_mut_in_list]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 -/ def hashmap.HashMap.get_mut_in_list_back (T : Type) (ls : hashmap.List T) (key : Usize) (ret0 : T) : Result (hashmap.List T) := hashmap.HashMap.get_mut_in_list_loop_back T ls key ret0 -/- [hashmap_main::hashmap::HashMap::{0}::get_mut]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function -/ def hashmap.HashMap.get_mut (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do @@ -353,11 +352,11 @@ def hashmap.HashMap.get_mut let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod hashmap.HashMap.get_mut_in_list T l key -/- [hashmap_main::hashmap::HashMap::{0}::get_mut]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 -/ def hashmap.HashMap.get_mut_back (T : Type) (self : hashmap.HashMap T) (key : Usize) (ret0 : T) : Result (hashmap.HashMap T) @@ -368,16 +367,16 @@ def hashmap.HashMap.get_mut_back let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod let l0 ← hashmap.HashMap.get_mut_in_list_back T l key ret0 let v ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod l0 Result.ret { self with slots := v } -/- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function -/ divergent def hashmap.HashMap.remove_from_list_loop (T : Type) (key : Usize) (ls : hashmap.List T) : Result (Option T) := match ls with @@ -393,12 +392,12 @@ divergent def hashmap.HashMap.remove_from_list_loop else hashmap.HashMap.remove_from_list_loop T key tl | hashmap.List.Nil => Result.ret none -/- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function -/ def hashmap.HashMap.remove_from_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result (Option T) := hashmap.HashMap.remove_from_list_loop T key ls -/- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: loop 0: backward function 1 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 -/ divergent def hashmap.HashMap.remove_from_list_loop_back (T : Type) (key : Usize) (ls : hashmap.List T) : Result (hashmap.List T) := match ls with @@ -417,12 +416,12 @@ divergent def hashmap.HashMap.remove_from_list_loop_back Result.ret (hashmap.List.Cons ckey t tl0) | hashmap.List.Nil => Result.ret hashmap.List.Nil -/- [hashmap_main::hashmap::HashMap::{0}::remove_from_list]: backward function 1 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 -/ def hashmap.HashMap.remove_from_list_back (T : Type) (key : Usize) (ls : hashmap.List T) : Result (hashmap.List T) := hashmap.HashMap.remove_from_list_loop_back T key ls -/- [hashmap_main::hashmap::HashMap::{0}::remove]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function -/ def hashmap.HashMap.remove (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result (Option T) := do @@ -431,7 +430,7 @@ def hashmap.HashMap.remove let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod let x ← hashmap.HashMap.remove_from_list T key l match x with @@ -440,7 +439,7 @@ def hashmap.HashMap.remove let _ ← self.num_entries - 1#usize Result.ret (some x0) -/- [hashmap_main::hashmap::HashMap::{0}::remove]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 -/ def hashmap.HashMap.remove_back (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result (hashmap.HashMap T) @@ -451,7 +450,7 @@ def hashmap.HashMap.remove_back let hash_mod ← hash % i let l ← alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List T)) + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod let x ← hashmap.HashMap.remove_from_list T key l match x with @@ -460,8 +459,8 @@ def hashmap.HashMap.remove_back let l0 ← hashmap.HashMap.remove_from_list_back T key l let v ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) + self.slots hash_mod l0 Result.ret { self with slots := v } | some x0 => do @@ -469,8 +468,8 @@ def hashmap.HashMap.remove_back let l0 ← hashmap.HashMap.remove_from_list_back T key l let v ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (hashmap.List - T)) self.slots hash_mod l0 + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) + self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } /- [hashmap_main::hashmap::test1]: forward function -/ diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index c6360338..701dc6f7 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -59,7 +59,7 @@ divergent def clear_loop let i1 ← i + 1#usize let v0 ← alloc.vec.Vec.index_mut_back U32 Usize - (core.slice.index.usize.coresliceindexSliceIndexInst U32) v i 0#u32 + (core.slice.index.SliceIndexUsizeSliceTInst U32) v i 0#u32 clear_loop v0 i1 else Result.ret v @@ -150,8 +150,7 @@ def get_elem_mut do let l ← alloc.vec.Vec.index_mut (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) - slots 0#usize + (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize get_elem_mut_loop x l /- [loops::get_elem_mut]: loop 0: backward function 0 -/ @@ -175,12 +174,11 @@ def get_elem_mut_back do let l ← alloc.vec.Vec.index_mut (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) - slots 0#usize + (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize let l0 ← get_elem_mut_loop_back x l ret0 alloc.vec.Vec.index_mut_back (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) slots - 0#usize l0 + (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize + l0 /- [loops::get_elem_shared]: loop 0: forward function -/ divergent def get_elem_shared_loop @@ -197,8 +195,7 @@ def get_elem_shared do let l ← alloc.vec.Vec.index (List Usize) Usize - (core.slice.index.usize.coresliceindexSliceIndexInst (List Usize)) - slots 0#usize + (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize get_elem_shared_loop x l /- [loops::id_mut]: forward function -/ -- cgit v1.2.3 From 46ab0fc047c69d14e52415bd8b76be167771cd58 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 11:46:10 +0100 Subject: Regenerate the Traits files --- tests/coq/traits/Traits.v | 126 +++++++++++++++++++++------------------- tests/fstar/traits/Traits.fst | 121 +++++++++++++++++++------------------- tests/lean/Traits.lean | 132 +++++++++++++++++++++--------------------- 3 files changed, 195 insertions(+), 184 deletions(-) diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index e104fb66..a25d5089 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -16,12 +16,12 @@ Record BoolTrait_t (Self : Type) := mkBoolTrait_t { Arguments mkBoolTrait_t { _ }. Arguments BoolTrait_t_get_bool { _ }. -(** [traits::Bool::{0}::get_bool]: forward function *) +(** [traits::{bool}::get_bool]: forward function *) Definition bool_get_bool (self : bool) : result bool := Return self. -(** Trait implementation: [traits::Bool::{0}] *) -Definition Bool_BoolTraitInst : BoolTrait_t bool := {| +(** Trait implementation: [traits::{bool}] *) +Definition traits_BoolTraitBoolInst : BoolTrait_t bool := {| BoolTrait_t_get_bool := bool_get_bool; |}. @@ -34,23 +34,26 @@ Definition boolTrait_ret_true (** [traits::test_bool_trait_bool]: forward function *) Definition test_bool_trait_bool (x : bool) : result bool := b <- bool_get_bool x; - if b then boolTrait_ret_true Bool_BoolTraitInst x else Return false + if b then boolTrait_ret_true traits_BoolTraitBoolInst x else Return false . -(** [traits::Option::{1}::get_bool]: forward function *) +(** [traits::{core::option::Option#1}::get_bool]: forward function *) Definition option_get_bool (T : Type) (self : option T) : result bool := match self with | None => Return false | Some t => Return true end . -(** Trait implementation: [traits::Option::{1}] *) -Definition Option_BoolTraitInst (T : Type) : BoolTrait_t (option T) := {| +(** Trait implementation: [traits::{core::option::Option#1}] *) +Definition traits_BoolTraitcoreoptionOptionTInst (T : Type) : BoolTrait_t + (option T) := {| BoolTrait_t_get_bool := option_get_bool T; |}. (** [traits::test_bool_trait_option]: forward function *) Definition test_bool_trait_option (T : Type) (x : option T) : result bool := b <- option_get_bool T x; - if b then boolTrait_ret_true (Option_BoolTraitInst T) x else Return false + if b + then boolTrait_ret_true (traits_BoolTraitcoreoptionOptionTInst T) x + else Return false . (** [traits::test_bool_trait]: forward function *) @@ -67,15 +70,17 @@ Record ToU64_t (Self : Type) := mkToU64_t { Arguments mkToU64_t { _ }. Arguments ToU64_t_to_u64 { _ }. -(** [traits::u64::{2}::to_u64]: forward function *) +(** [traits::{u64#2}::to_u64]: forward function *) Definition u64_to_u64 (self : u64) : result u64 := Return self. -(** Trait implementation: [traits::u64::{2}] *) -Definition u64_ToU64Inst : ToU64_t u64 := {| ToU64_t_to_u64 := u64_to_u64; |}. +(** Trait implementation: [traits::{u64#2}] *) +Definition traits_ToU64U64Inst : ToU64_t u64 := {| + ToU64_t_to_u64 := u64_to_u64; +|}. -(** [traits::Tuple2::{3}::to_u64]: forward function *) -Definition tuple2_to_u64 +(** [traits::{(A, A)#3}::to_u64]: forward function *) +Definition pair_to_u64 (A : Type) (inst : ToU64_t A) (self : (A * A)) : result u64 := let (t, t0) := self in i <- inst.(ToU64_t_to_u64) t; @@ -83,15 +88,15 @@ Definition tuple2_to_u64 u64_add i i0 . -(** Trait implementation: [traits::Tuple2::{3}] *) -Definition Tuple2_ToU64Inst (A : Type) (inst : ToU64_t A) : ToU64_t (A * A) - := {| - ToU64_t_to_u64 := tuple2_to_u64 A inst; +(** Trait implementation: [traits::{(A, A)#3}] *) +Definition traits_ToU64TupleAAInst (A : Type) (inst : ToU64_t A) : ToU64_t (A * + A) := {| + ToU64_t_to_u64 := pair_to_u64 A inst; |}. (** [traits::f]: forward function *) Definition f (T : Type) (inst : ToU64_t T) (x : (T * T)) : result u64 := - tuple2_to_u64 T inst x + pair_to_u64 T inst x . (** [traits::g]: forward function *) @@ -109,21 +114,21 @@ Record Wrapper_t (T : Type) := mkWrapper_t { wrapper_x : T; }. Arguments mkWrapper_t { _ }. Arguments wrapper_x { _ }. -(** [traits::Wrapper::{4}::to_u64]: forward function *) +(** [traits::{traits::Wrapper#4}::to_u64]: forward function *) Definition wrapper_to_u64 (T : Type) (inst : ToU64_t T) (self : Wrapper_t T) : result u64 := inst.(ToU64_t_to_u64) self.(wrapper_x) . -(** Trait implementation: [traits::Wrapper::{4}] *) -Definition Wrapper_ToU64Inst (T : Type) (inst : ToU64_t T) : ToU64_t (Wrapper_t - T) := {| +(** Trait implementation: [traits::{traits::Wrapper#4}] *) +Definition traits_ToU64traitsWrapperTInst (T : Type) (inst : ToU64_t T) : + ToU64_t (Wrapper_t T) := {| ToU64_t_to_u64 := wrapper_to_u64 T inst; |}. (** [traits::h1]: forward function *) Definition h1 (x : Wrapper_t u64) : result u64 := - wrapper_to_u64 u64 u64_ToU64Inst x + wrapper_to_u64 u64 traits_ToU64U64Inst x . (** [traits::h2]: forward function *) @@ -139,12 +144,12 @@ Record ToType_t (Self T : Type) := mkToType_t { Arguments mkToType_t { _ _ }. Arguments ToType_t_to_type { _ _ }. -(** [traits::u64::{5}::to_type]: forward function *) +(** [traits::{u64#5}::to_type]: forward function *) Definition u64_to_type (self : u64) : result bool := Return (self s> 0%u64). -(** Trait implementation: [traits::u64::{5}] *) -Definition u64_ToTypeInst : ToType_t u64 bool := {| +(** Trait implementation: [traits::{u64#5}] *) +Definition traits_ToTypeU64BoolInst : ToType_t u64 bool := {| ToType_t_to_type := u64_to_type; |}. @@ -189,14 +194,14 @@ Record TestType_t (T : Type) := mkTestType_t { testType_0 : T; }. Arguments mkTestType_t { _ }. Arguments testType_0 { _ }. -(** [traits::TestType::{6}::test::TestType1] *) +(** [traits::{traits::TestType#6}::test::TestType1] *) Record TestType_test_TestType1_t := mkTestType_test_TestType1_t { testType_test_TestType1_0 : u64; } . -(** Trait declaration: [traits::TestType::{6}::test::TestTrait] *) +(** Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] *) Record TestType_test_TestTrait_t (Self : Type) := mkTestType_test_TestTrait_t { TestType_test_TestTrait_t_test : Self -> result bool; }. @@ -204,19 +209,19 @@ Record TestType_test_TestTrait_t (Self : Type) := mkTestType_test_TestTrait_t { Arguments mkTestType_test_TestTrait_t { _ }. Arguments TestType_test_TestTrait_t_test { _ }. -(** [traits::TestType::{6}::test::TestType1::{0}::test]: forward function *) +(** [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function *) Definition testType_test_TestType1_test (self : TestType_test_TestType1_t) : result bool := Return (self.(testType_test_TestType1_0) s> 1%u64) . -(** Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] *) -Definition TestType_test_TestType1_TestType_test_TestTraitInst : - TestType_test_TestTrait_t TestType_test_TestType1_t := {| +(** Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] *) +Definition traits_TestType_test_TestTraittraitstraitsTestTypeTtestTestType1Inst + : TestType_test_TestTrait_t TestType_test_TestType1_t := {| TestType_test_TestTrait_t_test := testType_test_TestType1_test; |}. -(** [traits::TestType::{6}::test]: forward function *) +(** [traits::{traits::TestType#6}::test]: forward function *) Definition testType_test (T : Type) (inst : ToU64_t T) (self : TestType_t T) (x : T) : result bool := x0 <- inst.(ToU64_t_to_u64) x; @@ -228,15 +233,15 @@ Definition testType_test (** [traits::BoolWrapper] *) Record BoolWrapper_t := mkBoolWrapper_t { boolWrapper_0 : bool; }. -(** [traits::BoolWrapper::{7}::to_type]: forward function *) +(** [traits::{traits::BoolWrapper#7}::to_type]: forward function *) Definition boolWrapper_to_type (T : Type) (inst : ToType_t bool T) (self : BoolWrapper_t) : result T := inst.(ToType_t_to_type) self.(boolWrapper_0) . -(** Trait implementation: [traits::BoolWrapper::{7}] *) -Definition BoolWrapper_ToTypeInst (T : Type) (inst : ToType_t bool T) : - ToType_t BoolWrapper_t T := {| +(** Trait implementation: [traits::{traits::BoolWrapper#7}] *) +Definition traits_ToTypetraitsBoolWrapperTInst (T : Type) (inst : ToType_t bool + T) : ToType_t BoolWrapper_t T := {| ToType_t_to_type := boolWrapper_to_type T inst; |}. @@ -263,22 +268,22 @@ Arguments WithConstTy_tWithConstTy_t_W { _ _ }. Arguments WithConstTy_tWithConstTy_t_W_clause_0 { _ _ }. Arguments WithConstTy_t_f { _ _ }. -(** [traits::Bool::{8}::LEN1] *) +(** [traits::{bool#8}::LEN1] *) Definition bool_len1_body : result usize := Return 12%usize. Definition bool_len1_c : usize := bool_len1_body%global. -(** [traits::Bool::{8}::f]: merged forward/backward function +(** [traits::{bool#8}::f]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition bool_f (i : u64) (a : array u8 32%usize) : result u64 := Return i. -(** Trait implementation: [traits::Bool::{8}] *) -Definition Bool_WithConstTyInst : WithConstTy_t bool 32%usize := {| +(** Trait implementation: [traits::{bool#8}] *) +Definition traits_WithConstTyBool32Inst : WithConstTy_t bool 32%usize := {| WithConstTy_tWithConstTy_t_LEN1 := bool_len1_c; WithConstTy_tWithConstTy_t_LEN2 := with_const_ty_len2_c; WithConstTy_tWithConstTy_t_V := u8; WithConstTy_tWithConstTy_t_W := u64; - WithConstTy_tWithConstTy_t_W_clause_0 := u64_ToU64Inst; + WithConstTy_tWithConstTy_t_W_clause_0 := traits_ToU64U64Inst; WithConstTy_t_f := bool_f; |}. @@ -377,12 +382,13 @@ Record ChildTrait1_t (Self : Type) := mkChildTrait1_t { Arguments mkChildTrait1_t { _ }. Arguments ChildTrait1_tChildTrait1_t_parent_clause_0 { _ }. -(** Trait implementation: [traits::usize::{9}] *) -Definition usize_ParentTrait1Inst : ParentTrait1_t usize := mkParentTrait1_t. +(** Trait implementation: [traits::{usize#9}] *) +Definition traits_ParentTrait1UsizeInst : ParentTrait1_t usize + := mkParentTrait1_t. -(** Trait implementation: [traits::usize::{10}] *) -Definition usize_ChildTrait1Inst : ChildTrait1_t usize := {| - ChildTrait1_tChildTrait1_t_parent_clause_0 := usize_ParentTrait1Inst; +(** Trait implementation: [traits::{usize#10}] *) +Definition traits_ChildTrait1UsizeInst : ChildTrait1_t usize := {| + ChildTrait1_tChildTrait1_t_parent_clause_0 := traits_ParentTrait1UsizeInst; |}. (** Trait declaration: [traits::Iterator] *) @@ -456,31 +462,27 @@ Arguments mkChildTrait2_t { _ }. Arguments ChildTrait2_tChildTrait2_t_parent_clause_0 { _ }. Arguments ChildTrait2_t_convert { _ }. -(** Trait implementation: [traits::u32::{11}] *) -Definition u32_WithTargetInst : WithTarget_t u32 := {| +(** Trait implementation: [traits::{u32#11}] *) +Definition traits_WithTargetU32Inst : WithTarget_t u32 := {| WithTarget_tWithTarget_t_Target := u32; |}. -(** Trait implementation: [traits::u32::{12}] *) -Definition u32_ParentTrait2Inst : ParentTrait2_t u32 := {| +(** Trait implementation: [traits::{u32#12}] *) +Definition traits_ParentTrait2U32Inst : ParentTrait2_t u32 := {| ParentTrait2_tParentTrait2_t_U := u32; - ParentTrait2_tParentTrait2_t_U_clause_0 := u32_WithTargetInst; + ParentTrait2_tParentTrait2_t_U_clause_0 := traits_WithTargetU32Inst; |}. -(** [traits::u32::{13}::convert]: forward function *) +(** [traits::{u32#13}::convert]: forward function *) Definition u32_convert (x : u32) : result u32 := Return x. -(** Trait implementation: [traits::u32::{13}] *) -Definition u32_ChildTrait2Inst : ChildTrait2_t u32 := {| - ChildTrait2_tChildTrait2_t_parent_clause_0 := u32_ParentTrait2Inst; +(** Trait implementation: [traits::{u32#13}] *) +Definition traits_ChildTrait2U32Inst : ChildTrait2_t u32 := {| + ChildTrait2_tChildTrait2_t_parent_clause_0 := traits_ParentTrait2U32Inst; ChildTrait2_t_convert := u32_convert; |}. -(** [traits::incr_u32]: forward function *) -Definition incr_u32 (x : u32) : result u32 := - u32_add x 1%u32. - (** Trait declaration: [traits::CFnOnce] *) Record CFnOnce_t (Self Args : Type) := mkCFnOnce_t { CFnOnce_tCFnOnce_t_Output : Type; @@ -517,4 +519,8 @@ Arguments mkCFn_t { _ _ }. Arguments CFn_tCFn_t_parent_clause_0 { _ _ }. Arguments CFn_t_call_mut { _ _ }. +(** [traits::incr_u32]: forward function *) +Definition incr_u32 (x : u32) : result u32 := + u32_add x 1%u32. + End Traits . diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 318efa2b..7edb27c1 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -8,12 +8,12 @@ open Primitives (** Trait declaration: [traits::BoolTrait] *) noeq type boolTrait_t (self : Type0) = { get_bool : self -> result bool; } -(** [traits::Bool::{0}::get_bool]: forward function *) +(** [traits::{bool}::get_bool]: forward function *) let bool_get_bool (self : bool) : result bool = Return self -(** Trait implementation: [traits::Bool::{0}] *) -let bool_BoolTraitInst : boolTrait_t bool = { get_bool = bool_get_bool; } +(** Trait implementation: [traits::{bool}] *) +let traits_BoolTraitBoolInst : boolTrait_t bool = { get_bool = bool_get_bool; } (** [traits::BoolTrait::ret_true]: forward function *) let boolTrait_ret_true @@ -25,21 +25,24 @@ let boolTrait_ret_true (** [traits::test_bool_trait_bool]: forward function *) let test_bool_trait_bool (x : bool) : result bool = let* b = bool_get_bool x in - if b then boolTrait_ret_true bool_BoolTraitInst x else Return false + if b then boolTrait_ret_true traits_BoolTraitBoolInst x else Return false -(** [traits::Option::{1}::get_bool]: forward function *) +(** [traits::{core::option::Option#1}::get_bool]: forward function *) let option_get_bool (t : Type0) (self : option t) : result bool = begin match self with | None -> Return false | Some x -> Return true end -(** Trait implementation: [traits::Option::{1}] *) -let option_BoolTraitInst (t : Type0) : boolTrait_t (option t) = { +(** Trait implementation: [traits::{core::option::Option#1}] *) +let traits_BoolTraitcoreoptionOptionTInst (t : Type0) : boolTrait_t (option t) + = { get_bool = option_get_bool t; } (** [traits::test_bool_trait_option]: forward function *) let test_bool_trait_option (t : Type0) (x : option t) : result bool = let* b = option_get_bool t x in - if b then boolTrait_ret_true (option_BoolTraitInst t) x else Return false + if b + then boolTrait_ret_true (traits_BoolTraitcoreoptionOptionTInst t) x + else Return false (** [traits::test_bool_trait]: forward function *) let test_bool_trait (t : Type0) (inst : boolTrait_t t) (x : t) : result bool = @@ -48,29 +51,29 @@ let test_bool_trait (t : Type0) (inst : boolTrait_t t) (x : t) : result bool = (** Trait declaration: [traits::ToU64] *) noeq type toU64_t (self : Type0) = { to_u64 : self -> result u64; } -(** [traits::u64::{2}::to_u64]: forward function *) +(** [traits::{u64#2}::to_u64]: forward function *) let u64_to_u64 (self : u64) : result u64 = Return self -(** Trait implementation: [traits::u64::{2}] *) -let u64_ToU64Inst : toU64_t u64 = { to_u64 = u64_to_u64; } +(** Trait implementation: [traits::{u64#2}] *) +let traits_ToU64U64Inst : toU64_t u64 = { to_u64 = u64_to_u64; } -(** [traits::Tuple2::{3}::to_u64]: forward function *) -let tuple2_to_u64 - (a : Type0) (inst : toU64_t a) (self : (a & a)) : result u64 = +(** [traits::{(A, A)#3}::to_u64]: forward function *) +let pair_to_u64 (a : Type0) (inst : toU64_t a) (self : (a & a)) : result u64 = let (x, x0) = self in let* i = inst.to_u64 x in let* i0 = inst.to_u64 x0 in u64_add i i0 -(** Trait implementation: [traits::Tuple2::{3}] *) -let tuple2_ToU64Inst (a : Type0) (inst : toU64_t a) : toU64_t (a & a) = { - to_u64 = tuple2_to_u64 a inst; +(** Trait implementation: [traits::{(A, A)#3}] *) +let traits_ToU64TupleAAInst (a : Type0) (inst : toU64_t a) : toU64_t (a & a) + = { + to_u64 = pair_to_u64 a inst; } (** [traits::f]: forward function *) let f (t : Type0) (inst : toU64_t t) (x : (t & t)) : result u64 = - tuple2_to_u64 t inst x + pair_to_u64 t inst x (** [traits::g]: forward function *) let g (t : Type0) (inst : toU64_t (t & t)) (x : (t & t)) : result u64 = @@ -83,20 +86,20 @@ let h0 (x : u64) : result u64 = (** [traits::Wrapper] *) type wrapper_t (t : Type0) = { x : t; } -(** [traits::Wrapper::{4}::to_u64]: forward function *) +(** [traits::{traits::Wrapper#4}::to_u64]: forward function *) let wrapper_to_u64 (t : Type0) (inst : toU64_t t) (self : wrapper_t t) : result u64 = inst.to_u64 self.x -(** Trait implementation: [traits::Wrapper::{4}] *) -let wrapper_ToU64Inst (t : Type0) (inst : toU64_t t) : toU64_t (wrapper_t t) - = { +(** Trait implementation: [traits::{traits::Wrapper#4}] *) +let traits_ToU64traitsWrapperTInst (t : Type0) (inst : toU64_t t) : toU64_t + (wrapper_t t) = { to_u64 = wrapper_to_u64 t inst; } (** [traits::h1]: forward function *) let h1 (x : wrapper_t u64) : result u64 = - wrapper_to_u64 u64 u64_ToU64Inst x + wrapper_to_u64 u64 traits_ToU64U64Inst x (** [traits::h2]: forward function *) let h2 (t : Type0) (inst : toU64_t t) (x : wrapper_t t) : result u64 = @@ -105,12 +108,12 @@ let h2 (t : Type0) (inst : toU64_t t) (x : wrapper_t t) : result u64 = (** Trait declaration: [traits::ToType] *) noeq type toType_t (self t : Type0) = { to_type : self -> result t; } -(** [traits::u64::{5}::to_type]: forward function *) +(** [traits::{u64#5}::to_type]: forward function *) let u64_to_type (self : u64) : result bool = Return (self > 0) -(** Trait implementation: [traits::u64::{5}] *) -let u64_ToTypeInst : toType_t u64 bool = { to_type = u64_to_type; } +(** Trait implementation: [traits::{u64#5}] *) +let traits_ToTypeU64BoolInst : toType_t u64 bool = { to_type = u64_to_type; } (** Trait declaration: [traits::OfType] *) noeq type ofType_t (self : Type0) = { @@ -141,26 +144,26 @@ let h4 (** [traits::TestType] *) type testType_t (t : Type0) = { _0 : t; } -(** [traits::TestType::{6}::test::TestType1] *) +(** [traits::{traits::TestType#6}::test::TestType1] *) type testType_test_TestType1_t = { _0 : u64; } -(** Trait declaration: [traits::TestType::{6}::test::TestTrait] *) +(** Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] *) noeq type testType_test_TestTrait_t (self : Type0) = { test : self -> result bool; } -(** [traits::TestType::{6}::test::TestType1::{0}::test]: forward function *) +(** [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function *) let testType_test_TestType1_test (self : testType_test_TestType1_t) : result bool = Return (self._0 > 1) -(** Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] *) -let testType_test_TestType1_TestType_test_TestTraitInst : +(** Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] *) +let traits_TestType_test_TestTraittraitstraitsTestTypeTtestTestType1Inst : testType_test_TestTrait_t testType_test_TestType1_t = { test = testType_test_TestType1_test; } -(** [traits::TestType::{6}::test]: forward function *) +(** [traits::{traits::TestType#6}::test]: forward function *) let testType_test (t : Type0) (inst : toU64_t t) (self : testType_t t) (x : t) : result bool = let* x0 = inst.to_u64 x in @@ -169,14 +172,14 @@ let testType_test (** [traits::BoolWrapper] *) type boolWrapper_t = { _0 : bool; } -(** [traits::BoolWrapper::{7}::to_type]: forward function *) +(** [traits::{traits::BoolWrapper#7}::to_type]: forward function *) let boolWrapper_to_type (t : Type0) (inst : toType_t bool t) (self : boolWrapper_t) : result t = inst.to_type self._0 -(** Trait implementation: [traits::BoolWrapper::{7}] *) -let boolWrapper_ToTypeInst (t : Type0) (inst : toType_t bool t) : toType_t - boolWrapper_t t = { +(** Trait implementation: [traits::{traits::BoolWrapper#7}] *) +let traits_ToTypetraitsBoolWrapperTInst (t : Type0) (inst : toType_t bool t) : + toType_t boolWrapper_t t = { to_type = boolWrapper_to_type t inst; } @@ -194,22 +197,22 @@ noeq type withConstTy_t (self : Type0) (len : usize) = { f : tW -> array u8 len -> result tW; } -(** [traits::Bool::{8}::LEN1] *) +(** [traits::{bool#8}::LEN1] *) let bool_len1_body : result usize = Return 12 let bool_len1_c : usize = eval_global bool_len1_body -(** [traits::Bool::{8}::f]: merged forward/backward function +(** [traits::{bool#8}::f]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let bool_f (i : u64) (a : array u8 32) : result u64 = Return i -(** Trait implementation: [traits::Bool::{8}] *) -let bool_WithConstTyInst : withConstTy_t bool 32 = { +(** Trait implementation: [traits::{bool#8}] *) +let traits_WithConstTyBool32Inst : withConstTy_t bool 32 = { cLEN1 = bool_len1_c; cLEN2 = with_const_ty_len2_c; tV = u8; tW = u64; - tW_clause_0 = u64_ToU64Inst; + tW_clause_0 = traits_ToU64U64Inst; f = bool_f; } @@ -284,12 +287,12 @@ noeq type childTrait1_t (self : Type0) = { parent_clause_0 : parentTrait1_t self; } -(** Trait implementation: [traits::usize::{9}] *) -let usize_ParentTrait1Inst : parentTrait1_t usize = () +(** Trait implementation: [traits::{usize#9}] *) +let traits_ParentTrait1UsizeInst : parentTrait1_t usize = () -(** Trait implementation: [traits::usize::{10}] *) -let usize_ChildTrait1Inst : childTrait1_t usize = { - parent_clause_0 = usize_ParentTrait1Inst; +(** Trait implementation: [traits::{usize#10}] *) +let traits_ChildTrait1UsizeInst : childTrait1_t usize = { + parent_clause_0 = traits_ParentTrait1UsizeInst; } (** Trait declaration: [traits::Iterator] *) @@ -327,29 +330,25 @@ noeq type childTrait2_t (self : Type0) = { convert : parent_clause_0.tU -> result parent_clause_0.tU_clause_0.tTarget; } -(** Trait implementation: [traits::u32::{11}] *) -let u32_WithTargetInst : withTarget_t u32 = { tTarget = u32; } +(** Trait implementation: [traits::{u32#11}] *) +let traits_WithTargetU32Inst : withTarget_t u32 = { tTarget = u32; } -(** Trait implementation: [traits::u32::{12}] *) -let u32_ParentTrait2Inst : parentTrait2_t u32 = { +(** Trait implementation: [traits::{u32#12}] *) +let traits_ParentTrait2U32Inst : parentTrait2_t u32 = { tU = u32; - tU_clause_0 = u32_WithTargetInst; + tU_clause_0 = traits_WithTargetU32Inst; } -(** [traits::u32::{13}::convert]: forward function *) +(** [traits::{u32#13}::convert]: forward function *) let u32_convert (x : u32) : result u32 = Return x -(** Trait implementation: [traits::u32::{13}] *) -let u32_ChildTrait2Inst : childTrait2_t u32 = { - parent_clause_0 = u32_ParentTrait2Inst; +(** Trait implementation: [traits::{u32#13}] *) +let traits_ChildTrait2U32Inst : childTrait2_t u32 = { + parent_clause_0 = traits_ParentTrait2U32Inst; convert = u32_convert; } -(** [traits::incr_u32]: forward function *) -let incr_u32 (x : u32) : result u32 = - u32_add x 1 - (** Trait declaration: [traits::CFnOnce] *) noeq type cFnOnce_t (self args : Type0) = { tOutput : Type0; @@ -369,3 +368,7 @@ noeq type cFn_t (self args : Type0) = { call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; } +(** [traits::incr_u32]: forward function *) +let incr_u32 (x : u32) : result u32 = + u32_add x 1 + diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index 12e7eafa..51a05581 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -9,12 +9,12 @@ namespace traits structure BoolTrait (Self : Type) where get_bool : Self → Result Bool -/- [traits::Bool::{0}::get_bool]: forward function -/ +/- [traits::{bool}::get_bool]: forward function -/ def Bool.get_bool (self : Bool) : Result Bool := Result.ret self -/- Trait implementation: [traits::Bool::{0}] -/ -def Bool.BoolTraitInst : BoolTrait Bool := { +/- Trait implementation: [traits::{bool}] -/ +def traits.BoolTraitBoolInst : BoolTrait Bool := { get_bool := Bool.get_bool } @@ -28,17 +28,18 @@ def test_bool_trait_bool (x : Bool) : Result Bool := do let b ← Bool.get_bool x if b - then BoolTrait.ret_true Bool.BoolTraitInst x + then BoolTrait.ret_true traits.BoolTraitBoolInst x else Result.ret false -/- [traits::Option::{1}::get_bool]: forward function -/ +/- [traits::{core::option::Option#1}::get_bool]: forward function -/ def Option.get_bool (T : Type) (self : Option T) : Result Bool := match self with | none => Result.ret false | some t => Result.ret true -/- Trait implementation: [traits::Option::{1}] -/ -def Option.BoolTraitInst (T : Type) : BoolTrait (Option T) := { +/- Trait implementation: [traits::{core::option::Option#1}] -/ +def traits.BoolTraitcoreoptionOptionTInst (T : Type) : BoolTrait (Option T) + := { get_bool := Option.get_bool T } @@ -47,7 +48,7 @@ def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := do let b ← Option.get_bool T x if b - then BoolTrait.ret_true (Option.BoolTraitInst T) x + then BoolTrait.ret_true (traits.BoolTraitcoreoptionOptionTInst T) x else Result.ret false /- [traits::test_bool_trait]: forward function -/ @@ -58,31 +59,31 @@ def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := structure ToU64 (Self : Type) where to_u64 : Self → Result U64 -/- [traits::u64::{2}::to_u64]: forward function -/ -def u64.to_u64 (self : U64) : Result U64 := +/- [traits::{u64#2}::to_u64]: forward function -/ +def U64.to_u64 (self : U64) : Result U64 := Result.ret self -/- Trait implementation: [traits::u64::{2}] -/ -def u64.ToU64Inst : ToU64 U64 := { - to_u64 := u64.to_u64 +/- Trait implementation: [traits::{u64#2}] -/ +def traits.ToU64U64Inst : ToU64 U64 := { + to_u64 := U64.to_u64 } -/- [traits::Tuple2::{3}::to_u64]: forward function -/ -def Tuple2.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := +/- [traits::{(A, A)#3}::to_u64]: forward function -/ +def Pair.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := do let (t, t0) := self let i ← inst.to_u64 t let i0 ← inst.to_u64 t0 i + i0 -/- Trait implementation: [traits::Tuple2::{3}] -/ -def Tuple2.ToU64Inst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { - to_u64 := Tuple2.to_u64 A inst +/- Trait implementation: [traits::{(A, A)#3}] -/ +def traits.ToU64TupleAAInst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { + to_u64 := Pair.to_u64 A inst } /- [traits::f]: forward function -/ def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := - Tuple2.to_u64 T inst x + Pair.to_u64 T inst x /- [traits::g]: forward function -/ def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := @@ -90,25 +91,26 @@ def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := /- [traits::h0]: forward function -/ def h0 (x : U64) : Result U64 := - u64.to_u64 x + U64.to_u64 x /- [traits::Wrapper] -/ structure Wrapper (T : Type) where x : T -/- [traits::Wrapper::{4}::to_u64]: forward function -/ +/- [traits::{traits::Wrapper#4}::to_u64]: forward function -/ def Wrapper.to_u64 (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := inst.to_u64 self.x -/- Trait implementation: [traits::Wrapper::{4}] -/ -def Wrapper.ToU64Inst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper T) := { +/- Trait implementation: [traits::{traits::Wrapper#4}] -/ +def traits.ToU64traitsWrapperTInst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper + T) := { to_u64 := Wrapper.to_u64 T inst } /- [traits::h1]: forward function -/ def h1 (x : Wrapper U64) : Result U64 := - Wrapper.to_u64 U64 u64.ToU64Inst x + Wrapper.to_u64 U64 traits.ToU64U64Inst x /- [traits::h2]: forward function -/ def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := @@ -118,13 +120,13 @@ def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := structure ToType (Self T : Type) where to_type : Self → Result T -/- [traits::u64::{5}::to_type]: forward function -/ -def u64.to_type (self : U64) : Result Bool := +/- [traits::{u64#5}::to_type]: forward function -/ +def U64.to_type (self : U64) : Result Bool := Result.ret (self > 0#u64) -/- Trait implementation: [traits::u64::{5}] -/ -def u64.ToTypeInst : ToType U64 Bool := { - to_type := u64.to_type +/- Trait implementation: [traits::{u64#5}] -/ +def traits.ToTypeU64BoolInst : ToType U64 Bool := { + to_type := U64.to_type } /- Trait declaration: [traits::OfType] -/ @@ -154,26 +156,26 @@ def h4 structure TestType (T : Type) where _0 : T -/- [traits::TestType::{6}::test::TestType1] -/ +/- [traits::{traits::TestType#6}::test::TestType1] -/ structure TestType.test.TestType1 where _0 : U64 -/- Trait declaration: [traits::TestType::{6}::test::TestTrait] -/ +/- Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] -/ structure TestType.test.TestTrait (Self : Type) where test : Self → Result Bool -/- [traits::TestType::{6}::test::TestType1::{0}::test]: forward function -/ +/- [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function -/ def TestType.test.TestType1.test (self : TestType.test.TestType1) : Result Bool := Result.ret (self._0 > 1#u64) -/- Trait implementation: [traits::TestType::{6}::test::TestType1::{0}] -/ -def TestType.test.TestType1.TestTypetestTestTraitInst : TestType.test.TestTrait - TestType.test.TestType1 := { +/- Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] -/ +def traits.TestType.test.TestTraittraitstraitsTestTypeTtestTestType1Inst : + TestType.test.TestTrait TestType.test.TestType1 := { test := TestType.test.TestType1.test } -/- [traits::TestType::{6}::test]: forward function -/ +/- [traits::{traits::TestType#6}::test]: forward function -/ def TestType.test (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := do @@ -186,14 +188,14 @@ def TestType.test structure BoolWrapper where _0 : Bool -/- [traits::BoolWrapper::{7}::to_type]: forward function -/ +/- [traits::{traits::BoolWrapper#7}::to_type]: forward function -/ def BoolWrapper.to_type (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := inst.to_type self._0 -/- Trait implementation: [traits::BoolWrapper::{7}] -/ -def BoolWrapper.ToTypeInst (T : Type) (inst : ToType Bool T) : ToType - BoolWrapper T := { +/- Trait implementation: [traits::{traits::BoolWrapper#7}] -/ +def traits.ToTypetraitsBoolWrapperTInst (T : Type) (inst : ToType Bool T) : + ToType BoolWrapper T := { to_type := BoolWrapper.to_type T inst } @@ -211,22 +213,22 @@ structure WithConstTy (Self : Type) (LEN : Usize) where W_clause_0 : ToU64 W f : W → Array U8 LEN → Result W -/- [traits::Bool::{8}::LEN1] -/ +/- [traits::{bool#8}::LEN1] -/ def bool_len1_body : Result Usize := Result.ret 12#usize def bool_len1_c : Usize := eval_global bool_len1_body (by simp) -/- [traits::Bool::{8}::f]: merged forward/backward function +/- [traits::{bool#8}::f]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def Bool.f (i : U64) (a : Array U8 32#usize) : Result U64 := Result.ret i -/- Trait implementation: [traits::Bool::{8}] -/ -def Bool.WithConstTyInst : WithConstTy Bool 32#usize := { +/- Trait implementation: [traits::{bool#8}] -/ +def traits.WithConstTyBool32Inst : WithConstTy Bool 32#usize := { LEN1 := bool_len1_c LEN2 := with_const_ty_len2_c V := U8 W := U64 - W_clause_0 := u64.ToU64Inst + W_clause_0 := traits.ToU64U64Inst f := Bool.f } @@ -297,13 +299,13 @@ def order1 structure ChildTrait1 (Self : Type) where parent_clause_0 : ParentTrait1 Self -/- Trait implementation: [traits::usize::{9}] -/ -def usize.ParentTrait1Inst : ParentTrait1 Usize := { +/- Trait implementation: [traits::{usize#9}] -/ +def traits.ParentTrait1UsizeInst : ParentTrait1 Usize := { } -/- Trait implementation: [traits::usize::{10}] -/ -def usize.ChildTrait1Inst : ChildTrait1 Usize := { - parent_clause_0 := usize.ParentTrait1Inst +/- Trait implementation: [traits::{usize#10}] -/ +def traits.ChildTrait1UsizeInst : ChildTrait1 Usize := { + parent_clause_0 := traits.ParentTrait1UsizeInst } /- Trait declaration: [traits::Iterator] -/ @@ -339,31 +341,27 @@ structure ChildTrait2 (Self : Type) where parent_clause_0 : ParentTrait2 Self convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target -/- Trait implementation: [traits::u32::{11}] -/ -def u32.WithTargetInst : WithTarget U32 := { +/- Trait implementation: [traits::{u32#11}] -/ +def traits.WithTargetU32Inst : WithTarget U32 := { Target := U32 } -/- Trait implementation: [traits::u32::{12}] -/ -def u32.ParentTrait2Inst : ParentTrait2 U32 := { +/- Trait implementation: [traits::{u32#12}] -/ +def traits.ParentTrait2U32Inst : ParentTrait2 U32 := { U := U32 - U_clause_0 := u32.WithTargetInst + U_clause_0 := traits.WithTargetU32Inst } -/- [traits::u32::{13}::convert]: forward function -/ -def u32.convert (x : U32) : Result U32 := +/- [traits::{u32#13}::convert]: forward function -/ +def U32.convert (x : U32) : Result U32 := Result.ret x -/- Trait implementation: [traits::u32::{13}] -/ -def u32.ChildTrait2Inst : ChildTrait2 U32 := { - parent_clause_0 := u32.ParentTrait2Inst - convert := u32.convert +/- Trait implementation: [traits::{u32#13}] -/ +def traits.ChildTrait2U32Inst : ChildTrait2 U32 := { + parent_clause_0 := traits.ParentTrait2U32Inst + convert := U32.convert } -/- [traits::incr_u32]: forward function -/ -def incr_u32 (x : U32) : Result U32 := - x + 1#u32 - /- Trait declaration: [traits::CFnOnce] -/ structure CFnOnce (Self Args : Type) where Output : Type @@ -380,4 +378,8 @@ structure CFn (Self Args : Type) where parent_clause_0 : CFnMut Self Args call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output +/- [traits::incr_u32]: forward function -/ +def incr_u32 (x : U32) : Result U32 := + x + 1#u32 + end traits -- cgit v1.2.3 From 753f7e72f87f5282aee60ad5ada47efeb42625e9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 11:50:44 +0100 Subject: Regenerate the betree files --- tests/coq/betree/BetreeMain_Funs.v | 114 +++++++++--------- tests/coq/betree/BetreeMain_Opaque.v | 2 +- tests/fstar/betree/BetreeMain.Clauses.Template.fst | 32 ++--- tests/fstar/betree/BetreeMain.Clauses.fst | 2 +- tests/fstar/betree/BetreeMain.Funs.fst | 118 ++++++++++--------- tests/fstar/betree/BetreeMain.Opaque.fsti | 2 +- .../BetreeMain.Clauses.Template.fst | 32 ++--- .../betree_back_stateful/BetreeMain.Clauses.fst | 2 +- .../fstar/betree_back_stateful/BetreeMain.Funs.fst | 131 +++++++++++---------- .../betree_back_stateful/BetreeMain.Opaque.fsti | 2 +- tests/lean/BetreeMain/Funs.lean | 114 +++++++++--------- tests/lean/BetreeMain/FunsExternal_Template.lean | 2 +- 12 files changed, 279 insertions(+), 274 deletions(-) diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index 261e8270..d7428744 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -56,19 +56,19 @@ Definition betree_fresh_node_id_back (counter : u64) : result u64 := u64_add counter 1%u64 . -(** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function *) Definition betree_NodeIdCounter_new : result betree_NodeIdCounter_t := Return {| betree_NodeIdCounter_next_node_id := 0%u64 |} . -(** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function *) Definition betree_NodeIdCounter_fresh_id (self : betree_NodeIdCounter_t) : result u64 := _ <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; Return self.(betree_NodeIdCounter_next_node_id) . -(** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 *) Definition betree_NodeIdCounter_fresh_id_back (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t := i <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; @@ -95,7 +95,7 @@ Definition betree_upsert_update end . -(** [betree_main::betree::List::{1}::len]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function *) Fixpoint betree_List_len (T : Type) (n : nat) (self : betree_List_t T) : result u64 := match n with @@ -108,7 +108,7 @@ Fixpoint betree_List_len end . -(** [betree_main::betree::List::{1}::split_at]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function *) Fixpoint betree_List_split_at (T : Type) (n : nat) (self : betree_List_t T) (n0 : u64) : result ((betree_List_t T) * (betree_List_t T)) @@ -131,7 +131,7 @@ Fixpoint betree_List_split_at end . -(** [betree_main::betree::List::{1}::push_front]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition betree_List_push_front (T : Type) (self : betree_List_t T) (x : T) : result (betree_List_t T) := @@ -140,7 +140,7 @@ Definition betree_List_push_front Return (Betree_List_Cons x l) . -(** [betree_main::betree::List::{1}::pop_front]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function *) Definition betree_List_pop_front (T : Type) (self : betree_List_t T) : result T := let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in @@ -150,7 +150,7 @@ Definition betree_List_pop_front end . -(** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 *) Definition betree_List_pop_front_back (T : Type) (self : betree_List_t T) : result (betree_List_t T) := let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in @@ -160,7 +160,7 @@ Definition betree_List_pop_front_back end . -(** [betree_main::betree::List::{1}::hd]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function *) Definition betree_List_hd (T : Type) (self : betree_List_t T) : result T := match self with | Betree_List_Cons hd l => Return hd @@ -168,8 +168,8 @@ Definition betree_List_hd (T : Type) (self : betree_List_t T) : result T := end . -(** [betree_main::betree::List::{2}::head_has_key]: forward function *) -Definition betree_List_head_has_key +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function *) +Definition betree_ListTupleU64T_head_has_key (T : Type) (self : betree_List_t (u64 * T)) (key : u64) : result bool := match self with | Betree_List_Cons hd l => let (i, _) := hd in Return (i s= key) @@ -177,8 +177,8 @@ Definition betree_List_head_has_key end . -(** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -Fixpoint betree_List_partition_at_pivot +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function *) +Fixpoint betree_ListTupleU64T_partition_at_pivot (T : Type) (n : nat) (self : betree_List_t (u64 * T)) (pivot : u64) : result ((betree_List_t (u64 * T)) * (betree_List_t (u64 * T))) := @@ -191,7 +191,7 @@ Fixpoint betree_List_partition_at_pivot if i s>= pivot then Return (Betree_List_Nil, Betree_List_Cons (i, t) tl) else ( - p <- betree_List_partition_at_pivot T n0 tl pivot; + p <- betree_ListTupleU64T_partition_at_pivot T n0 tl pivot; let (ls0, ls1) := p in let l := ls0 in Return (Betree_List_Cons (i, t) l, ls1)) @@ -200,7 +200,7 @@ Fixpoint betree_List_partition_at_pivot end . -(** [betree_main::betree::Leaf::{3}::split]: forward function *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function *) Definition betree_Leaf_split (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -233,7 +233,7 @@ Definition betree_Leaf_split Return (st1, mkbetree_Internal_t self.(betree_Leaf_id) pivot n0 n1) . -(** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 *) Definition betree_Leaf_split_back (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -254,7 +254,7 @@ Definition betree_Leaf_split_back betree_NodeIdCounter_fresh_id_back node_id_cnt0 . -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function *) Fixpoint betree_Node_lookup_first_message_for_key (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : result (betree_List_t (u64 * betree_Message_t)) @@ -273,7 +273,7 @@ Fixpoint betree_Node_lookup_first_message_for_key end . -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 *) Fixpoint betree_Node_lookup_first_message_for_key_back (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) (ret : betree_List_t (u64 * betree_Message_t)) : @@ -296,7 +296,7 @@ Fixpoint betree_Node_lookup_first_message_for_key_back end . -(** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function *) Fixpoint betree_Node_apply_upserts (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -305,7 +305,7 @@ Fixpoint betree_Node_apply_upserts match n with | O => Fail_ OutOfFuel | S n0 => - b <- betree_List_head_has_key betree_Message_t msgs key; + b <- betree_ListTupleU64T_head_has_key betree_Message_t msgs key; if b then ( msg <- betree_List_pop_front (u64 * betree_Message_t) msgs; @@ -328,7 +328,7 @@ Fixpoint betree_Node_apply_upserts end . -(** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 *) Fixpoint betree_Node_apply_upserts_back (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -337,7 +337,7 @@ Fixpoint betree_Node_apply_upserts_back match n with | O => Fail_ OutOfFuel | S n0 => - b <- betree_List_head_has_key betree_Message_t msgs key; + b <- betree_ListTupleU64T_head_has_key betree_Message_t msgs key; if b then ( msg <- betree_List_pop_front (u64 * betree_Message_t) msgs; @@ -358,7 +358,7 @@ Fixpoint betree_Node_apply_upserts_back end . -(** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function *) Fixpoint betree_Node_lookup_in_bindings (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : result (option u64) @@ -380,7 +380,7 @@ Fixpoint betree_Node_lookup_in_bindings end . -(** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function *) Fixpoint betree_Internal_lookup_in_children (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : result (state * (option u64)) @@ -393,7 +393,7 @@ Fixpoint betree_Internal_lookup_in_children else betree_Node_lookup n0 self.(betree_Internal_right) key st end -(** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 *) with betree_Internal_lookup_in_children_back (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : result betree_Internal_t @@ -412,7 +412,7 @@ with betree_Internal_lookup_in_children_back self.(betree_Internal_pivot) self.(betree_Internal_left) n1)) end -(** [betree_main::betree::Node::{5}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function *) with betree_Node_lookup (n : nat) (self : betree_Node_t) (key : u64) (st : state) : result (state * (option u64)) @@ -483,7 +483,7 @@ with betree_Node_lookup end end -(** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 *) with betree_Node_lookup_back (n : nat) (self : betree_Node_t) (key : u64) (st : state) : result betree_Node_t @@ -552,7 +552,7 @@ with betree_Node_lookup_back end . -(** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint betree_Node_filter_messages_for_key (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : @@ -576,7 +576,7 @@ Fixpoint betree_Node_filter_messages_for_key end . -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function *) Fixpoint betree_Node_lookup_first_message_after_key (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : result (betree_List_t (u64 * betree_Message_t)) @@ -595,7 +595,7 @@ Fixpoint betree_Node_lookup_first_message_after_key end . -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 *) Fixpoint betree_Node_lookup_first_message_after_key_back (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) (ret : betree_List_t (u64 * betree_Message_t)) : @@ -618,7 +618,7 @@ Fixpoint betree_Node_lookup_first_message_after_key_back end . -(** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition betree_Node_apply_to_internal (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (key : u64) @@ -626,7 +626,7 @@ Definition betree_Node_apply_to_internal result (betree_List_t (u64 * betree_Message_t)) := msgs0 <- betree_Node_lookup_first_message_for_key n key msgs; - b <- betree_List_head_has_key betree_Message_t msgs0 key; + b <- betree_ListTupleU64T_head_has_key betree_Message_t msgs0 key; if b then match new_msg with @@ -676,7 +676,7 @@ Definition betree_Node_apply_to_internal betree_Node_lookup_first_message_for_key_back n key msgs msgs1) . -(** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint betree_Node_apply_messages_to_internal (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) @@ -696,7 +696,7 @@ Fixpoint betree_Node_apply_messages_to_internal end . -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function *) Fixpoint betree_Node_lookup_mut_in_bindings (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : result (betree_List_t (u64 * u64)) @@ -715,7 +715,7 @@ Fixpoint betree_Node_lookup_mut_in_bindings end . -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 *) Fixpoint betree_Node_lookup_mut_in_bindings_back (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) (ret : betree_List_t (u64 * u64)) : @@ -737,7 +737,7 @@ Fixpoint betree_Node_lookup_mut_in_bindings_back end . -(** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Definition betree_Node_apply_to_leaf (n : nat) (bindings : betree_List_t (u64 * u64)) (key : u64) @@ -745,7 +745,7 @@ Definition betree_Node_apply_to_leaf result (betree_List_t (u64 * u64)) := bindings0 <- betree_Node_lookup_mut_in_bindings n key bindings; - b <- betree_List_head_has_key u64 bindings0 key; + b <- betree_ListTupleU64T_head_has_key u64 bindings0 key; if b then ( hd <- betree_List_pop_front (u64 * u64) bindings0; @@ -778,7 +778,7 @@ Definition betree_Node_apply_to_leaf end . -(** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) Fixpoint betree_Node_apply_messages_to_leaf (n : nat) (bindings : betree_List_t (u64 * u64)) @@ -798,7 +798,7 @@ Fixpoint betree_Node_apply_messages_to_leaf end . -(** [betree_main::betree::Internal::{4}::flush]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function *) Fixpoint betree_Internal_flush (n : nat) (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -809,7 +809,7 @@ Fixpoint betree_Internal_flush | O => Fail_ OutOfFuel | S n0 => p <- - betree_List_partition_at_pivot betree_Message_t n0 content + betree_ListTupleU64T_partition_at_pivot betree_Message_t n0 content self.(betree_Internal_pivot); let (msgs_left, msgs_right) := p in len_left <- betree_List_len (u64 * betree_Message_t) n0 msgs_left; @@ -846,7 +846,7 @@ Fixpoint betree_Internal_flush Return (st0, msgs_left)) end -(** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 *) with betree_Internal_flush_back (n : nat) (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -857,7 +857,7 @@ with betree_Internal_flush_back | O => Fail_ OutOfFuel | S n0 => p <- - betree_List_partition_at_pivot betree_Message_t n0 content + betree_ListTupleU64T_partition_at_pivot betree_Message_t n0 content self.(betree_Internal_pivot); let (msgs_left, msgs_right) := p in len_left <- betree_List_len (u64 * betree_Message_t) n0 msgs_left; @@ -894,7 +894,7 @@ with betree_Internal_flush_back node_id_cnt0)) end -(** [betree_main::betree::Node::{5}::apply_messages]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function *) with betree_Node_apply_messages (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -946,7 +946,7 @@ with betree_Node_apply_messages end end -(** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 *) with betree_Node_apply_messages_back (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -998,7 +998,7 @@ with betree_Node_apply_messages_back end . -(** [betree_main::betree::Node::{5}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function *) Definition betree_Node_apply (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1016,7 +1016,7 @@ Definition betree_Node_apply Return (st0, tt) . -(** [betree_main::betree::Node::{5}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 *) Definition betree_Node_apply_back (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1028,7 +1028,7 @@ Definition betree_Node_apply_back (key, new_msg) l) st . -(** [betree_main::betree::BeTree::{6}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function *) Definition betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : result (state * betree_BeTree_t) @@ -1052,7 +1052,7 @@ Definition betree_BeTree_new |}) . -(** [betree_main::betree::BeTree::{6}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function *) Definition betree_BeTree_apply (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : @@ -1068,7 +1068,7 @@ Definition betree_BeTree_apply Return (st0, tt) . -(** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 *) Definition betree_BeTree_apply_back (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : @@ -1086,7 +1086,7 @@ Definition betree_BeTree_apply_back |} . -(** [betree_main::betree::BeTree::{6}::insert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function *) Definition betree_BeTree_insert (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state * unit) @@ -1097,7 +1097,7 @@ Definition betree_BeTree_insert Return (st0, tt) . -(** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 *) Definition betree_BeTree_insert_back (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result betree_BeTree_t @@ -1105,7 +1105,7 @@ Definition betree_BeTree_insert_back betree_BeTree_apply_back n self key (Betree_Message_Insert value) st . -(** [betree_main::betree::BeTree::{6}::delete]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function *) Definition betree_BeTree_delete (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * unit) @@ -1116,7 +1116,7 @@ Definition betree_BeTree_delete Return (st0, tt) . -(** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 *) Definition betree_BeTree_delete_back (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t @@ -1124,7 +1124,7 @@ Definition betree_BeTree_delete_back betree_BeTree_apply_back n self key Betree_Message_Delete st . -(** [betree_main::betree::BeTree::{6}::upsert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function *) Definition betree_BeTree_upsert (n : nat) (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -1136,7 +1136,7 @@ Definition betree_BeTree_upsert Return (st0, tt) . -(** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 *) Definition betree_BeTree_upsert_back (n : nat) (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -1145,7 +1145,7 @@ Definition betree_BeTree_upsert_back betree_BeTree_apply_back n self key (Betree_Message_Upsert upd) st . -(** [betree_main::betree::BeTree::{6}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function *) Definition betree_BeTree_lookup (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * (option u64)) @@ -1153,7 +1153,7 @@ Definition betree_BeTree_lookup betree_Node_lookup n self.(betree_BeTree_root) key st . -(** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 *) Definition betree_BeTree_lookup_back (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t diff --git a/tests/coq/betree/BetreeMain_Opaque.v b/tests/coq/betree/BetreeMain_Opaque.v index eade90de..bb798e71 100644 --- a/tests/coq/betree/BetreeMain_Opaque.v +++ b/tests/coq/betree/BetreeMain_Opaque.v @@ -32,7 +32,7 @@ Axiom betree_utils_store_leaf_node : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) . -(** [core::option::Option::{0}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function *) Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/fstar/betree/BetreeMain.Clauses.Template.fst b/tests/fstar/betree/BetreeMain.Clauses.Template.fst index 8722f0bf..4d16d8d3 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.Template.fst @@ -6,94 +6,94 @@ open BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::List::{1}::len]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: decreases clause *) unfold let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () -(** [betree_main::betree::List::{1}::split_at]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: decreases clause *) unfold let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () -(** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: decreases clause *) unfold -let betree_List_partition_at_pivot_decreases (t : Type0) +let betree_ListTupleU64T_partition_at_pivot_decreases (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: decreases clause *) unfold let betree_Node_lookup_first_message_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause *) unfold let betree_Node_apply_upserts_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause *) unfold let betree_Node_lookup_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause *) unfold let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: decreases clause *) unfold let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: decreases clause *) unfold let betree_Node_filter_messages_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: decreases clause *) unfold let betree_Node_lookup_first_message_after_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_messages_to_internal]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: decreases clause *) unfold let betree_Node_apply_messages_to_internal_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: decreases clause *) unfold let betree_Node_lookup_mut_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: decreases clause *) unfold let betree_Node_apply_messages_to_leaf_decreases (bindings : betree_List_t (u64 & u64)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Internal::{4}::flush]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: decreases clause *) unfold let betree_Internal_flush_decreases (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: decreases clause *) unfold let betree_Node_apply_messages_decreases (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) diff --git a/tests/fstar/betree/BetreeMain.Clauses.fst b/tests/fstar/betree/BetreeMain.Clauses.fst index cda7b920..21f953d1 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.fst @@ -114,7 +114,7 @@ let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_List_partition_at_pivot_decreases (t : Type0) +let betree_ListTupleU64T_partition_at_pivot_decreases (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : betree_List_t (u64 & t) = self diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index d2bf5c7c..2ccbac60 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -44,16 +44,16 @@ let betree_fresh_node_id (counter : u64) : result u64 = let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 -(** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function *) let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = Return { next_node_id = 0 } -(** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function *) let betree_NodeIdCounter_fresh_id (self : betree_NodeIdCounter_t) : result u64 = let* _ = u64_add self.next_node_id 1 in Return self.next_node_id -(** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 *) let betree_NodeIdCounter_fresh_id_back (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } @@ -77,7 +77,7 @@ let betree_upsert_update end end -(** [betree_main::betree::List::{1}::len]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function *) let rec betree_List_len (t : Type0) (self : betree_List_t t) : Tot (result u64) (decreases (betree_List_len_decreases t self)) @@ -87,7 +87,7 @@ let rec betree_List_len | Betree_List_Nil -> Return 0 end -(** [betree_main::betree::List::{1}::split_at]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function *) let rec betree_List_split_at (t : Type0) (self : betree_List_t t) (n : u64) : Tot (result ((betree_List_t t) & (betree_List_t t))) @@ -106,7 +106,7 @@ let rec betree_List_split_at | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{1}::push_front]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let betree_List_push_front (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = @@ -114,7 +114,7 @@ let betree_List_push_front let l = tl in Return (Betree_List_Cons x l) -(** [betree_main::betree::List::{1}::pop_front]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function *) let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with @@ -122,7 +122,7 @@ let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 *) let betree_List_pop_front_back (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in @@ -131,26 +131,26 @@ let betree_List_pop_front_back | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{1}::hd]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function *) let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with | Betree_List_Cons hd l -> Return hd | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{2}::head_has_key]: forward function *) -let betree_List_head_has_key +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function *) +let betree_ListTupleU64T_head_has_key (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with | Betree_List_Cons hd l -> let (i, _) = hd in Return (i = key) | Betree_List_Nil -> Return false end -(** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -let rec betree_List_partition_at_pivot +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function *) +let rec betree_ListTupleU64T_partition_at_pivot (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) - (decreases (betree_List_partition_at_pivot_decreases t self pivot)) + (decreases (betree_ListTupleU64T_partition_at_pivot_decreases t self pivot)) = begin match self with | Betree_List_Cons hd tl -> @@ -158,14 +158,14 @@ let rec betree_List_partition_at_pivot if i >= pivot then Return (Betree_List_Nil, Betree_List_Cons (i, x) tl) else - let* p = betree_List_partition_at_pivot t tl pivot in + let* p = betree_ListTupleU64T_partition_at_pivot t tl pivot in let (ls0, ls1) = p in let l = ls0 in Return (Betree_List_Cons (i, x) l, ls1) | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end -(** [betree_main::betree::Leaf::{3}::split]: forward function *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function *) let betree_Leaf_split (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -185,7 +185,7 @@ let betree_Leaf_split let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) -(** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 *) let betree_Leaf_split_back (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -202,7 +202,7 @@ let betree_Leaf_split_back let* _ = betree_store_leaf_node id1 content1 st0 in betree_NodeIdCounter_fresh_id_back node_id_cnt0 -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function *) let rec betree_Node_lookup_first_message_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -217,7 +217,7 @@ let rec betree_Node_lookup_first_message_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 *) let rec betree_Node_lookup_first_message_for_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -236,14 +236,14 @@ let rec betree_Node_lookup_first_message_for_key_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function *) let rec betree_Node_apply_upserts (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (state & u64)) (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_List_head_has_key betree_Message_t msgs key in + let* b = betree_ListTupleU64T_head_has_key betree_Message_t msgs key in if b then let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in @@ -263,14 +263,14 @@ let rec betree_Node_apply_upserts Betree_Message_Insert v) in Return (st0, v) -(** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 *) let rec betree_Node_apply_upserts_back (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (betree_List_t (u64 & betree_Message_t))) (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_List_head_has_key betree_Message_t msgs key in + let* b = betree_ListTupleU64T_head_has_key betree_Message_t msgs key in if b then let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in @@ -288,7 +288,7 @@ let rec betree_Node_apply_upserts_back betree_List_push_front (u64 & betree_Message_t) msgs (key, Betree_Message_Insert v) -(** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function *) let rec betree_Node_lookup_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) @@ -303,7 +303,7 @@ let rec betree_Node_lookup_in_bindings | Betree_List_Nil -> Return None end -(** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function *) let rec betree_Internal_lookup_in_children (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -313,7 +313,7 @@ let rec betree_Internal_lookup_in_children then betree_Node_lookup self.left key st else betree_Node_lookup self.right key st -(** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 *) and betree_Internal_lookup_in_children_back (self : betree_Internal_t) (key : u64) (st : state) : Tot (result betree_Internal_t) @@ -327,7 +327,7 @@ and betree_Internal_lookup_in_children_back let* n = betree_Node_lookup_back self.right key st in Return { self with right = n } -(** [betree_main::betree::Node::{5}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function *) and betree_Node_lookup (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -386,7 +386,7 @@ and betree_Node_lookup Return (st0, o) end -(** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 *) and betree_Node_lookup_back (self : betree_Node_t) (key : u64) (st : state) : Tot (result betree_Node_t) @@ -445,7 +445,7 @@ and betree_Node_lookup_back Return (Betree_Node_Leaf node) end -(** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec betree_Node_filter_messages_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : @@ -465,7 +465,7 @@ let rec betree_Node_filter_messages_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function *) let rec betree_Node_lookup_first_message_after_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -480,7 +480,7 @@ let rec betree_Node_lookup_first_message_after_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 *) let rec betree_Node_lookup_first_message_after_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -499,7 +499,7 @@ let rec betree_Node_lookup_first_message_after_key_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let betree_Node_apply_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) @@ -507,7 +507,7 @@ let betree_Node_apply_to_internal result (betree_List_t (u64 & betree_Message_t)) = let* msgs0 = betree_Node_lookup_first_message_for_key key msgs in - let* b = betree_List_head_has_key betree_Message_t msgs0 key in + let* b = betree_ListTupleU64T_head_has_key betree_Message_t msgs0 key in if b then begin match new_msg with @@ -558,7 +558,7 @@ let betree_Node_apply_to_internal betree_List_push_front (u64 & betree_Message_t) msgs0 (key, new_msg) in betree_Node_lookup_first_message_for_key_back key msgs msgs1 -(** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec betree_Node_apply_messages_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) @@ -574,7 +574,7 @@ let rec betree_Node_apply_messages_to_internal | Betree_List_Nil -> Return msgs end -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function *) let rec betree_Node_lookup_mut_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (betree_List_t (u64 & u64))) @@ -589,7 +589,7 @@ let rec betree_Node_lookup_mut_in_bindings | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 *) let rec betree_Node_lookup_mut_in_bindings_back (key : u64) (bindings : betree_List_t (u64 & u64)) (ret : betree_List_t (u64 & u64)) : @@ -607,7 +607,7 @@ let rec betree_Node_lookup_mut_in_bindings_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let betree_Node_apply_to_leaf (bindings : betree_List_t (u64 & u64)) (key : u64) @@ -615,7 +615,7 @@ let betree_Node_apply_to_leaf result (betree_List_t (u64 & u64)) = let* bindings0 = betree_Node_lookup_mut_in_bindings key bindings in - let* b = betree_List_head_has_key u64 bindings0 key in + let* b = betree_ListTupleU64T_head_has_key u64 bindings0 key in if b then let* hd = betree_List_pop_front (u64 & u64) bindings0 in @@ -647,7 +647,7 @@ let betree_Node_apply_to_leaf betree_Node_lookup_mut_in_bindings_back key bindings bindings1 end -(** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec betree_Node_apply_messages_to_leaf (bindings : betree_List_t (u64 & u64)) @@ -663,7 +663,7 @@ let rec betree_Node_apply_messages_to_leaf | Betree_List_Nil -> Return bindings end -(** [betree_main::betree::Internal::{4}::flush]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function *) let rec betree_Internal_flush (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -672,7 +672,8 @@ let rec betree_Internal_flush (decreases ( betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + let* p = + betree_ListTupleU64T_partition_at_pivot betree_Message_t content self.pivot in let (msgs_left, msgs_right) = p in let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in @@ -702,7 +703,7 @@ let rec betree_Internal_flush st in Return (st0, msgs_left) -(** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 *) and betree_Internal_flush_back (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -711,7 +712,8 @@ and betree_Internal_flush_back (decreases ( betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + let* p = + betree_ListTupleU64T_partition_at_pivot betree_Message_t content self.pivot in let (msgs_left, msgs_right) = p in let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in @@ -736,7 +738,7 @@ and betree_Internal_flush_back st in Return ({ self with right = n }, node_id_cnt0) -(** [betree_main::betree::Node::{5}::apply_messages]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function *) and betree_Node_apply_messages (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -776,7 +778,7 @@ and betree_Node_apply_messages Return (st1, ()) end -(** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 *) and betree_Node_apply_messages_back (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -819,7 +821,7 @@ and betree_Node_apply_messages_back Return (Betree_Node_Leaf { node with size = len }, node_id_cnt) end -(** [betree_main::betree::Node::{5}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function *) let betree_Node_apply (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -835,7 +837,7 @@ let betree_Node_apply (key, new_msg) l) st in Return (st0, ()) -(** [betree_main::betree::Node::{5}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 *) let betree_Node_apply_back (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -846,7 +848,7 @@ let betree_Node_apply_back betree_Node_apply_messages_back self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st -(** [betree_main::betree::BeTree::{6}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function *) let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : result (state & betree_BeTree_t) @@ -862,7 +864,7 @@ let betree_BeTree_new root = (Betree_Node_Leaf { id = id; size = 0 }) }) -(** [betree_main::betree::BeTree::{6}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function *) let betree_BeTree_apply (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) @@ -873,7 +875,7 @@ let betree_BeTree_apply betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in Return (st0, ()) -(** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 *) let betree_BeTree_apply_back (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result betree_BeTree_t @@ -882,7 +884,7 @@ let betree_BeTree_apply_back betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in Return { self with node_id_cnt = nic; root = n } -(** [betree_main::betree::BeTree::{6}::insert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function *) let betree_BeTree_insert (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) @@ -893,26 +895,26 @@ let betree_BeTree_insert in Return (st0, ()) -(** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 *) let betree_BeTree_insert_back (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result betree_BeTree_t = betree_BeTree_apply_back self key (Betree_Message_Insert value) st -(** [betree_main::betree::BeTree::{6}::delete]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function *) let betree_BeTree_delete (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in let* _ = betree_BeTree_apply_back self key Betree_Message_Delete st in Return (st0, ()) -(** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 *) let betree_BeTree_delete_back (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = betree_BeTree_apply_back self key Betree_Message_Delete st -(** [betree_main::betree::BeTree::{6}::upsert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function *) let betree_BeTree_upsert (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -923,7 +925,7 @@ let betree_BeTree_upsert let* _ = betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st in Return (st0, ()) -(** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 *) let betree_BeTree_upsert_back (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -931,14 +933,14 @@ let betree_BeTree_upsert_back = betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st -(** [betree_main::betree::BeTree::{6}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function *) let betree_BeTree_lookup (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = betree_Node_lookup self.root key st -(** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 *) let betree_BeTree_lookup_back (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = let* n = betree_Node_lookup_back self.root key st in diff --git a/tests/fstar/betree/BetreeMain.Opaque.fsti b/tests/fstar/betree/BetreeMain.Opaque.fsti index c5d0a814..23d2e60e 100644 --- a/tests/fstar/betree/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree/BetreeMain.Opaque.fsti @@ -24,7 +24,7 @@ val betree_utils_load_leaf_node val betree_utils_store_leaf_node : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) -(** [core::option::Option::{0}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function *) val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst index 8722f0bf..4d16d8d3 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst @@ -6,94 +6,94 @@ open BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::List::{1}::len]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: decreases clause *) unfold let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () -(** [betree_main::betree::List::{1}::split_at]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: decreases clause *) unfold let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () -(** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: decreases clause *) unfold -let betree_List_partition_at_pivot_decreases (t : Type0) +let betree_ListTupleU64T_partition_at_pivot_decreases (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: decreases clause *) unfold let betree_Node_lookup_first_message_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_upserts]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause *) unfold let betree_Node_apply_upserts_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause *) unfold let betree_Node_lookup_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::Internal::{4}::lookup_in_children]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause *) unfold let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: decreases clause *) unfold let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::filter_messages_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: decreases clause *) unfold let betree_Node_filter_messages_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: decreases clause *) unfold let betree_Node_lookup_first_message_after_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_messages_to_internal]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: decreases clause *) unfold let betree_Node_apply_messages_to_internal_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: decreases clause *) unfold let betree_Node_lookup_mut_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: decreases clause *) unfold let betree_Node_apply_messages_to_leaf_decreases (bindings : betree_List_t (u64 & u64)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::Internal::{4}::flush]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: decreases clause *) unfold let betree_Internal_flush_decreases (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () -(** [betree_main::betree::Node::{5}::apply_messages]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: decreases clause *) unfold let betree_Node_apply_messages_decreases (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst index cda7b920..21f953d1 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.fst @@ -114,7 +114,7 @@ let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (** [betree_main::betree::List::{2}::partition_at_pivot]: decreases clause *) unfold -let betree_List_partition_at_pivot_decreases (t : Type0) +let betree_ListTupleU64T_partition_at_pivot_decreases (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : betree_List_t (u64 & t) = self diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index 08c4f615..b46ca0a0 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -44,16 +44,16 @@ let betree_fresh_node_id (counter : u64) : result u64 = let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 -(** [betree_main::betree::NodeIdCounter::{0}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function *) let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = Return { next_node_id = 0 } -(** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function *) let betree_NodeIdCounter_fresh_id (self : betree_NodeIdCounter_t) : result u64 = let* _ = u64_add self.next_node_id 1 in Return self.next_node_id -(** [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 *) let betree_NodeIdCounter_fresh_id_back (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } @@ -77,7 +77,7 @@ let betree_upsert_update end end -(** [betree_main::betree::List::{1}::len]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function *) let rec betree_List_len (t : Type0) (self : betree_List_t t) : Tot (result u64) (decreases (betree_List_len_decreases t self)) @@ -87,7 +87,7 @@ let rec betree_List_len | Betree_List_Nil -> Return 0 end -(** [betree_main::betree::List::{1}::split_at]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function *) let rec betree_List_split_at (t : Type0) (self : betree_List_t t) (n : u64) : Tot (result ((betree_List_t t) & (betree_List_t t))) @@ -106,7 +106,7 @@ let rec betree_List_split_at | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{1}::push_front]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let betree_List_push_front (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = @@ -114,7 +114,7 @@ let betree_List_push_front let l = tl in Return (Betree_List_Cons x l) -(** [betree_main::betree::List::{1}::pop_front]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function *) let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with @@ -122,7 +122,7 @@ let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{1}::pop_front]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 *) let betree_List_pop_front_back (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in @@ -131,26 +131,26 @@ let betree_List_pop_front_back | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{1}::hd]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function *) let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with | Betree_List_Cons hd l -> Return hd | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::List::{2}::head_has_key]: forward function *) -let betree_List_head_has_key +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function *) +let betree_ListTupleU64T_head_has_key (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with | Betree_List_Cons hd l -> let (i, _) = hd in Return (i = key) | Betree_List_Nil -> Return false end -(** [betree_main::betree::List::{2}::partition_at_pivot]: forward function *) -let rec betree_List_partition_at_pivot +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function *) +let rec betree_ListTupleU64T_partition_at_pivot (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) - (decreases (betree_List_partition_at_pivot_decreases t self pivot)) + (decreases (betree_ListTupleU64T_partition_at_pivot_decreases t self pivot)) = begin match self with | Betree_List_Cons hd tl -> @@ -158,14 +158,14 @@ let rec betree_List_partition_at_pivot if i >= pivot then Return (Betree_List_Nil, Betree_List_Cons (i, x) tl) else - let* p = betree_List_partition_at_pivot t tl pivot in + let* p = betree_ListTupleU64T_partition_at_pivot t tl pivot in let (ls0, ls1) = p in let l = ls0 in Return (Betree_List_Cons (i, x) l, ls1) | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end -(** [betree_main::betree::Leaf::{3}::split]: forward function *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function *) let betree_Leaf_split (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -185,7 +185,7 @@ let betree_Leaf_split let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) -(** [betree_main::betree::Leaf::{3}::split]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 0 *) let betree_Leaf_split_back0 (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -202,7 +202,7 @@ let betree_Leaf_split_back0 let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) -(** [betree_main::betree::Leaf::{3}::split]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 1 *) let betree_Leaf_split_back1 (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -219,7 +219,7 @@ let betree_Leaf_split_back1 let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) -(** [betree_main::betree::Leaf::{3}::split]: backward function 2 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 *) let betree_Leaf_split_back2 (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -237,7 +237,7 @@ let betree_Leaf_split_back2 let* node_id_cnt1 = betree_NodeIdCounter_fresh_id_back node_id_cnt0 in Return (st0, node_id_cnt1) -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function *) let rec betree_Node_lookup_first_message_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -252,7 +252,7 @@ let rec betree_Node_lookup_first_message_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 *) let rec betree_Node_lookup_first_message_for_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -271,14 +271,14 @@ let rec betree_Node_lookup_first_message_for_key_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::Node::{5}::apply_upserts]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function *) let rec betree_Node_apply_upserts (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : Tot (result (state & u64)) (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_List_head_has_key betree_Message_t msgs key in + let* b = betree_ListTupleU64T_head_has_key betree_Message_t msgs key in if b then let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in @@ -298,14 +298,14 @@ let rec betree_Node_apply_upserts Betree_Message_Insert v) in Return (st0, v) -(** [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 *) let rec betree_Node_apply_upserts_back (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) (st0 : state) : Tot (result (state & (betree_List_t (u64 & betree_Message_t)))) (decreases (betree_Node_apply_upserts_decreases msgs prev key st)) = - let* b = betree_List_head_has_key betree_Message_t msgs key in + let* b = betree_ListTupleU64T_head_has_key betree_Message_t msgs key in if b then let* msg = betree_List_pop_front (u64 & betree_Message_t) msgs in @@ -325,7 +325,7 @@ let rec betree_Node_apply_upserts_back Betree_Message_Insert v) in Return (st0, msgs0) -(** [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function *) let rec betree_Node_lookup_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) @@ -340,7 +340,7 @@ let rec betree_Node_lookup_in_bindings | Betree_List_Nil -> Return None end -(** [betree_main::betree::Internal::{4}::lookup_in_children]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function *) let rec betree_Internal_lookup_in_children (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -350,7 +350,7 @@ let rec betree_Internal_lookup_in_children then betree_Node_lookup self.left key st else betree_Node_lookup self.right key st -(** [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 *) and betree_Internal_lookup_in_children_back (self : betree_Internal_t) (key : u64) (st : state) (st0 : state) : Tot (result (state & betree_Internal_t)) @@ -364,7 +364,7 @@ and betree_Internal_lookup_in_children_back let* (st1, n) = betree_Node_lookup_back self.right key st st0 in Return (st1, { self with right = n }) -(** [betree_main::betree::Node::{5}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function *) and betree_Node_lookup (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -424,7 +424,7 @@ and betree_Node_lookup Return (st0, o) end -(** [betree_main::betree::Node::{5}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 *) and betree_Node_lookup_back (self : betree_Node_t) (key : u64) (st : state) (st0 : state) : Tot (result (state & betree_Node_t)) @@ -486,7 +486,7 @@ and betree_Node_lookup_back Return (st0, Betree_Node_Leaf node) end -(** [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec betree_Node_filter_messages_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : @@ -506,7 +506,7 @@ let rec betree_Node_filter_messages_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function *) let rec betree_Node_lookup_first_message_after_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -521,7 +521,7 @@ let rec betree_Node_lookup_first_message_after_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 *) let rec betree_Node_lookup_first_message_after_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -540,7 +540,7 @@ let rec betree_Node_lookup_first_message_after_key_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let betree_Node_apply_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) @@ -548,7 +548,7 @@ let betree_Node_apply_to_internal result (betree_List_t (u64 & betree_Message_t)) = let* msgs0 = betree_Node_lookup_first_message_for_key key msgs in - let* b = betree_List_head_has_key betree_Message_t msgs0 key in + let* b = betree_ListTupleU64T_head_has_key betree_Message_t msgs0 key in if b then begin match new_msg with @@ -599,7 +599,7 @@ let betree_Node_apply_to_internal betree_List_push_front (u64 & betree_Message_t) msgs0 (key, new_msg) in betree_Node_lookup_first_message_for_key_back key msgs msgs1 -(** [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec betree_Node_apply_messages_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) @@ -615,7 +615,7 @@ let rec betree_Node_apply_messages_to_internal | Betree_List_Nil -> Return msgs end -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function *) let rec betree_Node_lookup_mut_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (betree_List_t (u64 & u64))) @@ -630,7 +630,7 @@ let rec betree_Node_lookup_mut_in_bindings | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 *) let rec betree_Node_lookup_mut_in_bindings_back (key : u64) (bindings : betree_List_t (u64 & u64)) (ret : betree_List_t (u64 & u64)) : @@ -648,7 +648,7 @@ let rec betree_Node_lookup_mut_in_bindings_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let betree_Node_apply_to_leaf (bindings : betree_List_t (u64 & u64)) (key : u64) @@ -656,7 +656,7 @@ let betree_Node_apply_to_leaf result (betree_List_t (u64 & u64)) = let* bindings0 = betree_Node_lookup_mut_in_bindings key bindings in - let* b = betree_List_head_has_key u64 bindings0 key in + let* b = betree_ListTupleU64T_head_has_key u64 bindings0 key in if b then let* hd = betree_List_pop_front (u64 & u64) bindings0 in @@ -688,7 +688,7 @@ let betree_Node_apply_to_leaf betree_Node_lookup_mut_in_bindings_back key bindings bindings1 end -(** [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) *) let rec betree_Node_apply_messages_to_leaf (bindings : betree_List_t (u64 & u64)) @@ -704,7 +704,7 @@ let rec betree_Node_apply_messages_to_leaf | Betree_List_Nil -> Return bindings end -(** [betree_main::betree::Internal::{4}::flush]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function *) let rec betree_Internal_flush (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -713,7 +713,8 @@ let rec betree_Internal_flush (decreases ( betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + let* p = + betree_ListTupleU64T_partition_at_pivot betree_Message_t content self.pivot in let (msgs_left, msgs_right) = p in let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in @@ -752,7 +753,7 @@ let rec betree_Internal_flush st st1 in Return (st2, msgs_left) -(** [betree_main::betree::Internal::{4}::flush]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 *) and betree_Internal_flush_back'a (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -762,7 +763,8 @@ and betree_Internal_flush_back'a (decreases ( betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + let* p = + betree_ListTupleU64T_partition_at_pivot betree_Message_t content self.pivot in let (msgs_left, msgs_right) = p in let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in @@ -801,7 +803,7 @@ and betree_Internal_flush_back'a st st2 in Return (st0, ({ self with right = n }, node_id_cnt0)) -(** [betree_main::betree::Internal::{4}::flush]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 1 *) and betree_Internal_flush_back1 (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -811,7 +813,8 @@ and betree_Internal_flush_back1 (decreases ( betree_Internal_flush_decreases self params node_id_cnt content st)) = - let* p = betree_List_partition_at_pivot betree_Message_t content self.pivot + let* p = + betree_ListTupleU64T_partition_at_pivot betree_Message_t content self.pivot in let (msgs_left, msgs_right) = p in let* len_left = betree_List_len (u64 & betree_Message_t) msgs_left in @@ -850,7 +853,7 @@ and betree_Internal_flush_back1 st st2 in Return (st0, ()) -(** [betree_main::betree::Node::{5}::apply_messages]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function *) and betree_Node_apply_messages (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -891,7 +894,7 @@ and betree_Node_apply_messages Return (st1, ()) end -(** [betree_main::betree::Node::{5}::apply_messages]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 *) and betree_Node_apply_messages_back'a (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -937,7 +940,7 @@ and betree_Node_apply_messages_back'a Return (st0, (Betree_Node_Leaf { node with size = len }, node_id_cnt)) end -(** [betree_main::betree::Node::{5}::apply_messages]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 1 *) and betree_Node_apply_messages_back1 (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -979,7 +982,7 @@ and betree_Node_apply_messages_back1 let* _ = betree_store_leaf_node node.id content0 st1 in Return (st0, ()) end -(** [betree_main::betree::Node::{5}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function *) let betree_Node_apply (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -996,7 +999,7 @@ let betree_Node_apply betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 -(** [betree_main::betree::Node::{5}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 *) let betree_Node_apply_back'a (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1015,7 +1018,7 @@ let betree_Node_apply_back'a (key, new_msg) l) st st2 in Return (st0, (self0, node_id_cnt0)) -(** [betree_main::betree::Node::{5}::apply]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 1 *) let betree_Node_apply_back1 (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1034,7 +1037,7 @@ let betree_Node_apply_back1 (key, new_msg) l) st st2 in Return (st0, ()) -(** [betree_main::betree::BeTree::{6}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function *) let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : result (state & betree_BeTree_t) @@ -1050,7 +1053,7 @@ let betree_BeTree_new root = (Betree_Node_Leaf { id = id; size = 0 }) }) -(** [betree_main::betree::BeTree::{6}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function *) let betree_BeTree_apply (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) @@ -1062,7 +1065,7 @@ let betree_BeTree_apply st0 in betree_Node_apply_back1 self.root self.params self.node_id_cnt key msg st st1 -(** [betree_main::betree::BeTree::{6}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 *) let betree_BeTree_apply_back (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) (st0 : state) : @@ -1078,7 +1081,7 @@ let betree_BeTree_apply_back st2 in Return (st0, { self with node_id_cnt = nic; root = n }) -(** [betree_main::betree::BeTree::{6}::insert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function *) let betree_BeTree_insert (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) @@ -1089,7 +1092,7 @@ let betree_BeTree_insert betree_BeTree_apply_back self key (Betree_Message_Insert value) st st0 in Return (st1, ()) -(** [betree_main::betree::BeTree::{6}::insert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 *) let betree_BeTree_insert_back (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) (st0 : state) : @@ -1101,7 +1104,7 @@ let betree_BeTree_insert_back betree_BeTree_apply_back self key (Betree_Message_Insert value) st st1 in Return (st0, self0) -(** [betree_main::betree::BeTree::{6}::delete]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function *) let betree_BeTree_delete (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in @@ -1109,7 +1112,7 @@ let betree_BeTree_delete betree_BeTree_apply_back self key Betree_Message_Delete st st0 in Return (st1, ()) -(** [betree_main::betree::BeTree::{6}::delete]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 *) let betree_BeTree_delete_back (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : result (state & betree_BeTree_t) @@ -1119,7 +1122,7 @@ let betree_BeTree_delete_back betree_BeTree_apply_back self key Betree_Message_Delete st st1 in Return (st0, self0) -(** [betree_main::betree::BeTree::{6}::upsert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function *) let betree_BeTree_upsert (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -1131,7 +1134,7 @@ let betree_BeTree_upsert betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st0 in Return (st1, ()) -(** [betree_main::betree::BeTree::{6}::upsert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 *) let betree_BeTree_upsert_back (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) (st0 : state) : @@ -1143,14 +1146,14 @@ let betree_BeTree_upsert_back betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st1 in Return (st0, self0) -(** [betree_main::betree::BeTree::{6}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function *) let betree_BeTree_lookup (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = betree_Node_lookup self.root key st -(** [betree_main::betree::BeTree::{6}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 *) let betree_BeTree_lookup_back (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : result (state & betree_BeTree_t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti index c5d0a814..23d2e60e 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti @@ -24,7 +24,7 @@ val betree_utils_load_leaf_node val betree_utils_store_leaf_node : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) -(** [core::option::Option::{0}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function *) val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 0901d449..441a3721 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -47,17 +47,17 @@ def betree.fresh_node_id (counter : U64) : Result U64 := def betree.fresh_node_id_back (counter : U64) : Result U64 := counter + 1#u64 -/- [betree_main::betree::NodeIdCounter::{0}::new]: forward function -/ +/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function -/ def betree.NodeIdCounter.new : Result betree.NodeIdCounter := Result.ret { next_node_id := 0#u64 } -/- [betree_main::betree::NodeIdCounter::{0}::fresh_id]: forward function -/ +/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function -/ def betree.NodeIdCounter.fresh_id (self : betree.NodeIdCounter) : Result U64 := do let _ ← self.next_node_id + 1#u64 Result.ret self.next_node_id -/- [betree_main::betree::NodeIdCounter::{0}::fresh_id]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 -/ def betree.NodeIdCounter.fresh_id_back (self : betree.NodeIdCounter) : Result betree.NodeIdCounter := do @@ -85,7 +85,7 @@ def betree.upsert_update then prev0 - v else Result.ret 0#u64 -/- [betree_main::betree::List::{1}::len]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::len]: forward function -/ divergent def betree.List.len (T : Type) (self : betree.List T) : Result U64 := match self with | betree.List.Cons t tl => do @@ -93,7 +93,7 @@ divergent def betree.List.len (T : Type) (self : betree.List T) : Result U64 := 1#u64 + i | betree.List.Nil => Result.ret 0#u64 -/- [betree_main::betree::List::{1}::split_at]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function -/ divergent def betree.List.split_at (T : Type) (self : betree.List T) (n : U64) : Result ((betree.List T) × (betree.List T)) @@ -111,7 +111,7 @@ divergent def betree.List.split_at Result.ret (betree.List.Cons hd l, ls1) | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::List::{1}::push_front]: merged forward/backward function +/- [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def betree.List.push_front (T : Type) (self : betree.List T) (x : T) : Result (betree.List T) := @@ -119,14 +119,14 @@ def betree.List.push_front let l := tl Result.ret (betree.List.Cons x l) -/- [betree_main::betree::List::{1}::pop_front]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function -/ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret x | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::List::{1}::pop_front]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 -/ def betree.List.pop_front_back (T : Type) (self : betree.List T) : Result (betree.List T) := let ls := core.mem.replace (betree.List T) self betree.List.Nil @@ -134,22 +134,22 @@ def betree.List.pop_front_back | betree.List.Cons x tl => Result.ret tl | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::List::{1}::hd]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function -/ def betree.List.hd (T : Type) (self : betree.List T) : Result T := match self with | betree.List.Cons hd l => Result.ret hd | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::List::{2}::head_has_key]: forward function -/ -def betree.List.head_has_key +/- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function -/ +def betree.ListTupleU64T.head_has_key (T : Type) (self : betree.List (U64 × T)) (key : U64) : Result Bool := match self with | betree.List.Cons hd l => let (i, _) := hd Result.ret (i = key) | betree.List.Nil => Result.ret false -/- [betree_main::betree::List::{2}::partition_at_pivot]: forward function -/ -divergent def betree.List.partition_at_pivot +/- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function -/ +divergent def betree.ListTupleU64T.partition_at_pivot (T : Type) (self : betree.List (U64 × T)) (pivot : U64) : Result ((betree.List (U64 × T)) × (betree.List (U64 × T))) := @@ -160,13 +160,13 @@ divergent def betree.List.partition_at_pivot then Result.ret (betree.List.Nil, betree.List.Cons (i, t) tl) else do - let p ← betree.List.partition_at_pivot T tl pivot + let p ← betree.ListTupleU64T.partition_at_pivot T tl pivot let (ls0, ls1) := p let l := ls0 Result.ret (betree.List.Cons (i, t) l, ls1) | betree.List.Nil => Result.ret (betree.List.Nil, betree.List.Nil) -/- [betree_main::betree::Leaf::{3}::split]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function -/ def betree.Leaf.split (self : betree.Leaf) (content : betree.List (U64 × U64)) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (st : State) : @@ -186,7 +186,7 @@ def betree.Leaf.split let n0 := betree.Node.Leaf { id := id1, size := params.split_size } Result.ret (st1, betree.Internal.mk self.id pivot n n0) -/- [betree_main::betree::Leaf::{3}::split]: backward function 2 -/ +/- [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 -/ def betree.Leaf.split_back (self : betree.Leaf) (content : betree.List (U64 × U64)) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (st : State) : @@ -203,7 +203,7 @@ def betree.Leaf.split_back let _ ← betree.store_leaf_node id1 content1 st0 betree.NodeIdCounter.fresh_id_back node_id_cnt0 -/- [betree_main::betree::Node::{5}::lookup_first_message_for_key]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function -/ divergent def betree.Node.lookup_first_message_for_key (key : U64) (msgs : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) @@ -216,7 +216,7 @@ divergent def betree.Node.lookup_first_message_for_key else betree.Node.lookup_first_message_for_key key next_msgs | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::Node::{5}::lookup_first_message_for_key]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 -/ divergent def betree.Node.lookup_first_message_for_key_back (key : U64) (msgs : betree.List (U64 × betree.Message)) (ret0 : betree.List (U64 × betree.Message)) : @@ -234,14 +234,14 @@ divergent def betree.Node.lookup_first_message_for_key_back Result.ret (betree.List.Cons (i, m) next_msgs0) | betree.List.Nil => Result.ret ret0 -/- [betree_main::betree::Node::{5}::apply_upserts]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function -/ divergent def betree.Node.apply_upserts (msgs : betree.List (U64 × betree.Message)) (prev : Option U64) (key : U64) (st : State) : Result (State × U64) := do - let b ← betree.List.head_has_key betree.Message msgs key + let b ← betree.ListTupleU64T.head_has_key betree.Message msgs key if b then do @@ -264,14 +264,14 @@ divergent def betree.Node.apply_upserts betree.Message.Insert v) Result.ret (st0, v) -/- [betree_main::betree::Node::{5}::apply_upserts]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 -/ divergent def betree.Node.apply_upserts_back (msgs : betree.List (U64 × betree.Message)) (prev : Option U64) (key : U64) (st : State) : Result (betree.List (U64 × betree.Message)) := do - let b ← betree.List.head_has_key betree.Message msgs key + let b ← betree.ListTupleU64T.head_has_key betree.Message msgs key if b then do @@ -292,7 +292,7 @@ divergent def betree.Node.apply_upserts_back betree.List.push_front (U64 × betree.Message) msgs (key, betree.Message.Insert v) -/- [betree_main::betree::Node::{5}::lookup_in_bindings]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function -/ divergent def betree.Node.lookup_in_bindings (key : U64) (bindings : betree.List (U64 × U64)) : Result (Option U64) := match bindings with @@ -306,7 +306,7 @@ divergent def betree.Node.lookup_in_bindings else betree.Node.lookup_in_bindings key tl | betree.List.Nil => Result.ret none -/- [betree_main::betree::Internal::{4}::lookup_in_children]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function -/ mutual divergent def betree.Internal.lookup_in_children (self : betree.Internal) (key : U64) (st : State) : Result (State × (Option U64)) @@ -316,7 +316,7 @@ mutual divergent def betree.Internal.lookup_in_children then betree.Node.lookup n key st else betree.Node.lookup n0 key st -/- [betree_main::betree::Internal::{4}::lookup_in_children]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 -/ divergent def betree.Internal.lookup_in_children_back (self : betree.Internal) (key : U64) (st : State) : Result betree.Internal := let ⟨ i, i0, n, n0 ⟩ := self @@ -330,7 +330,7 @@ divergent def betree.Internal.lookup_in_children_back let n1 ← betree.Node.lookup_back n0 key st Result.ret (betree.Internal.mk i i0 n n1) -/- [betree_main::betree::Node::{5}::lookup]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function -/ divergent def betree.Node.lookup (self : betree.Node) (key : U64) (st : State) : Result (State × (Option U64)) @@ -402,7 +402,7 @@ divergent def betree.Node.lookup let o ← betree.Node.lookup_in_bindings key bindings Result.ret (st0, o) -/- [betree_main::betree::Node::{5}::lookup]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 -/ divergent def betree.Node.lookup_back (self : betree.Node) (key : U64) (st : State) : Result betree.Node := match self with @@ -475,7 +475,7 @@ divergent def betree.Node.lookup_back end -/- [betree_main::betree::Node::{5}::filter_messages_for_key]: merged forward/backward function +/- [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def betree.Node.filter_messages_for_key (key : U64) (msgs : betree.List (U64 × betree.Message)) : @@ -494,7 +494,7 @@ divergent def betree.Node.filter_messages_for_key else Result.ret (betree.List.Cons (k, m) l) | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::Node::{5}::lookup_first_message_after_key]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function -/ divergent def betree.Node.lookup_first_message_after_key (key : U64) (msgs : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) @@ -507,7 +507,7 @@ divergent def betree.Node.lookup_first_message_after_key else Result.ret (betree.List.Cons (k, m) next_msgs) | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::Node::{5}::lookup_first_message_after_key]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 -/ divergent def betree.Node.lookup_first_message_after_key_back (key : U64) (msgs : betree.List (U64 × betree.Message)) (ret0 : betree.List (U64 × betree.Message)) : @@ -525,7 +525,7 @@ divergent def betree.Node.lookup_first_message_after_key_back else Result.ret ret0 | betree.List.Nil => Result.ret ret0 -/- [betree_main::betree::Node::{5}::apply_to_internal]: merged forward/backward function +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def betree.Node.apply_to_internal (msgs : betree.List (U64 × betree.Message)) (key : U64) @@ -534,7 +534,7 @@ def betree.Node.apply_to_internal := do let msgs0 ← betree.Node.lookup_first_message_for_key key msgs - let b ← betree.List.head_has_key betree.Message msgs0 key + let b ← betree.ListTupleU64T.head_has_key betree.Message msgs0 key if b then match new_msg with @@ -591,7 +591,7 @@ def betree.Node.apply_to_internal betree.List.push_front (U64 × betree.Message) msgs0 (key, new_msg) betree.Node.lookup_first_message_for_key_back key msgs msgs1 -/- [betree_main::betree::Node::{5}::apply_messages_to_internal]: merged forward/backward function +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def betree.Node.apply_messages_to_internal (msgs : betree.List (U64 × betree.Message)) @@ -606,7 +606,7 @@ divergent def betree.Node.apply_messages_to_internal betree.Node.apply_messages_to_internal msgs0 new_msgs_tl | betree.List.Nil => Result.ret msgs -/- [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function -/ divergent def betree.Node.lookup_mut_in_bindings (key : U64) (bindings : betree.List (U64 × U64)) : Result (betree.List (U64 × U64)) @@ -619,7 +619,7 @@ divergent def betree.Node.lookup_mut_in_bindings else betree.Node.lookup_mut_in_bindings key tl | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::Node::{5}::lookup_mut_in_bindings]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 -/ divergent def betree.Node.lookup_mut_in_bindings_back (key : U64) (bindings : betree.List (U64 × U64)) (ret0 : betree.List (U64 × U64)) : @@ -636,7 +636,7 @@ divergent def betree.Node.lookup_mut_in_bindings_back Result.ret (betree.List.Cons (i, i0) tl0) | betree.List.Nil => Result.ret ret0 -/- [betree_main::betree::Node::{5}::apply_to_leaf]: merged forward/backward function +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ def betree.Node.apply_to_leaf (bindings : betree.List (U64 × U64)) (key : U64) (new_msg : betree.Message) @@ -645,7 +645,7 @@ def betree.Node.apply_to_leaf := do let bindings0 ← betree.Node.lookup_mut_in_bindings key bindings - let b ← betree.List.head_has_key U64 bindings0 key + let b ← betree.ListTupleU64T.head_has_key U64 bindings0 key if b then do @@ -685,7 +685,7 @@ def betree.Node.apply_to_leaf betree.List.push_front (U64 × U64) bindings0 (key, v) betree.Node.lookup_mut_in_bindings_back key bindings bindings1 -/- [betree_main::betree::Node::{5}::apply_messages_to_leaf]: merged forward/backward function +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) -/ divergent def betree.Node.apply_messages_to_leaf (bindings : betree.List (U64 × U64)) @@ -700,7 +700,7 @@ divergent def betree.Node.apply_messages_to_leaf betree.Node.apply_messages_to_leaf bindings0 new_msgs_tl | betree.List.Nil => Result.ret bindings -/- [betree_main::betree::Internal::{4}::flush]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function -/ mutual divergent def betree.Internal.flush (self : betree.Internal) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -709,7 +709,7 @@ mutual divergent def betree.Internal.flush := do let ⟨ _, i, n, n0 ⟩ := self - let p ← betree.List.partition_at_pivot betree.Message content i + let p ← betree.ListTupleU64T.partition_at_pivot betree.Message content i let (msgs_left, msgs_right) := p let len_left ← betree.List.len (U64 × betree.Message) msgs_left if len_left >= params.min_flush_size @@ -738,7 +738,7 @@ mutual divergent def betree.Internal.flush betree.Node.apply_messages_back n0 params node_id_cnt msgs_right st Result.ret (st0, msgs_left) -/- [betree_main::betree::Internal::{4}::flush]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 -/ divergent def betree.Internal.flush_back (self : betree.Internal) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -747,7 +747,7 @@ divergent def betree.Internal.flush_back := do let ⟨ i, i0, n, n0 ⟩ := self - let p ← betree.List.partition_at_pivot betree.Message content i0 + let p ← betree.ListTupleU64T.partition_at_pivot betree.Message content i0 let (msgs_left, msgs_right) := p let len_left ← betree.List.len (U64 × betree.Message) msgs_left if len_left >= params.min_flush_size @@ -772,7 +772,7 @@ divergent def betree.Internal.flush_back betree.Node.apply_messages_back n0 params node_id_cnt msgs_right st Result.ret (betree.Internal.mk i i0 n n1, node_id_cnt0) -/- [betree_main::betree::Node::{5}::apply_messages]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function -/ divergent def betree.Node.apply_messages (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -820,7 +820,7 @@ divergent def betree.Node.apply_messages let (st1, _) ← betree.store_leaf_node node.id content0 st0 Result.ret (st1, ()) -/- [betree_main::betree::Node::{5}::apply_messages]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 -/ divergent def betree.Node.apply_messages_back (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -874,7 +874,7 @@ divergent def betree.Node.apply_messages_back end -/- [betree_main::betree::Node::{5}::apply]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function -/ def betree.Node.apply (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (key : U64) (new_msg : betree.Message) @@ -891,7 +891,7 @@ def betree.Node.apply (key, new_msg) l) st Result.ret (st0, ()) -/- [betree_main::betree::Node::{5}::apply]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 -/ def betree.Node.apply_back (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (key : U64) (new_msg : betree.Message) @@ -902,7 +902,7 @@ def betree.Node.apply_back betree.Node.apply_messages_back self params node_id_cnt (betree.List.Cons (key, new_msg) l) st -/- [betree_main::betree::BeTree::{6}::new]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function -/ def betree.BeTree.new (min_flush_size : U64) (split_size : U64) (st : State) : Result (State × betree.BeTree) @@ -920,7 +920,7 @@ def betree.BeTree.new root := (betree.Node.Leaf { id := id, size := 0#u64 }) }) -/- [betree_main::betree::BeTree::{6}::apply]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function -/ def betree.BeTree.apply (self : betree.BeTree) (key : U64) (msg : betree.Message) (st : State) : Result (State × Unit) @@ -932,7 +932,7 @@ def betree.BeTree.apply betree.Node.apply_back self.root self.params self.node_id_cnt key msg st Result.ret (st0, ()) -/- [betree_main::betree::BeTree::{6}::apply]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 -/ def betree.BeTree.apply_back (self : betree.BeTree) (key : U64) (msg : betree.Message) (st : State) : Result betree.BeTree @@ -942,7 +942,7 @@ def betree.BeTree.apply_back betree.Node.apply_back self.root self.params self.node_id_cnt key msg st Result.ret { self with node_id_cnt := nic, root := n } -/- [betree_main::betree::BeTree::{6}::insert]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function -/ def betree.BeTree.insert (self : betree.BeTree) (key : U64) (value : U64) (st : State) : Result (State × Unit) @@ -954,14 +954,14 @@ def betree.BeTree.insert betree.BeTree.apply_back self key (betree.Message.Insert value) st Result.ret (st0, ()) -/- [betree_main::betree::BeTree::{6}::insert]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 -/ def betree.BeTree.insert_back (self : betree.BeTree) (key : U64) (value : U64) (st : State) : Result betree.BeTree := betree.BeTree.apply_back self key (betree.Message.Insert value) st -/- [betree_main::betree::BeTree::{6}::delete]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function -/ def betree.BeTree.delete (self : betree.BeTree) (key : U64) (st : State) : Result (State × Unit) := do @@ -969,12 +969,12 @@ def betree.BeTree.delete let _ ← betree.BeTree.apply_back self key betree.Message.Delete st Result.ret (st0, ()) -/- [betree_main::betree::BeTree::{6}::delete]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 -/ def betree.BeTree.delete_back (self : betree.BeTree) (key : U64) (st : State) : Result betree.BeTree := betree.BeTree.apply_back self key betree.Message.Delete st -/- [betree_main::betree::BeTree::{6}::upsert]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function -/ def betree.BeTree.upsert (self : betree.BeTree) (key : U64) (upd : betree.UpsertFunState) (st : State) : @@ -986,7 +986,7 @@ def betree.BeTree.upsert let _ ← betree.BeTree.apply_back self key (betree.Message.Upsert upd) st Result.ret (st0, ()) -/- [betree_main::betree::BeTree::{6}::upsert]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 -/ def betree.BeTree.upsert_back (self : betree.BeTree) (key : U64) (upd : betree.UpsertFunState) (st : State) : @@ -994,14 +994,14 @@ def betree.BeTree.upsert_back := betree.BeTree.apply_back self key (betree.Message.Upsert upd) st -/- [betree_main::betree::BeTree::{6}::lookup]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function -/ def betree.BeTree.lookup (self : betree.BeTree) (key : U64) (st : State) : Result (State × (Option U64)) := betree.Node.lookup self.root key st -/- [betree_main::betree::BeTree::{6}::lookup]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 -/ def betree.BeTree.lookup_back (self : betree.BeTree) (key : U64) (st : State) : Result betree.BeTree := do diff --git a/tests/lean/BetreeMain/FunsExternal_Template.lean b/tests/lean/BetreeMain/FunsExternal_Template.lean index 430d2dda..1dc3af0e 100644 --- a/tests/lean/BetreeMain/FunsExternal_Template.lean +++ b/tests/lean/BetreeMain/FunsExternal_Template.lean @@ -24,7 +24,7 @@ axiom betree_utils.load_leaf_node axiom betree_utils.store_leaf_node : U64 → betree.List (U64 × U64) → State → Result (State × Unit) -/- [core::option::Option::{0}::unwrap]: forward function -/ +/- [core::option::{core::option::Option}::unwrap]: forward function -/ axiom core.option.Option.unwrap (T : Type) : Option T → State → Result (State × T) -- cgit v1.2.3 From f852e1a1334b7506c0baf366b9e75cd01b9c843e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 12:15:37 +0100 Subject: Rename PrimitiveValues to Values --- compiler/InterpreterExpansion.ml | 1 - compiler/InterpreterExpansion.mli | 1 - compiler/InterpreterExpressions.ml | 3 +-- compiler/InterpreterStatements.ml | 1 - compiler/Invariants.ml | 3 +-- compiler/PrimitiveValues.ml | 1 - compiler/PrimitiveValuesUtils.ml | 1 - compiler/Print.ml | 3 ++- compiler/PrintPure.ml | 8 ++++---- compiler/SymbolicToPure.ml | 4 +--- compiler/SynthesizeSymbolic.ml | 1 - compiler/Values.ml | 4 +--- compiler/ValuesUtils.ml | 2 +- compiler/dune | 2 -- 14 files changed, 11 insertions(+), 24 deletions(-) delete mode 100644 compiler/PrimitiveValues.ml delete mode 100644 compiler/PrimitiveValuesUtils.ml diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index ff21cd77..d7f5fcd5 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -4,7 +4,6 @@ * using indices to identify the values for instance). *) open Types -open PrimitiveValues open Values open Contexts open TypesUtils diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index 6ea75d0b..4be1fd24 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -1,4 +1,3 @@ -open PrimitiveValues open Values open Contexts open Cps diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index 38620be0..cc0580be 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -1,4 +1,3 @@ -open PrimitiveValues open Types open Values open LlbcAst @@ -96,7 +95,7 @@ let literal_to_typed_value (ty : literal_type) (cv : literal) : typed_value = log#ldebug (lazy ("literal_to_typed_value:" ^ "\n- cv: " - ^ Print.PrimitiveValues.literal_to_string cv)); + ^ Print.Values.literal_to_string cv)); match (ty, cv) with (* Scalar, boolean... *) | TBool, VBool v -> { value = VLiteral (VBool v); ty = TLiteral ty } diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 88130f21..e8069e31 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -1,6 +1,5 @@ open Types open TypesUtils -open PrimitiveValues open Values open ValuesUtils open Expressions diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 49ba8370..e0e3f354 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -2,7 +2,6 @@ * are always maintained by evaluation contexts *) open Types -open PrimitiveValues open Values open Contexts open Cps @@ -465,7 +464,7 @@ let check_typing_invariant (ctx : eval_ctx) : unit = inner_values); (* The length is necessarily concrete *) let len = - (PrimitiveValuesUtils.literal_as_scalar + (ValuesUtils.literal_as_scalar (TypesUtils.const_generic_as_literal cg)) .value in diff --git a/compiler/PrimitiveValues.ml b/compiler/PrimitiveValues.ml deleted file mode 100644 index 0eacca9e..00000000 --- a/compiler/PrimitiveValues.ml +++ /dev/null @@ -1 +0,0 @@ -include Charon.PrimitiveValues diff --git a/compiler/PrimitiveValuesUtils.ml b/compiler/PrimitiveValuesUtils.ml deleted file mode 100644 index 0000916d..00000000 --- a/compiler/PrimitiveValuesUtils.ml +++ /dev/null @@ -1 +0,0 @@ -include Charon.PrimitiveValuesUtils diff --git a/compiler/Print.ml b/compiler/Print.ml index 48a5a20b..92ce6f23 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -10,7 +10,6 @@ open ValuesUtils open Expressions open LlbcAst open Contexts -module PrimitiveValues = Charon.PrintPrimitiveValues module Types = Charon.PrintTypes module Expressions = Charon.PrintExpressions @@ -21,6 +20,8 @@ let bool_to_string (b : bool) : string = if b then "true" else "false" (** Pretty-printing for values *) module Values = struct + include Charon.PrintValues + let symbolic_value_id_to_pretty_string (id : SymbolicValueId.id) : string = "s@" ^ SymbolicValueId.to_string id diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index a7ec9336..49e74b6c 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -102,10 +102,10 @@ let adt_field_names (env : fmt_env) = let option_to_string = Print.option_to_string let type_var_to_string = Print.Types.type_var_to_string let const_generic_var_to_string = Print.Types.const_generic_var_to_string -let integer_type_to_string = Print.PrimitiveValues.integer_type_to_string -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 +let integer_type_to_string = Print.Values.integer_type_to_string +let literal_type_to_string = Print.Values.literal_type_to_string +let scalar_value_to_string = Print.Values.scalar_value_to_string +let literal_to_string = Print.Values.literal_to_string let assumed_ty_to_string (aty : assumed_ty) : string = match aty with diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 6983a0e8..f25ff2f6 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -2,16 +2,14 @@ open Utils open LlbcAstUtils open Pure open PureUtils -open PrimitiveValues open InterpreterUtils open FunsAnalysis open TypesAnalysis module T = Types -module Id = Identifiers +module V = Values module C = Contexts module A = LlbcAst module S = SymbolicAst -module TA = TypesAnalysis module PP = PrintPure (** The local logger *) diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 38efc53a..9e14a4d6 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -1,6 +1,5 @@ open Types open TypesUtils -open PrimitiveValues open Expressions open Values open SymbolicAst diff --git a/compiler/Values.ml b/compiler/Values.ml index 6b1a782c..c1ff9804 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -1,5 +1,6 @@ open Identifiers open Types +include Charon.Values (* TODO(SH): I often write "abstract" (value, borrow content, etc.) while I should * write "abstraction" (because those values are not abstract, they simply are @@ -11,9 +12,6 @@ module AbstractionId = IdGen () module FunCallId = IdGen () module LoopId = IdGen () -type big_int = PrimitiveValues.big_int [@@deriving show, ord] -type scalar_value = PrimitiveValues.scalar_value [@@deriving show, ord] -type literal = PrimitiveValues.literal [@@deriving show, ord] type symbolic_value_id = SymbolicValueId.id [@@deriving show, ord] type symbolic_value_id_set = SymbolicValueId.Set.t [@@deriving show, ord] type loop_id = LoopId.id [@@deriving show, ord] diff --git a/compiler/ValuesUtils.ml b/compiler/ValuesUtils.ml index 0d3533c2..2c7d213f 100644 --- a/compiler/ValuesUtils.ml +++ b/compiler/ValuesUtils.ml @@ -2,7 +2,7 @@ open Utils open TypesUtils open Types open Values -include PrimitiveValuesUtils +include Charon.ValuesUtils (** Utility exception *) exception FoundSymbolicValue of symbolic_value diff --git a/compiler/dune b/compiler/dune index 39ad6260..4bba6a08 100644 --- a/compiler/dune +++ b/compiler/dune @@ -51,8 +51,6 @@ PrePasses Print PrintPure - PrimitiveValues - PrimitiveValuesUtils PureMicroPasses Pure PureTypeCheck -- cgit v1.2.3 From e94cd72ffa63dbc5fc40c7c1a422c1a70ba4a7e5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 13:55:46 +0100 Subject: Add an `is_local` field to declarations --- compiler/Pure.ml | 4 ++++ compiler/PureMicroPasses.ml | 1 + compiler/PureUtils.ml | 2 ++ compiler/SymbolicToPure.ml | 8 +++++++- compiler/dune | 4 ++-- 5 files changed, 16 insertions(+), 3 deletions(-) diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 40711e53..ebcaa68d 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -381,6 +381,7 @@ type predicates = { trait_type_constraints : trait_type_constraint list } type type_decl = { def_id : TypeDeclId.id; + is_local : bool; llbc_name : llbc_name; (** The original name coming from the LLBC declaration *) name : string; @@ -991,6 +992,7 @@ type fun_kind = A.fun_kind [@@deriving show] type fun_decl = { def_id : FunDeclId.id; + is_local : bool; kind : fun_kind; num_loops : int; (** The number of loops in the parent forward function (basically the number @@ -1014,6 +1016,7 @@ type fun_decl = { type trait_decl = { def_id : trait_decl_id; + is_local : bool; llbc_name : llbc_name; name : string; generics : generic_params; @@ -1028,6 +1031,7 @@ type trait_decl = { type trait_impl = { def_id : trait_impl_id; + is_local : bool; llbc_name : llbc_name; name : string; impl_trait : trait_decl_ref; diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 96421925..1565f252 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1427,6 +1427,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_def : fun_decl = { def_id = def.def_id; + is_local = def.is_local; kind = def.kind; num_loops; loop_id = Some loop.loop_id; diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 06270621..d410abdc 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -646,6 +646,7 @@ let trait_decl_get_method (trait_decl : trait_decl) (method_name : string) : let trait_decl_is_empty (trait_decl : trait_decl) : bool = let { def_id = _; + is_local = _; name = _; llbc_name = _; generics = _; @@ -664,6 +665,7 @@ let trait_decl_is_empty (trait_decl : trait_decl) : bool = let trait_impl_is_empty (trait_impl : trait_impl) : bool = let { def_id = _; + is_local = _; name = _; llbc_name = _; impl_trait = _; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index f25ff2f6..9899a0c6 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -495,7 +495,8 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let generics = { types; const_generics; trait_clauses } in let kind = translate_type_decl_kind def.T.kind in let preds = translate_predicates def.preds in - { def_id; llbc_name; name; generics; kind; preds } + let is_local = def.is_local in + { def_id; is_local; llbc_name; name; generics; kind; preds } let translate_type_id (id : T.type_id) : type_id = match id with @@ -3026,6 +3027,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = let def : fun_decl = { def_id; + is_local = def.is_local; kind = def.kind; num_loops; loop_id; @@ -3104,6 +3106,7 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) : trait_decl = let { def_id; + is_local; name = llbc_name; generics; preds; @@ -3139,6 +3142,7 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) in { def_id; + is_local; llbc_name; name; generics; @@ -3154,6 +3158,7 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) : trait_impl = let { A.def_id; + is_local; name = llbc_name; impl_trait; generics; @@ -3193,6 +3198,7 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in { def_id; + is_local; llbc_name; name; impl_trait; diff --git a/compiler/dune b/compiler/dune index 4bba6a08..0d0a8017 100644 --- a/compiler/dune +++ b/compiler/dune @@ -84,7 +84,7 @@ -g ;-dsource -warn-error - -5@8-9-11-14-33-20-21-26-27-39)) + -5@8-11-14-33-20-21-26-27-39)) (release (flags :standard @@ -92,4 +92,4 @@ -g ;-dsource -warn-error - -5@8-9-11-14-33-20-21-26-27-39))) + -5@8-11-14-33-20-21-26-27-39))) -- cgit v1.2.3 From 77ba13b371cccbe8098e432ebd287108d5373666 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 14:43:12 +0100 Subject: Add span information to the generated code --- compiler/Extract.ml | 31 +++++++++++++++++++------------ compiler/ExtractTypes.ml | 15 ++++++++++++++- compiler/InterpreterLoops.ml | 12 +++++++----- compiler/InterpreterLoops.mli | 3 ++- compiler/InterpreterStatements.ml | 2 +- compiler/PrintPure.ml | 4 ++-- compiler/Pure.ml | 13 +++++++++++-- compiler/PureMicroPasses.ml | 9 ++++++--- compiler/PureUtils.ml | 6 ++++-- compiler/SymbolicAst.ml | 13 +++++++------ compiler/SymbolicToPure.ml | 21 ++++++++++++++------- compiler/SynthesizeSymbolic.ml | 7 ++++--- 12 files changed, 91 insertions(+), 45 deletions(-) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index fb3364f4..d7b4c152 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1135,8 +1135,9 @@ let extract_template_fstar_decreases_clause (ctx : extraction_ctx) (* 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 - [ "[" ^ name_to_string ctx def.llbc_name ^ "]: decreases clause" ]; + extract_comment_with_span fmt + [ "[" ^ name_to_string ctx def.llbc_name ^ "]: decreases clause" ] + def.meta.span; F.pp_print_space fmt (); (* Open a box for the definition, so that whenever possible it gets printed on * one line *) @@ -1197,8 +1198,9 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) (* 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 - [ "[" ^ name_to_string ctx def.llbc_name ^ "]: termination measure" ]; + extract_comment_with_span fmt + [ "[" ^ name_to_string ctx def.llbc_name ^ "]: termination measure" ] + def.meta.span; F.pp_print_space fmt (); (* Open a box for the definition, so that whenever possible it gets printed on * one line *) @@ -1251,8 +1253,9 @@ let extract_template_lean_termination_and_decreasing (ctx : extraction_ctx) let def_name = ctx_get_decreases_proof def.def_id def.loop_id ctx in (* syntax term ... term : tactic *) F.pp_print_break fmt 0 0; - extract_comment fmt - [ "[" ^ name_to_string ctx def.llbc_name ^ "]: decreases_by tactic" ]; + extract_comment_with_span fmt + [ "[" ^ name_to_string ctx def.llbc_name ^ "]: decreases_by tactic" ] + def.meta.span; F.pp_print_space fmt (); F.pp_open_hvbox fmt 0; F.pp_print_string fmt "syntax \""; @@ -1313,7 +1316,7 @@ let extract_fun_comment (ctx : extraction_ctx) (fmt : F.formatter) | [ s ] -> [ comment_pre ^ loop_comment ^ s ] | s :: sl -> (comment_pre ^ loop_comment ^ s) :: sl in - extract_comment fmt comment + extract_comment_with_span fmt comment def.meta.span (** Extract a function declaration. @@ -1765,7 +1768,9 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; - extract_comment fmt [ "[" ^ name_to_string ctx global.name ^ "]" ]; + extract_comment_with_span fmt + [ "[" ^ name_to_string ctx global.name ^ "]" ] + global.meta.span; F.pp_print_space fmt (); let decl_name = ctx_get_global global.def_id ctx in @@ -2190,8 +2195,9 @@ 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 - [ "Trait declaration: [" ^ name_to_string ctx decl.llbc_name ^ "]" ]; + extract_comment_with_span fmt + [ "Trait declaration: [" ^ name_to_string ctx decl.llbc_name ^ "]" ] + decl.meta.span; F.pp_print_break fmt 0 0; (* Open two outer boxes for the definition, so that whenever possible it gets printed on one line and indents are correct. @@ -2478,8 +2484,9 @@ 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 - [ "Trait implementation: [" ^ name_to_string ctx impl.llbc_name ^ "]" ]; + extract_comment_with_span fmt + [ "Trait implementation: [" ^ name_to_string ctx impl.llbc_name ^ "]" ] + impl.meta.span; F.pp_print_break fmt 0 0; (* Open two outer boxes for the definition, so that whenever possible it gets printed on diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index a74bd532..4dcefabc 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1813,6 +1813,17 @@ let extract_comment (fmt : F.formatter) (sl : string list) : unit = F.pp_print_string fmt rd; F.pp_close_box fmt () +let extract_comment_with_span (fmt : F.formatter) (sl : string list) + (span : Meta.span) : unit = + let file = match span.file with Virtual s | Local s -> s in + let span = + "Source: '" ^ file ^ "': lines " + ^ string_of_int span.beg_loc.line + ^ "-" + ^ string_of_int span.end_loc.line + in + extract_comment fmt (sl @ [ span ]) + 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 @@ -2034,7 +2045,9 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) 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 [ "[" ^ name_to_string ctx def.llbc_name ^ "]" ]; + extract_comment_with_span fmt + [ "[" ^ name_to_string ctx def.llbc_name ^ "]" ] + def.meta.span; 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 diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index f88fc977..ed2a9587 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -2,6 +2,7 @@ open Types open Values open Contexts open ValuesUtils +open Meta module S = SynthesizeSymbolic open Cps open InterpreterUtils @@ -60,8 +61,8 @@ let eval_loop_concrete (eval_loop_body : st_cm_fun) : st_cm_fun = eval_loop_body reeval_loop_body ctx (** Evaluate a loop in symbolic mode *) -let eval_loop_symbolic (config : config) (eval_loop_body : st_cm_fun) : - st_cm_fun = +let eval_loop_symbolic (config : config) (meta : meta) + (eval_loop_body : st_cm_fun) : st_cm_fun = fun cf ctx -> (* Debug *) log#ldebug @@ -205,9 +206,10 @@ let eval_loop_symbolic (config : config) (eval_loop_body : st_cm_fun) : (* Put together *) S.synthesize_loop loop_id input_svalues fresh_sids rg_to_given_back end_expr - loop_expr + loop_expr meta -let eval_loop (config : config) (eval_loop_body : st_cm_fun) : st_cm_fun = +let eval_loop (config : config) (meta : meta) (eval_loop_body : st_cm_fun) : + st_cm_fun = fun cf ctx -> match config.mode with | ConcreteMode -> eval_loop_concrete eval_loop_body cf ctx @@ -231,4 +233,4 @@ let eval_loop (config : config) (eval_loop_body : st_cm_fun) : st_cm_fun = *non-fixed* abstractions. *) let cc = prepare_ashared_loans None in - comp cc (eval_loop_symbolic config eval_loop_body) cf ctx + comp cc (eval_loop_symbolic config meta eval_loop_body) cf ctx diff --git a/compiler/InterpreterLoops.mli b/compiler/InterpreterLoops.mli index 320e4bcb..03633861 100644 --- a/compiler/InterpreterLoops.mli +++ b/compiler/InterpreterLoops.mli @@ -58,6 +58,7 @@ open Contexts open Cps +open Meta (** Evaluate a loop *) -val eval_loop : config -> st_cm_fun -> st_cm_fun +val eval_loop : config -> meta -> st_cm_fun -> st_cm_fun diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index e8069e31..9ea5387f 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -739,7 +739,7 @@ let rec eval_statement (config : config) (st : statement) : st_cm_fun = (* Compose and apply *) comp cf_st1 cf_st2 cf ctx | Loop loop_body -> - InterpreterLoops.eval_loop config + InterpreterLoops.eval_loop config st.meta (eval_statement config loop_body) cf ctx | Switch switch -> eval_switch config switch cf ctx diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 49e74b6c..5d8297d3 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -590,7 +590,7 @@ let rec texpression_to_string (env : fmt_env) (inside : bool) (indent : string) "[ " ^ String.concat ", " fields ^ " ]" | _ -> raise (Failure "Unexpected")) | Meta (meta, e) -> ( - let meta_s = meta_to_string env meta in + let meta_s = emeta_to_string env meta in let e = texpression_to_string env inside indent indent_incr e in match meta with | Assignment _ | SymbolicAssignment _ | Tag _ -> @@ -724,7 +724,7 @@ and loop_to_string (env : fmt_env) (indent : string) (indent_incr : string) ^ indent1 ^ "loop_body: {\n" ^ indent2 ^ loop_body ^ "\n" ^ indent1 ^ "}\n" ^ indent ^ "}" -and meta_to_string (env : fmt_env) (meta : meta) : string = +and emeta_to_string (env : fmt_env) (meta : emeta) : string = let meta = match meta with | Assignment (lp, rv, rp) -> diff --git a/compiler/Pure.ml b/compiler/Pure.ml index ebcaa68d..42f51075 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -48,6 +48,10 @@ 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] +type loc = Meta.loc [@@deriving show, ord] +type file_name = Meta.file_name [@@deriving show, ord] +type span = Meta.span [@@deriving show, ord] +type meta = Meta.meta [@@deriving show, ord] (** The assumed types for the pure AST. @@ -389,6 +393,7 @@ type type_decl = { the name used at extraction time will be derived from the llbc_name. *) + meta : meta; generics : generic_params; kind : type_decl_kind; preds : predicates; @@ -717,7 +722,7 @@ type expression = | Switch of texpression * switch_body | Loop of loop (** See the comments for {!loop} *) | StructUpdate of struct_update (** See the comments for {!struct_update} *) - | Meta of (meta[@opaque]) * texpression (** Meta-information *) + | Meta of (emeta[@opaque]) * texpression (** Meta-information *) and switch_body = If of texpression * texpression | Match of match_branch list and match_branch = { pat : typed_pattern; branch : texpression } @@ -736,6 +741,7 @@ and match_branch = { pat : typed_pattern; branch : texpression } and loop = { fun_end : texpression; loop_id : loop_id; + meta : meta; [@opaque] fuel0 : var_id; fuel : var_id; input_state : var_id option; @@ -791,7 +797,7 @@ and texpression = { e : expression; ty : ty } and mvalue = (texpression[@opaque]) (** Meta-information stored in the AST *) -and meta = +and emeta = | Assignment of mplace * mvalue * mplace option (** Information about an assignment which occured in LLBC. We use this to guide the heuristics which derive pretty names. @@ -993,6 +999,7 @@ type fun_kind = A.fun_kind [@@deriving show] type fun_decl = { def_id : FunDeclId.id; is_local : bool; + meta : meta; kind : fun_kind; num_loops : int; (** The number of loops in the parent forward function (basically the number @@ -1019,6 +1026,7 @@ type trait_decl = { is_local : bool; llbc_name : llbc_name; name : string; + meta : meta; generics : generic_params; preds : predicates; parent_clauses : trait_clause list; @@ -1034,6 +1042,7 @@ type trait_impl = { is_local : bool; llbc_name : llbc_name; name : string; + meta : meta; impl_trait : trait_decl_ref; generics : generic_params; preds : predicates; diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 1565f252..8463f56c 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -391,7 +391,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = | Switch (scrut, body) -> update_switch_body scrut body ctx | Loop loop -> update_loop loop ctx | StructUpdate supd -> update_struct_update supd ctx - | Meta (meta, e) -> update_meta meta e ctx + | Meta (meta, e) -> update_emeta meta e ctx in (ctx, { e; ty }) (* *) @@ -449,6 +449,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = let { fun_end; loop_id; + meta; fuel0; fuel; input_state; @@ -467,6 +468,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = { fun_end; loop_id; + meta; fuel0; fuel; input_state; @@ -490,7 +492,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = let supd = { struct_id; init; updates } in (ctx, StructUpdate supd) (* *) - and update_meta (meta : meta) (e : texpression) (ctx : pn_ctx) : + and update_emeta (meta : emeta) (e : texpression) (ctx : pn_ctx) : pn_ctx * expression = let ctx = match meta with @@ -516,7 +518,7 @@ let compute_pretty_names (def : fun_decl) : fun_decl = | Tag _ -> ctx in let ctx, e = update_texpression e ctx in - let e = mk_meta meta e in + let e = mk_emeta meta e in (ctx, e.e) in @@ -1428,6 +1430,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = { def_id = def.def_id; is_local = def.is_local; + meta = loop.meta; kind = def.kind; num_loops; loop_id = Some loop.loop_id; diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index d410abdc..992ea499 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -453,13 +453,13 @@ let mk_dummy_pattern (ty : ty) : typed_pattern = let value = PatDummy in { value; ty } -let mk_meta (m : meta) (e : texpression) : texpression = +let mk_emeta (m : emeta) (e : texpression) : texpression = let ty = e.ty in let e = Meta (m, e) in { e; ty } let mk_mplace_texpression (mp : mplace) (e : texpression) : texpression = - mk_meta (MPlace mp) e + mk_emeta (MPlace mp) e let mk_opt_mplace_texpression (mp : mplace option) (e : texpression) : texpression = @@ -649,6 +649,7 @@ let trait_decl_is_empty (trait_decl : trait_decl) : bool = is_local = _; name = _; llbc_name = _; + meta = _; generics = _; preds = _; parent_clauses; @@ -668,6 +669,7 @@ let trait_impl_is_empty (trait_impl : trait_impl) : bool = is_local = _; name = _; llbc_name = _; + meta = _; impl_trait = _; generics = _; preds = _; diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index c9820ba5..a9f45926 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -51,11 +51,10 @@ type call = { } [@@deriving show] -(** Meta information, not necessary for synthesis but useful to guide it to - generate a pretty output. +(** Meta information for expressions, not necessary for synthesis but useful to + guide it to generate a pretty output. *) - -type meta = +type emeta = | Assignment of Contexts.eval_ctx * mplace * typed_value * mplace option (** We generated an assignment (destination, assigned value, src) *) [@@deriving show] @@ -82,7 +81,8 @@ class ['self] iter_expression_base = fun _ _ -> () method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () - method visit_meta : 'env -> meta -> unit = fun _ _ -> () + method visit_emeta : 'env -> emeta -> unit = fun _ _ -> () + method visit_meta : 'env -> Meta.meta -> unit = fun _ _ -> () method visit_region_group_id_map : 'a. ('env -> 'a -> unit) -> 'env -> 'a region_group_id_map -> unit = @@ -200,7 +200,7 @@ type expression = The boolean is [is_continue]. *) - | Meta of meta * expression (** Meta information *) + | Meta of emeta * expression (** Meta information *) and loop = { loop_id : loop_id; @@ -215,6 +215,7 @@ and loop = { end_expr : expression; (** The end of the function (upon the moment it enters the loop) *) loop_expr : expression; (** The symbolically executed loop body *) + meta : Meta.meta; (** Information about where the origin of the loop body *) } and expansion = diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 9899a0c6..5dee23db 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -496,7 +496,8 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let kind = translate_type_decl_kind def.T.kind in let preds = translate_predicates def.preds in let is_local = def.is_local in - { def_id; is_local; llbc_name; name; generics; kind; preds } + let meta = def.meta in + { def_id; is_local; llbc_name; name; meta; generics; kind; preds } let translate_type_id (id : T.type_id) : type_id = match id with @@ -1489,11 +1490,11 @@ let get_abs_ancestors (ctx : bs_ctx) (abs : V.abs) (call_id : V.FunCallId.id) : (call_info.forward, abs_ancestors) (** Add meta-information to an expression *) -let mk_meta_symbolic_assignments (vars : var list) (values : texpression list) +let mk_emeta_symbolic_assignments (vars : var list) (values : texpression list) (e : texpression) : texpression = let var_values = List.combine vars values in List.fold_right - (fun (var, arg) e -> mk_meta (SymbolicAssignment (var_get_id var, arg)) e) + (fun (var, arg) e -> mk_emeta (SymbolicAssignment (var_get_id var, arg)) e) var_values e let rec translate_expression (e : S.expression) (ctx : bs_ctx) : texpression = @@ -1509,7 +1510,7 @@ let rec translate_expression (e : S.expression) (ctx : bs_ctx) : texpression = | Expansion (p, sv, exp) -> translate_expansion p sv exp ctx | IntroSymbolic (ectx, p, sv, v, e) -> translate_intro_symbolic ectx p sv v e ctx - | Meta (meta, e) -> translate_meta meta e ctx + | Meta (meta, e) -> translate_emeta meta e ctx | ForwardEnd (ectx, loop_input_values, e, back_e) -> translate_forward_end ectx loop_input_values e back_e ctx | Loop loop -> translate_loop loop ctx @@ -2206,7 +2207,7 @@ and translate_end_abstraction_loop (ectx : C.eval_ctx) (abs : V.abs) var_values in let vars, values = List.split var_values in - mk_meta_symbolic_assignments vars values next_e + mk_emeta_symbolic_assignments vars values next_e else next_e in @@ -2637,7 +2638,7 @@ and translate_forward_end (ectx : C.eval_ctx) We then remove all the meta information from the body *before* calling {!PureMicroPasses.decompose_loops}. *) - mk_meta_symbolic_assignments loop_info.input_vars org_args e + mk_emeta_symbolic_assignments loop_info.input_vars org_args e and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let loop_id = V.LoopId.Map.find loop.loop_id ctx.loop_ids_map in @@ -2795,6 +2796,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = { fun_end; loop_id; + meta = loop.meta; fuel0 = ctx.fuel0; fuel = ctx.fuel; input_state; @@ -2810,7 +2812,7 @@ and translate_loop (loop : S.loop) (ctx : bs_ctx) : texpression = let ty = fun_end.ty in { e = loop; ty } -and translate_meta (meta : S.meta) (e : S.expression) (ctx : bs_ctx) : +and translate_emeta (meta : S.emeta) (e : S.expression) (ctx : bs_ctx) : texpression = let next_e = translate_expression e ctx in let meta = @@ -3028,6 +3030,7 @@ let translate_fun_decl (ctx : bs_ctx) (body : S.expression option) : fun_decl = { def_id; is_local = def.is_local; + meta = def.meta; kind = def.kind; num_loops; loop_id; @@ -3108,6 +3111,7 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) def_id; is_local; name = llbc_name; + meta; generics; preds; parent_clauses; @@ -3145,6 +3149,7 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) is_local; llbc_name; name; + meta; generics; preds; parent_clauses; @@ -3160,6 +3165,7 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) A.def_id; is_local; name = llbc_name; + meta; impl_trait; generics; preds; @@ -3201,6 +3207,7 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) is_local; llbc_name; name; + meta; impl_trait; generics; preds; diff --git a/compiler/SynthesizeSymbolic.ml b/compiler/SynthesizeSymbolic.ml index 9e14a4d6..efcf001a 100644 --- a/compiler/SynthesizeSymbolic.ml +++ b/compiler/SynthesizeSymbolic.ml @@ -15,7 +15,7 @@ let mk_opt_place_from_op (op : operand) (ctx : Contexts.eval_ctx) : mplace option = match op with Copy p | Move p -> Some (mk_mplace p ctx) | Constant _ -> None -let mk_meta (m : meta) (e : expression) : expression = Meta (m, e) +let mk_emeta (m : emeta) (e : expression) : expression = Meta (m, e) let synthesize_symbolic_expansion (sv : symbolic_value) (place : mplace option) (seel : symbolic_expansion option list) (el : expression list option) : @@ -163,8 +163,8 @@ let synthesize_forward_end (ctx : Contexts.eval_ctx) let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) (fresh_svalues : SymbolicValueId.Set.t) (rg_to_given_back_tys : (RegionId.Set.t * ty list) RegionGroupId.Map.t) - (end_expr : expression option) (loop_expr : expression option) : - expression option = + (end_expr : expression option) (loop_expr : expression option) + (meta : Meta.meta) : expression option = match (end_expr, loop_expr) with | None, None -> None | Some end_expr, Some loop_expr -> @@ -177,5 +177,6 @@ let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) rg_to_given_back_tys; end_expr; loop_expr; + meta; }) | _ -> raise (Failure "Unreachable") -- cgit v1.2.3 From d564a010893653edea0df518e0b740fadf7df031 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 14:56:46 +0100 Subject: Make minor updates to the extraction of spans --- compiler/ExtractTypes.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 4dcefabc..3a81e6fe 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1816,11 +1816,12 @@ let extract_comment (fmt : F.formatter) (sl : string list) : unit = let extract_comment_with_span (fmt : F.formatter) (sl : string list) (span : Meta.span) : unit = let file = match span.file with Virtual s | Local s -> s in + let loc_to_string (l : Meta.loc) : string = + string_of_int l.line ^ ":" ^ string_of_int l.col + in let span = - "Source: '" ^ file ^ "': lines " - ^ string_of_int span.beg_loc.line - ^ "-" - ^ string_of_int span.end_loc.line + "Source: '" ^ file ^ "', lines " ^ loc_to_string span.beg_loc ^ "-" + ^ loc_to_string span.end_loc in extract_comment fmt (sl @ [ span ]) -- cgit v1.2.3 From 137cc7335e64fcb70c254e7fd2a6fa353fb43e61 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 14:57:38 +0100 Subject: Regenerate the files --- tests/coq/array/Array.v | 189 ++++++++++++------ tests/coq/betree/BetreeMain_Funs.v | 168 ++++++++++------ tests/coq/betree/BetreeMain_Opaque.v | 15 +- tests/coq/betree/BetreeMain_Types.v | 27 ++- tests/coq/hashmap/Hashmap_Funs.v | 114 +++++++---- tests/coq/hashmap/Hashmap_Types.v | 6 +- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 120 +++++++---- tests/coq/hashmap_on_disk/HashmapMain_Opaque.v | 6 +- tests/coq/hashmap_on_disk/HashmapMain_Types.v | 6 +- tests/coq/misc/Constants.v | 84 +++++--- tests/coq/misc/External_Funs.v | 27 ++- tests/coq/misc/External_Opaque.v | 15 +- tests/coq/misc/External_Types.v | 3 +- tests/coq/misc/Loops.v | 186 +++++++++++------ tests/coq/misc/NoNestedBorrows.v | 207 ++++++++++++------- tests/coq/misc/Paper.v | 33 ++-- tests/coq/misc/PoloniusList.v | 9 +- tests/coq/traits/Traits.v | 219 ++++++++++++++------- tests/fstar/array/Array.Clauses.Template.fst | 6 +- tests/fstar/array/Array.Funs.fst | 186 +++++++++++------ tests/fstar/array/Array.Types.fst | 3 +- tests/fstar/betree/BetreeMain.Clauses.Template.fst | 45 +++-- tests/fstar/betree/BetreeMain.Funs.fst | 168 ++++++++++------ tests/fstar/betree/BetreeMain.Opaque.fsti | 15 +- tests/fstar/betree/BetreeMain.Types.fsti | 27 ++- .../BetreeMain.Clauses.Template.fst | 45 +++-- .../fstar/betree_back_stateful/BetreeMain.Funs.fst | 183 +++++++++++------ .../betree_back_stateful/BetreeMain.Opaque.fsti | 15 +- .../betree_back_stateful/BetreeMain.Types.fsti | 27 ++- tests/fstar/hashmap/Hashmap.Clauses.Template.fst | 27 ++- tests/fstar/hashmap/Hashmap.Funs.fst | 114 +++++++---- tests/fstar/hashmap/Hashmap.Types.fst | 6 +- .../HashmapMain.Clauses.Template.fst | 27 ++- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 120 +++++++---- .../fstar/hashmap_on_disk/HashmapMain.Opaque.fsti | 6 +- tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti | 6 +- tests/fstar/misc/Constants.fst | 84 +++++--- tests/fstar/misc/External.Funs.fst | 27 ++- tests/fstar/misc/External.Opaque.fsti | 15 +- tests/fstar/misc/External.Types.fsti | 3 +- tests/fstar/misc/Loops.Clauses.Template.fst | 57 ++++-- tests/fstar/misc/Loops.Funs.fst | 183 +++++++++++------ tests/fstar/misc/Loops.Types.fst | 3 +- tests/fstar/misc/NoNestedBorrows.fst | 207 ++++++++++++------- tests/fstar/misc/Paper.fst | 33 ++-- tests/fstar/misc/PoloniusList.fst | 9 +- tests/fstar/traits/Traits.fst | 219 ++++++++++++++------- tests/lean/Array.lean | 189 ++++++++++++------ tests/lean/BetreeMain/Funs.lean | 168 ++++++++++------ tests/lean/BetreeMain/FunsExternal_Template.lean | 15 +- tests/lean/BetreeMain/Types.lean | 27 ++- tests/lean/Constants.lean | 84 +++++--- tests/lean/External/Funs.lean | 27 ++- tests/lean/External/FunsExternal_Template.lean | 15 +- tests/lean/External/Types.lean | 3 +- tests/lean/Hashmap/Funs.lean | 114 +++++++---- tests/lean/Hashmap/Types.lean | 6 +- tests/lean/HashmapMain/Funs.lean | 120 +++++++---- tests/lean/HashmapMain/FunsExternal_Template.lean | 6 +- tests/lean/HashmapMain/Types.lean | 6 +- tests/lean/Loops.lean | 186 +++++++++++------ tests/lean/NoNestedBorrows.lean | 207 ++++++++++++------- tests/lean/Paper.lean | 33 ++-- tests/lean/PoloniusList.lean | 9 +- tests/lean/Traits.lean | 219 ++++++++++++++------- 65 files changed, 3156 insertions(+), 1578 deletions(-) diff --git a/tests/coq/array/Array.v b/tests/coq/array/Array.v index 256ccd1c..99ff3b03 100644 --- a/tests/coq/array/Array.v +++ b/tests/coq/array/Array.v @@ -8,27 +8,32 @@ Import ListNotations. Local Open Scope Primitives_scope. Module Array. -(** [array::AB] *) +(** [array::AB] + Source: 'src/array.rs', lines 3:0-3:11 *) Inductive AB_t := | AB_A : AB_t | AB_B : AB_t. (** [array::incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 8:0-8:24 *) Definition incr (x : u32) : result u32 := u32_add x 1%u32. -(** [array::array_to_shared_slice_]: forward function *) +(** [array::array_to_shared_slice_]: forward function + Source: 'src/array.rs', lines 16:0-16:53 *) Definition array_to_shared_slice_ (T : Type) (s : array T 32%usize) : result (slice T) := array_to_slice T 32%usize s . -(** [array::array_to_mut_slice_]: forward function *) +(** [array::array_to_mut_slice_]: forward function + Source: 'src/array.rs', lines 21:0-21:58 *) Definition array_to_mut_slice_ (T : Type) (s : array T 32%usize) : result (slice T) := array_to_slice T 32%usize s . -(** [array::array_to_mut_slice_]: backward function 0 *) +(** [array::array_to_mut_slice_]: backward function 0 + Source: 'src/array.rs', lines 21:0-21:58 *) Definition array_to_mut_slice__back (T : Type) (s : array T 32%usize) (ret : slice T) : result (array T 32%usize) @@ -36,44 +41,52 @@ Definition array_to_mut_slice__back array_from_slice T 32%usize s ret . -(** [array::array_len]: forward function *) +(** [array::array_len]: forward function + Source: 'src/array.rs', lines 25:0-25:40 *) Definition array_len (T : Type) (s : array T 32%usize) : result usize := s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i . -(** [array::shared_array_len]: forward function *) +(** [array::shared_array_len]: forward function + Source: 'src/array.rs', lines 29:0-29:48 *) Definition shared_array_len (T : Type) (s : array T 32%usize) : result usize := s0 <- array_to_slice T 32%usize s; let i := slice_len T s0 in Return i . -(** [array::shared_slice_len]: forward function *) +(** [array::shared_slice_len]: forward function + Source: 'src/array.rs', lines 33:0-33:44 *) Definition shared_slice_len (T : Type) (s : slice T) : result usize := let i := slice_len T s in Return i . -(** [array::index_array_shared]: forward function *) +(** [array::index_array_shared]: forward function + Source: 'src/array.rs', lines 37:0-37:57 *) Definition index_array_shared (T : Type) (s : array T 32%usize) (i : usize) : result T := array_index_usize T 32%usize s i . -(** [array::index_array_u32]: forward function *) +(** [array::index_array_u32]: forward function + Source: 'src/array.rs', lines 44:0-44:53 *) Definition index_array_u32 (s : array u32 32%usize) (i : usize) : result u32 := array_index_usize u32 32%usize s i . -(** [array::index_array_copy]: forward function *) +(** [array::index_array_copy]: forward function + Source: 'src/array.rs', lines 48:0-48:45 *) Definition index_array_copy (x : array u32 32%usize) : result u32 := array_index_usize u32 32%usize x 0%usize . -(** [array::index_mut_array]: forward function *) +(** [array::index_mut_array]: forward function + Source: 'src/array.rs', lines 52:0-52:62 *) Definition index_mut_array (T : Type) (s : array T 32%usize) (i : usize) : result T := array_index_usize T 32%usize s i . -(** [array::index_mut_array]: backward function 0 *) +(** [array::index_mut_array]: backward function 0 + Source: 'src/array.rs', lines 52:0-52:62 *) Definition index_mut_array_back (T : Type) (s : array T 32%usize) (i : usize) (ret : T) : result (array T 32%usize) @@ -81,23 +94,27 @@ Definition index_mut_array_back array_update_usize T 32%usize s i ret . -(** [array::index_slice]: forward function *) +(** [array::index_slice]: forward function + Source: 'src/array.rs', lines 56:0-56:46 *) Definition index_slice (T : Type) (s : slice T) (i : usize) : result T := slice_index_usize T s i . -(** [array::index_mut_slice]: forward function *) +(** [array::index_mut_slice]: forward function + Source: 'src/array.rs', lines 60:0-60:58 *) Definition index_mut_slice (T : Type) (s : slice T) (i : usize) : result T := slice_index_usize T s i . -(** [array::index_mut_slice]: backward function 0 *) +(** [array::index_mut_slice]: backward function 0 + Source: 'src/array.rs', lines 60:0-60:58 *) Definition index_mut_slice_back (T : Type) (s : slice T) (i : usize) (ret : T) : result (slice T) := slice_update_usize T s i ret . -(** [array::slice_subslice_shared_]: forward function *) +(** [array::slice_subslice_shared_]: forward function + Source: 'src/array.rs', lines 64:0-64:70 *) Definition slice_subslice_shared_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) := core_slice_index_Slice_index u32 (core_ops_range_Range usize) @@ -105,7 +122,8 @@ Definition slice_subslice_shared_ {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . -(** [array::slice_subslice_mut_]: forward function *) +(** [array::slice_subslice_mut_]: forward function + Source: 'src/array.rs', lines 68:0-68:75 *) Definition slice_subslice_mut_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) := core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) @@ -113,7 +131,8 @@ Definition slice_subslice_mut_ {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . -(** [array::slice_subslice_mut_]: backward function 0 *) +(** [array::slice_subslice_mut_]: backward function 0 + Source: 'src/array.rs', lines 68:0-68:75 *) Definition slice_subslice_mut__back (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : result (slice u32) @@ -123,24 +142,28 @@ Definition slice_subslice_mut__back {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret . -(** [array::array_to_slice_shared_]: forward function *) +(** [array::array_to_slice_shared_]: forward function + Source: 'src/array.rs', lines 72:0-72:54 *) Definition array_to_slice_shared_ (x : array u32 32%usize) : result (slice u32) := array_to_slice u32 32%usize x . -(** [array::array_to_slice_mut_]: forward function *) +(** [array::array_to_slice_mut_]: forward function + Source: 'src/array.rs', lines 76:0-76:59 *) Definition array_to_slice_mut_ (x : array u32 32%usize) : result (slice u32) := array_to_slice u32 32%usize x . -(** [array::array_to_slice_mut_]: backward function 0 *) +(** [array::array_to_slice_mut_]: backward function 0 + Source: 'src/array.rs', lines 76:0-76:59 *) Definition array_to_slice_mut__back (x : array u32 32%usize) (ret : slice u32) : result (array u32 32%usize) := array_from_slice u32 32%usize x ret . -(** [array::array_subslice_shared_]: forward function *) +(** [array::array_subslice_shared_]: forward function + Source: 'src/array.rs', lines 80:0-80:74 *) Definition array_subslice_shared_ (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index u32 (core_ops_range_Range usize) 32%usize @@ -149,7 +172,8 @@ Definition array_subslice_shared_ {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . -(** [array::array_subslice_mut_]: forward function *) +(** [array::array_subslice_mut_]: forward function + Source: 'src/array.rs', lines 84:0-84:79 *) Definition array_subslice_mut_ (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index_mut u32 (core_ops_range_Range usize) 32%usize @@ -158,7 +182,8 @@ Definition array_subslice_mut_ {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . -(** [array::array_subslice_mut_]: backward function 0 *) +(** [array::array_subslice_mut_]: backward function 0 + Source: 'src/array.rs', lines 84:0-84:79 *) Definition array_subslice_mut__back (x : array u32 32%usize) (y : usize) (z : usize) (ret : slice u32) : result (array u32 32%usize) @@ -169,17 +194,20 @@ Definition array_subslice_mut__back {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} ret . -(** [array::index_slice_0]: forward function *) +(** [array::index_slice_0]: forward function + Source: 'src/array.rs', lines 88:0-88:38 *) Definition index_slice_0 (T : Type) (s : slice T) : result T := slice_index_usize T s 0%usize . -(** [array::index_array_0]: forward function *) +(** [array::index_array_0]: forward function + Source: 'src/array.rs', lines 92:0-92:42 *) Definition index_array_0 (T : Type) (s : array T 32%usize) : result T := array_index_usize T 32%usize s 0%usize . -(** [array::index_index_array]: forward function *) +(** [array::index_index_array]: forward function + Source: 'src/array.rs', lines 103:0-103:71 *) Definition index_index_array (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : result u32 @@ -188,7 +216,8 @@ Definition index_index_array array_index_usize u32 32%usize a j . -(** [array::update_update_array]: forward function *) +(** [array::update_update_array]: forward function + Source: 'src/array.rs', lines 114:0-114:70 *) Definition update_update_array (s : array (array u32 32%usize) 32%usize) (i : usize) (j : usize) : result unit @@ -199,30 +228,36 @@ Definition update_update_array Return tt . -(** [array::array_local_deep_copy]: forward function *) +(** [array::array_local_deep_copy]: forward function + Source: 'src/array.rs', lines 118:0-118:43 *) Definition array_local_deep_copy (x : array u32 32%usize) : result unit := Return tt . -(** [array::take_array]: forward function *) +(** [array::take_array]: forward function + Source: 'src/array.rs', lines 122:0-122:30 *) Definition take_array (a : array u32 2%usize) : result unit := Return tt. -(** [array::take_array_borrow]: forward function *) +(** [array::take_array_borrow]: forward function + Source: 'src/array.rs', lines 123:0-123:38 *) Definition take_array_borrow (a : array u32 2%usize) : result unit := Return tt . -(** [array::take_slice]: forward function *) +(** [array::take_slice]: forward function + Source: 'src/array.rs', lines 124:0-124:28 *) Definition take_slice (s : slice u32) : result unit := Return tt. (** [array::take_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 125:0-125:36 *) Definition take_mut_slice (s : slice u32) : result (slice u32) := Return s. -(** [array::take_all]: forward function *) +(** [array::take_all]: forward function + Source: 'src/array.rs', lines 127:0-127:17 *) Definition take_all : result unit := _ <- take_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); _ <- take_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); @@ -234,32 +269,38 @@ Definition take_all : result unit := Return tt . -(** [array::index_array]: forward function *) +(** [array::index_array]: forward function + Source: 'src/array.rs', lines 141:0-141:38 *) Definition index_array (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . -(** [array::index_array_borrow]: forward function *) +(** [array::index_array_borrow]: forward function + Source: 'src/array.rs', lines 144:0-144:46 *) Definition index_array_borrow (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . -(** [array::index_slice_u32_0]: forward function *) +(** [array::index_slice_u32_0]: forward function + Source: 'src/array.rs', lines 148:0-148:42 *) Definition index_slice_u32_0 (x : slice u32) : result u32 := slice_index_usize u32 x 0%usize . -(** [array::index_mut_slice_u32_0]: forward function *) +(** [array::index_mut_slice_u32_0]: forward function + Source: 'src/array.rs', lines 152:0-152:50 *) Definition index_mut_slice_u32_0 (x : slice u32) : result u32 := slice_index_usize u32 x 0%usize . -(** [array::index_mut_slice_u32_0]: backward function 0 *) +(** [array::index_mut_slice_u32_0]: backward function 0 + Source: 'src/array.rs', lines 152:0-152:50 *) Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := _ <- slice_index_usize u32 x 0%usize; Return x . -(** [array::index_all]: forward function *) +(** [array::index_all]: forward function + Source: 'src/array.rs', lines 156:0-156:25 *) Definition index_all : result u32 := i <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); i0 <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); @@ -277,25 +318,29 @@ Definition index_all : result u32 := Return i7 . -(** [array::update_array]: forward function *) +(** [array::update_array]: forward function + Source: 'src/array.rs', lines 170:0-170:36 *) Definition update_array (x : array u32 2%usize) : result unit := _ <- array_update_usize u32 2%usize x 0%usize 1%u32; Return tt . (** [array::update_array_mut_borrow]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 173:0-173:48 *) Definition update_array_mut_borrow (x : array u32 2%usize) : result (array u32 2%usize) := array_update_usize u32 2%usize x 0%usize 1%u32 . (** [array::update_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 176:0-176:38 *) Definition update_mut_slice (x : slice u32) : result (slice u32) := slice_update_usize u32 x 0%usize 1%u32 . -(** [array::update_all]: forward function *) +(** [array::update_all]: forward function + Source: 'src/array.rs', lines 180:0-180:19 *) Definition update_all : result unit := _ <- update_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); x <- update_array_mut_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); @@ -305,7 +350,8 @@ Definition update_all : result unit := Return tt . -(** [array::range_all]: forward function *) +(** [array::range_all]: forward function + Source: 'src/array.rs', lines 191:0-191:18 *) Definition range_all : result unit := s <- core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize @@ -329,32 +375,38 @@ Definition range_all : result unit := Return tt . -(** [array::deref_array_borrow]: forward function *) +(** [array::deref_array_borrow]: forward function + Source: 'src/array.rs', lines 200:0-200:46 *) Definition deref_array_borrow (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . -(** [array::deref_array_mut_borrow]: forward function *) +(** [array::deref_array_mut_borrow]: forward function + Source: 'src/array.rs', lines 205:0-205:54 *) Definition deref_array_mut_borrow (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . -(** [array::deref_array_mut_borrow]: backward function 0 *) +(** [array::deref_array_mut_borrow]: backward function 0 + Source: 'src/array.rs', lines 205:0-205:54 *) Definition deref_array_mut_borrow_back (x : array u32 2%usize) : result (array u32 2%usize) := _ <- array_index_usize u32 2%usize x 0%usize; Return x . -(** [array::take_array_t]: forward function *) +(** [array::take_array_t]: forward function + Source: 'src/array.rs', lines 213:0-213:31 *) Definition take_array_t (a : array AB_t 2%usize) : result unit := Return tt. -(** [array::non_copyable_array]: forward function *) +(** [array::non_copyable_array]: forward function + Source: 'src/array.rs', lines 215:0-215:27 *) Definition non_copyable_array : result unit := _ <- take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]); Return tt . -(** [array::sum]: loop 0: forward function *) +(** [array::sum]: loop 0: forward function + Source: 'src/array.rs', lines 228:0-236:1 *) Fixpoint sum_loop (n : nat) (s : slice u32) (sum0 : u32) (i : usize) : result u32 := match n with @@ -371,12 +423,14 @@ Fixpoint sum_loop end . -(** [array::sum]: forward function *) +(** [array::sum]: forward function + Source: 'src/array.rs', lines 228:0-228:28 *) Definition sum (n : nat) (s : slice u32) : result u32 := sum_loop n s 0%u32 0%usize . -(** [array::sum2]: loop 0: forward function *) +(** [array::sum2]: loop 0: forward function + Source: 'src/array.rs', lines 238:0-247:1 *) Fixpoint sum2_loop (n : nat) (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : result u32 @@ -397,14 +451,16 @@ Fixpoint sum2_loop end . -(** [array::sum2]: forward function *) +(** [array::sum2]: forward function + Source: 'src/array.rs', lines 238:0-238:41 *) Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := let i := slice_len u32 s in let i0 := slice_len u32 s2 in if negb (i s= i0) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize . -(** [array::f0]: forward function *) +(** [array::f0]: forward function + Source: 'src/array.rs', lines 249:0-249:11 *) Definition f0 : result unit := s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); s0 <- slice_update_usize u32 s 0%usize 1%u32; @@ -412,7 +468,8 @@ Definition f0 : result unit := Return tt . -(** [array::f1]: forward function *) +(** [array::f1]: forward function + Source: 'src/array.rs', lines 254:0-254:11 *) Definition f1 : result unit := _ <- array_update_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) @@ -420,11 +477,13 @@ Definition f1 : result unit := Return tt . -(** [array::f2]: forward function *) +(** [array::f2]: forward function + Source: 'src/array.rs', lines 259:0-259:17 *) Definition f2 (i : u32) : result unit := Return tt. -(** [array::f4]: forward function *) +(** [array::f4]: forward function + Source: 'src/array.rs', lines 268:0-268:54 *) Definition f4 (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index u32 (core_ops_range_Range usize) 32%usize @@ -433,7 +492,8 @@ Definition f4 {| core_ops_range_Range_start := y; core_ops_range_Range_end_ := z |} . -(** [array::f3]: forward function *) +(** [array::f3]: forward function + Source: 'src/array.rs', lines 261:0-261:18 *) Definition f3 (n : nat) : result u32 := i <- array_index_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) @@ -445,16 +505,19 @@ Definition f3 (n : nat) : result u32 := sum2 n s s0 . -(** [array::SZ] *) +(** [array::SZ] + Source: 'src/array.rs', lines 272:0-272:19 *) Definition sz_body : result usize := Return 32%usize. Definition sz_c : usize := sz_body%global. -(** [array::f5]: forward function *) +(** [array::f5]: forward function + Source: 'src/array.rs', lines 275:0-275:31 *) Definition f5 (x : array u32 32%usize) : result u32 := array_index_usize u32 32%usize x 0%usize . -(** [array::ite]: forward function *) +(** [array::ite]: forward function + Source: 'src/array.rs', lines 280:0-280:12 *) Definition ite : result unit := s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index d7428744..8e48b17d 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -12,7 +12,8 @@ Require Export BetreeMain_Opaque. Import BetreeMain_Opaque. Module BetreeMain_Funs. -(** [betree_main::betree::load_internal_node]: forward function *) +(** [betree_main::betree::load_internal_node]: forward function + Source: 'src/betree.rs', lines 36:0-36:52 *) Definition betree_load_internal_node (id : u64) (st : state) : result (state * (betree_List_t (u64 * betree_Message_t))) @@ -20,7 +21,8 @@ Definition betree_load_internal_node betree_utils_load_internal_node id st . -(** [betree_main::betree::store_internal_node]: forward function *) +(** [betree_main::betree::store_internal_node]: forward function + Source: 'src/betree.rs', lines 41:0-41:60 *) Definition betree_store_internal_node (id : u64) (content : betree_List_t (u64 * betree_Message_t)) (st : state) : result (state * unit) @@ -30,13 +32,15 @@ Definition betree_store_internal_node Return (st0, tt) . -(** [betree_main::betree::load_leaf_node]: forward function *) +(** [betree_main::betree::load_leaf_node]: forward function + Source: 'src/betree.rs', lines 46:0-46:44 *) Definition betree_load_leaf_node (id : u64) (st : state) : result (state * (betree_List_t (u64 * u64))) := betree_utils_load_leaf_node id st . -(** [betree_main::betree::store_leaf_node]: forward function *) +(** [betree_main::betree::store_leaf_node]: forward function + Source: 'src/betree.rs', lines 51:0-51:52 *) Definition betree_store_leaf_node (id : u64) (content : betree_List_t (u64 * u64)) (st : state) : result (state * unit) @@ -46,36 +50,42 @@ Definition betree_store_leaf_node Return (st0, tt) . -(** [betree_main::betree::fresh_node_id]: forward function *) +(** [betree_main::betree::fresh_node_id]: forward function + Source: 'src/betree.rs', lines 55:0-55:48 *) Definition betree_fresh_node_id (counter : u64) : result u64 := _ <- u64_add counter 1%u64; Return counter . -(** [betree_main::betree::fresh_node_id]: backward function 0 *) +(** [betree_main::betree::fresh_node_id]: backward function 0 + Source: 'src/betree.rs', lines 55:0-55:48 *) Definition betree_fresh_node_id_back (counter : u64) : result u64 := u64_add counter 1%u64 . -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function + Source: 'src/betree.rs', lines 206:4-206:20 *) Definition betree_NodeIdCounter_new : result betree_NodeIdCounter_t := Return {| betree_NodeIdCounter_next_node_id := 0%u64 |} . -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function + Source: 'src/betree.rs', lines 210:4-210:36 *) Definition betree_NodeIdCounter_fresh_id (self : betree_NodeIdCounter_t) : result u64 := _ <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; Return self.(betree_NodeIdCounter_next_node_id) . -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 + Source: 'src/betree.rs', lines 210:4-210:36 *) Definition betree_NodeIdCounter_fresh_id_back (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t := i <- u64_add self.(betree_NodeIdCounter_next_node_id) 1%u64; Return {| betree_NodeIdCounter_next_node_id := i |} . -(** [betree_main::betree::upsert_update]: forward function *) +(** [betree_main::betree::upsert_update]: forward function + Source: 'src/betree.rs', lines 234:0-234:70 *) Definition betree_upsert_update (prev : option u64) (st : betree_UpsertFunState_t) : result u64 := match prev with @@ -95,7 +105,8 @@ Definition betree_upsert_update end . -(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function + Source: 'src/betree.rs', lines 276:4-276:24 *) Fixpoint betree_List_len (T : Type) (n : nat) (self : betree_List_t T) : result u64 := match n with @@ -108,7 +119,8 @@ Fixpoint betree_List_len end . -(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function + Source: 'src/betree.rs', lines 284:4-284:51 *) Fixpoint betree_List_split_at (T : Type) (n : nat) (self : betree_List_t T) (n0 : u64) : result ((betree_List_t T) * (betree_List_t T)) @@ -132,7 +144,8 @@ Fixpoint betree_List_split_at . (** [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 299:4-299:34 *) Definition betree_List_push_front (T : Type) (self : betree_List_t T) (x : T) : result (betree_List_t T) := let tl := core_mem_replace (betree_List_t T) self Betree_List_Nil in @@ -140,7 +153,8 @@ Definition betree_List_push_front Return (Betree_List_Cons x l) . -(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function + Source: 'src/betree.rs', lines 306:4-306:32 *) Definition betree_List_pop_front (T : Type) (self : betree_List_t T) : result T := let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in @@ -150,7 +164,8 @@ Definition betree_List_pop_front end . -(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 + Source: 'src/betree.rs', lines 306:4-306:32 *) Definition betree_List_pop_front_back (T : Type) (self : betree_List_t T) : result (betree_List_t T) := let ls := core_mem_replace (betree_List_t T) self Betree_List_Nil in @@ -160,7 +175,8 @@ Definition betree_List_pop_front_back end . -(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function + Source: 'src/betree.rs', lines 318:4-318:22 *) Definition betree_List_hd (T : Type) (self : betree_List_t T) : result T := match self with | Betree_List_Cons hd l => Return hd @@ -168,7 +184,8 @@ Definition betree_List_hd (T : Type) (self : betree_List_t T) : result T := end . -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function + Source: 'src/betree.rs', lines 327:4-327:44 *) Definition betree_ListTupleU64T_head_has_key (T : Type) (self : betree_List_t (u64 * T)) (key : u64) : result bool := match self with @@ -177,7 +194,8 @@ Definition betree_ListTupleU64T_head_has_key end . -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function + Source: 'src/betree.rs', lines 339:4-339:73 *) Fixpoint betree_ListTupleU64T_partition_at_pivot (T : Type) (n : nat) (self : betree_List_t (u64 * T)) (pivot : u64) : result ((betree_List_t (u64 * T)) * (betree_List_t (u64 * T))) @@ -200,7 +218,8 @@ Fixpoint betree_ListTupleU64T_partition_at_pivot end . -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function + Source: 'src/betree.rs', lines 359:4-364:17 *) Definition betree_Leaf_split (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -233,7 +252,8 @@ Definition betree_Leaf_split Return (st1, mkbetree_Internal_t self.(betree_Leaf_id) pivot n0 n1) . -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 + Source: 'src/betree.rs', lines 359:4-364:17 *) Definition betree_Leaf_split_back (n : nat) (self : betree_Leaf_t) (content : betree_List_t (u64 * u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -254,7 +274,8 @@ Definition betree_Leaf_split_back betree_NodeIdCounter_fresh_id_back node_id_cnt0 . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function + Source: 'src/betree.rs', lines 789:4-792:34 *) Fixpoint betree_Node_lookup_first_message_for_key (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : result (betree_List_t (u64 * betree_Message_t)) @@ -273,7 +294,8 @@ Fixpoint betree_Node_lookup_first_message_for_key end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 + Source: 'src/betree.rs', lines 789:4-792:34 *) Fixpoint betree_Node_lookup_first_message_for_key_back (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) (ret : betree_List_t (u64 * betree_Message_t)) : @@ -296,7 +318,8 @@ Fixpoint betree_Node_lookup_first_message_for_key_back end . -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function + Source: 'src/betree.rs', lines 819:4-819:90 *) Fixpoint betree_Node_apply_upserts (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -328,7 +351,8 @@ Fixpoint betree_Node_apply_upserts end . -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 + Source: 'src/betree.rs', lines 819:4-819:90 *) Fixpoint betree_Node_apply_upserts_back (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -358,7 +382,8 @@ Fixpoint betree_Node_apply_upserts_back end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 *) Fixpoint betree_Node_lookup_in_bindings (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : result (option u64) @@ -380,7 +405,8 @@ Fixpoint betree_Node_lookup_in_bindings end . -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function + Source: 'src/betree.rs', lines 395:4-395:63 *) Fixpoint betree_Internal_lookup_in_children (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : result (state * (option u64)) @@ -393,7 +419,8 @@ Fixpoint betree_Internal_lookup_in_children else betree_Node_lookup n0 self.(betree_Internal_right) key st end -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 + Source: 'src/betree.rs', lines 395:4-395:63 *) with betree_Internal_lookup_in_children_back (n : nat) (self : betree_Internal_t) (key : u64) (st : state) : result betree_Internal_t @@ -412,7 +439,8 @@ with betree_Internal_lookup_in_children_back self.(betree_Internal_pivot) self.(betree_Internal_left) n1)) end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function + Source: 'src/betree.rs', lines 709:4-709:58 *) with betree_Node_lookup (n : nat) (self : betree_Node_t) (key : u64) (st : state) : result (state * (option u64)) @@ -483,7 +511,8 @@ with betree_Node_lookup end end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 709:4-709:58 *) with betree_Node_lookup_back (n : nat) (self : betree_Node_t) (key : u64) (st : state) : result betree_Node_t @@ -553,7 +582,8 @@ with betree_Node_lookup_back . (** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 674:4-674:77 *) Fixpoint betree_Node_filter_messages_for_key (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : result (betree_List_t (u64 * betree_Message_t)) @@ -576,7 +606,8 @@ Fixpoint betree_Node_filter_messages_for_key end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function + Source: 'src/betree.rs', lines 689:4-692:34 *) Fixpoint betree_Node_lookup_first_message_after_key (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) : result (betree_List_t (u64 * betree_Message_t)) @@ -595,7 +626,8 @@ Fixpoint betree_Node_lookup_first_message_after_key end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 + Source: 'src/betree.rs', lines 689:4-692:34 *) Fixpoint betree_Node_lookup_first_message_after_key_back (n : nat) (key : u64) (msgs : betree_List_t (u64 * betree_Message_t)) (ret : betree_List_t (u64 * betree_Message_t)) : @@ -619,7 +651,8 @@ Fixpoint betree_Node_lookup_first_message_after_key_back . (** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 521:4-521:89 *) Definition betree_Node_apply_to_internal (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (key : u64) (new_msg : betree_Message_t) : @@ -677,7 +710,8 @@ Definition betree_Node_apply_to_internal . (** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 502:4-505:5 *) Fixpoint betree_Node_apply_messages_to_internal (n : nat) (msgs : betree_List_t (u64 * betree_Message_t)) (new_msgs : betree_List_t (u64 * betree_Message_t)) : @@ -696,7 +730,8 @@ Fixpoint betree_Node_apply_messages_to_internal end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function + Source: 'src/betree.rs', lines 653:4-656:32 *) Fixpoint betree_Node_lookup_mut_in_bindings (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : result (betree_List_t (u64 * u64)) @@ -715,7 +750,8 @@ Fixpoint betree_Node_lookup_mut_in_bindings end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 + Source: 'src/betree.rs', lines 653:4-656:32 *) Fixpoint betree_Node_lookup_mut_in_bindings_back (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) (ret : betree_List_t (u64 * u64)) : @@ -738,7 +774,8 @@ Fixpoint betree_Node_lookup_mut_in_bindings_back . (** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 460:4-460:87 *) Definition betree_Node_apply_to_leaf (n : nat) (bindings : betree_List_t (u64 * u64)) (key : u64) (new_msg : betree_Message_t) : @@ -779,7 +816,8 @@ Definition betree_Node_apply_to_leaf . (** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 444:4-447:5 *) Fixpoint betree_Node_apply_messages_to_leaf (n : nat) (bindings : betree_List_t (u64 * u64)) (new_msgs : betree_List_t (u64 * betree_Message_t)) : @@ -798,7 +836,8 @@ Fixpoint betree_Node_apply_messages_to_leaf end . -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function + Source: 'src/betree.rs', lines 410:4-415:26 *) Fixpoint betree_Internal_flush (n : nat) (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -846,7 +885,8 @@ Fixpoint betree_Internal_flush Return (st0, msgs_left)) end -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 + Source: 'src/betree.rs', lines 410:4-415:26 *) with betree_Internal_flush_back (n : nat) (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -894,7 +934,8 @@ with betree_Internal_flush_back node_id_cnt0)) end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function + Source: 'src/betree.rs', lines 588:4-593:5 *) with betree_Node_apply_messages (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -946,7 +987,8 @@ with betree_Node_apply_messages end end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 + Source: 'src/betree.rs', lines 588:4-593:5 *) with betree_Node_apply_messages_back (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -998,7 +1040,8 @@ with betree_Node_apply_messages_back end . -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function + Source: 'src/betree.rs', lines 576:4-582:5 *) Definition betree_Node_apply (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1016,7 +1059,8 @@ Definition betree_Node_apply Return (st0, tt) . -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 + Source: 'src/betree.rs', lines 576:4-582:5 *) Definition betree_Node_apply_back (n : nat) (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1028,7 +1072,8 @@ Definition betree_Node_apply_back (key, new_msg) l) st . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function + Source: 'src/betree.rs', lines 849:4-849:60 *) Definition betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : result (state * betree_BeTree_t) @@ -1052,7 +1097,8 @@ Definition betree_BeTree_new |}) . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function + Source: 'src/betree.rs', lines 868:4-868:47 *) Definition betree_BeTree_apply (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : @@ -1068,7 +1114,8 @@ Definition betree_BeTree_apply Return (st0, tt) . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 + Source: 'src/betree.rs', lines 868:4-868:47 *) Definition betree_BeTree_apply_back (n : nat) (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : @@ -1086,7 +1133,8 @@ Definition betree_BeTree_apply_back |} . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function + Source: 'src/betree.rs', lines 874:4-874:52 *) Definition betree_BeTree_insert (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state * unit) @@ -1097,7 +1145,8 @@ Definition betree_BeTree_insert Return (st0, tt) . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 + Source: 'src/betree.rs', lines 874:4-874:52 *) Definition betree_BeTree_insert_back (n : nat) (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result betree_BeTree_t @@ -1105,7 +1154,8 @@ Definition betree_BeTree_insert_back betree_BeTree_apply_back n self key (Betree_Message_Insert value) st . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function + Source: 'src/betree.rs', lines 880:4-880:38 *) Definition betree_BeTree_delete (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * unit) @@ -1116,7 +1166,8 @@ Definition betree_BeTree_delete Return (st0, tt) . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 + Source: 'src/betree.rs', lines 880:4-880:38 *) Definition betree_BeTree_delete_back (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t @@ -1124,7 +1175,8 @@ Definition betree_BeTree_delete_back betree_BeTree_apply_back n self key Betree_Message_Delete st . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function + Source: 'src/betree.rs', lines 886:4-886:59 *) Definition betree_BeTree_upsert (n : nat) (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -1136,7 +1188,8 @@ Definition betree_BeTree_upsert Return (st0, tt) . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 + Source: 'src/betree.rs', lines 886:4-886:59 *) Definition betree_BeTree_upsert_back (n : nat) (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -1145,7 +1198,8 @@ Definition betree_BeTree_upsert_back betree_BeTree_apply_back n self key (Betree_Message_Upsert upd) st . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function + Source: 'src/betree.rs', lines 895:4-895:62 *) Definition betree_BeTree_lookup (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result (state * (option u64)) @@ -1153,7 +1207,8 @@ Definition betree_BeTree_lookup betree_Node_lookup n self.(betree_BeTree_root) key st . -(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 895:4-895:62 *) Definition betree_BeTree_lookup_back (n : nat) (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t @@ -1167,7 +1222,8 @@ Definition betree_BeTree_lookup_back |} . -(** [betree_main::main]: forward function *) +(** [betree_main::main]: forward function + Source: 'src/betree_main.rs', lines 5:0-5:9 *) Definition main : result unit := Return tt. diff --git a/tests/coq/betree/BetreeMain_Opaque.v b/tests/coq/betree/BetreeMain_Opaque.v index bb798e71..a065c8a3 100644 --- a/tests/coq/betree/BetreeMain_Opaque.v +++ b/tests/coq/betree/BetreeMain_Opaque.v @@ -10,29 +10,34 @@ Require Export BetreeMain_Types. Import BetreeMain_Types. Module BetreeMain_Opaque. -(** [betree_main::betree_utils::load_internal_node]: forward function *) +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) Axiom betree_utils_load_internal_node : u64 -> state -> result (state * (betree_List_t (u64 * betree_Message_t))) . -(** [betree_main::betree_utils::store_internal_node]: forward function *) +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) Axiom betree_utils_store_internal_node : u64 -> betree_List_t (u64 * betree_Message_t) -> state -> result (state * unit) . -(** [betree_main::betree_utils::load_leaf_node]: forward function *) +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) Axiom betree_utils_load_leaf_node : u64 -> state -> result (state * (betree_List_t (u64 * u64))) . -(** [betree_main::betree_utils::store_leaf_node]: forward function *) +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) Axiom betree_utils_store_leaf_node : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) . -(** [core::option::{core::option::Option}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/betree/BetreeMain_Types.v b/tests/coq/betree/BetreeMain_Types.v index 933a670c..b729d1c3 100644 --- a/tests/coq/betree/BetreeMain_Types.v +++ b/tests/coq/betree/BetreeMain_Types.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module BetreeMain_Types. -(** [betree_main::betree::List] *) +(** [betree_main::betree::List] + Source: 'src/betree.rs', lines 17:0-17:23 *) Inductive betree_List_t (T : Type) := | Betree_List_Cons : T -> betree_List_t T -> betree_List_t T | Betree_List_Nil : betree_List_t T @@ -17,27 +18,31 @@ Inductive betree_List_t (T : Type) := Arguments Betree_List_Cons { _ }. Arguments Betree_List_Nil { _ }. -(** [betree_main::betree::UpsertFunState] *) +(** [betree_main::betree::UpsertFunState] + Source: 'src/betree.rs', lines 63:0-63:23 *) Inductive betree_UpsertFunState_t := | Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t | Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t . -(** [betree_main::betree::Message] *) +(** [betree_main::betree::Message] + Source: 'src/betree.rs', lines 69:0-69:23 *) Inductive betree_Message_t := | Betree_Message_Insert : u64 -> betree_Message_t | Betree_Message_Delete : betree_Message_t | Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t . -(** [betree_main::betree::Leaf] *) +(** [betree_main::betree::Leaf] + Source: 'src/betree.rs', lines 167:0-167:11 *) Record betree_Leaf_t := mkbetree_Leaf_t { betree_Leaf_id : u64; betree_Leaf_size : u64; } . -(** [betree_main::betree::Internal] *) +(** [betree_main::betree::Internal] + Source: 'src/betree.rs', lines 156:0-156:15 *) Inductive betree_Internal_t := | mkbetree_Internal_t : u64 -> @@ -46,7 +51,8 @@ Inductive betree_Internal_t := betree_Node_t -> betree_Internal_t -(** [betree_main::betree::Node] *) +(** [betree_main::betree::Node] + Source: 'src/betree.rs', lines 179:0-179:9 *) with betree_Node_t := | Betree_Node_Internal : betree_Internal_t -> betree_Node_t | Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t @@ -81,21 +87,24 @@ Notation "x1 .(betree_Internal_right)" := (betree_Internal_right x1) (at level 9) . -(** [betree_main::betree::Params] *) +(** [betree_main::betree::Params] + Source: 'src/betree.rs', lines 187:0-187:13 *) Record betree_Params_t := mkbetree_Params_t { betree_Params_min_flush_size : u64; betree_Params_split_size : u64; } . -(** [betree_main::betree::NodeIdCounter] *) +(** [betree_main::betree::NodeIdCounter] + Source: 'src/betree.rs', lines 201:0-201:20 *) Record betree_NodeIdCounter_t := mkbetree_NodeIdCounter_t { betree_NodeIdCounter_next_node_id : u64; } . -(** [betree_main::betree::BeTree] *) +(** [betree_main::betree::BeTree] + Source: 'src/betree.rs', lines 218:0-218:17 *) Record betree_BeTree_t := mkbetree_BeTree_t { betree_BeTree_params : betree_Params_t; diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index fbed86b5..c08f7f7d 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -10,11 +10,13 @@ Require Export Hashmap_Types. Import Hashmap_Types. Module Hashmap_Funs. -(** [hashmap::hash_key]: forward function *) +(** [hashmap::hash_key]: forward function + Source: 'src/hashmap.rs', lines 27:0-27:32 *) Definition hash_key (k : usize) : result usize := Return k. -(** [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function + Source: 'src/hashmap.rs', lines 50:4-56:5 *) Fixpoint hashMap_allocate_slots_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : result (alloc_vec_Vec (List_t T)) @@ -31,7 +33,8 @@ Fixpoint hashMap_allocate_slots_loop end . -(** [hashmap::{hashmap::HashMap}::allocate_slots]: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: forward function + Source: 'src/hashmap.rs', lines 50:4-50:76 *) Definition hashMap_allocate_slots (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (n0 : usize) : result (alloc_vec_Vec (List_t T)) @@ -39,7 +42,8 @@ Definition hashMap_allocate_slots hashMap_allocate_slots_loop T n slots n0 . -(** [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function *) +(** [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function + Source: 'src/hashmap.rs', lines 59:4-63:13 *) Definition hashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -58,13 +62,15 @@ Definition hashMap_new_with_capacity |} . -(** [hashmap::{hashmap::HashMap}::new]: forward function *) +(** [hashmap::{hashmap::HashMap}::new]: forward function + Source: 'src/hashmap.rs', lines 75:4-75:24 *) Definition hashMap_new (T : Type) (n : nat) : result (HashMap_t T) := hashMap_new_with_capacity T n 32%usize 4%usize 5%usize . (** [hashmap::{hashmap::HashMap}::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-88:5 *) Fixpoint hashMap_clear_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (List_t T)) (i : usize) : result (alloc_vec_Vec (List_t T)) @@ -86,7 +92,8 @@ Fixpoint hashMap_clear_loop . (** [hashmap::{hashmap::HashMap}::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-80:27 *) Definition hashMap_clear (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := v <- hashMap_clear_loop T n self.(hashMap_slots) 0%usize; @@ -99,12 +106,14 @@ Definition hashMap_clear |} . -(** [hashmap::{hashmap::HashMap}::len]: forward function *) +(** [hashmap::{hashmap::HashMap}::len]: forward function + Source: 'src/hashmap.rs', lines 90:4-90:30 *) Definition hashMap_len (T : Type) (self : HashMap_t T) : result usize := Return self.(hashMap_num_entries) . -(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 97:4-114:5 *) Fixpoint hashMap_insert_in_list_loop (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool @@ -122,7 +131,8 @@ Fixpoint hashMap_insert_in_list_loop end . -(** [hashmap::{hashmap::HashMap}::insert_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: forward function + Source: 'src/hashmap.rs', lines 97:4-97:71 *) Definition hashMap_insert_in_list (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result bool @@ -130,7 +140,8 @@ Definition hashMap_insert_in_list hashMap_insert_in_list_loop T n key value ls . -(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-114:5 *) Fixpoint hashMap_insert_in_list_loop_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) @@ -150,7 +161,8 @@ Fixpoint hashMap_insert_in_list_loop_back end . -(** [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-97:71 *) Definition hashMap_insert_in_list_back (T : Type) (n : nat) (key : usize) (value : T) (ls : List_t T) : result (List_t T) @@ -159,7 +171,8 @@ Definition hashMap_insert_in_list_back . (** [hashmap::{hashmap::HashMap}::insert_no_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 117:4-117:54 *) Definition hashMap_insert_no_resize (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : result (HashMap_t T) @@ -203,7 +216,8 @@ Definition hashMap_insert_no_resize . (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-196:5 *) Fixpoint hashMap_move_elements_from_list_loop (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : result (HashMap_t T) @@ -221,7 +235,8 @@ Fixpoint hashMap_move_elements_from_list_loop . (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-183:72 *) Definition hashMap_move_elements_from_list (T : Type) (n : nat) (ntable : HashMap_t T) (ls : List_t T) : result (HashMap_t T) @@ -230,7 +245,8 @@ Definition hashMap_move_elements_from_list . (** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-180:5 *) Fixpoint hashMap_move_elements_loop (T : Type) (n : nat) (ntable : HashMap_t T) (slots : alloc_vec_Vec (List_t T)) (i : usize) : @@ -258,7 +274,8 @@ Fixpoint hashMap_move_elements_loop . (** [hashmap::{hashmap::HashMap}::move_elements]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-171:95 *) Definition hashMap_move_elements (T : Type) (n : nat) (ntable : HashMap_t T) (slots : alloc_vec_Vec (List_t T)) (i : usize) : @@ -268,7 +285,8 @@ Definition hashMap_move_elements . (** [hashmap::{hashmap::HashMap}::try_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 140:4-140:28 *) Definition hashMap_try_resize (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := max_usize <- scalar_cast U32 Usize core_u32_max; @@ -300,7 +318,8 @@ Definition hashMap_try_resize . (** [hashmap::{hashmap::HashMap}::insert]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 129:4-129:48 *) Definition hashMap_insert (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (value : T) : result (HashMap_t T) @@ -312,7 +331,8 @@ Definition hashMap_insert else Return self0 . -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 206:4-219:5 *) Fixpoint hashMap_contains_key_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := match n with @@ -328,13 +348,15 @@ Fixpoint hashMap_contains_key_in_list_loop end . -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function + Source: 'src/hashmap.rs', lines 206:4-206:68 *) Definition hashMap_contains_key_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result bool := hashMap_contains_key_in_list_loop T n key ls . -(** [hashmap::{hashmap::HashMap}::contains_key]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key]: forward function + Source: 'src/hashmap.rs', lines 199:4-199:49 *) Definition hashMap_contains_key (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result bool := hash <- hash_key key; @@ -347,7 +369,8 @@ Definition hashMap_contains_key hashMap_contains_key_in_list T n key l . -(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 224:4-237:5 *) Fixpoint hashMap_get_in_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := match n with @@ -363,13 +386,15 @@ Fixpoint hashMap_get_in_list_loop end . -(** [hashmap::{hashmap::HashMap}::get_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: forward function + Source: 'src/hashmap.rs', lines 224:4-224:70 *) Definition hashMap_get_in_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result T := hashMap_get_in_list_loop T n key ls . -(** [hashmap::{hashmap::HashMap}::get]: forward function *) +(** [hashmap::{hashmap::HashMap}::get]: forward function + Source: 'src/hashmap.rs', lines 239:4-239:55 *) Definition hashMap_get (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := hash <- hash_key key; @@ -382,7 +407,8 @@ Definition hashMap_get hashMap_get_in_list T n key l . -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 245:4-254:5 *) Fixpoint hashMap_get_mut_in_list_loop (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := match n with @@ -398,13 +424,15 @@ Fixpoint hashMap_get_mut_in_list_loop end . -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function + Source: 'src/hashmap.rs', lines 245:4-245:86 *) Definition hashMap_get_mut_in_list (T : Type) (n : nat) (ls : List_t T) (key : usize) : result T := hashMap_get_mut_in_list_loop T n ls key . -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-254:5 *) Fixpoint hashMap_get_mut_in_list_loop_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) @@ -424,7 +452,8 @@ Fixpoint hashMap_get_mut_in_list_loop_back end . -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-245:86 *) Definition hashMap_get_mut_in_list_back (T : Type) (n : nat) (ls : List_t T) (key : usize) (ret : T) : result (List_t T) @@ -432,7 +461,8 @@ Definition hashMap_get_mut_in_list_back hashMap_get_mut_in_list_loop_back T n ls key ret . -(** [hashmap::{hashmap::HashMap}::get_mut]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut]: forward function + Source: 'src/hashmap.rs', lines 257:4-257:67 *) Definition hashMap_get_mut (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result T := hash <- hash_key key; @@ -445,7 +475,8 @@ Definition hashMap_get_mut hashMap_get_mut_in_list T n l key . -(** [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 + Source: 'src/hashmap.rs', lines 257:4-257:67 *) Definition hashMap_get_mut_back (T : Type) (n : nat) (self : HashMap_t T) (key : usize) (ret : T) : result (HashMap_t T) @@ -471,7 +502,8 @@ Definition hashMap_get_mut_back |} . -(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 265:4-291:5 *) Fixpoint hashMap_remove_from_list_loop (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := match n with @@ -493,13 +525,15 @@ Fixpoint hashMap_remove_from_list_loop end . -(** [hashmap::{hashmap::HashMap}::remove_from_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: forward function + Source: 'src/hashmap.rs', lines 265:4-265:69 *) Definition hashMap_remove_from_list (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (option T) := hashMap_remove_from_list_loop T n key ls . -(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-291:5 *) Fixpoint hashMap_remove_from_list_loop_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := match n with @@ -523,13 +557,15 @@ Fixpoint hashMap_remove_from_list_loop_back end . -(** [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-265:69 *) Definition hashMap_remove_from_list_back (T : Type) (n : nat) (key : usize) (ls : List_t T) : result (List_t T) := hashMap_remove_from_list_loop_back T n key ls . -(** [hashmap::{hashmap::HashMap}::remove]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove]: forward function + Source: 'src/hashmap.rs', lines 294:4-294:52 *) Definition hashMap_remove (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result (option T) @@ -549,7 +585,8 @@ Definition hashMap_remove end . -(** [hashmap::{hashmap::HashMap}::remove]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::remove]: backward function 0 + Source: 'src/hashmap.rs', lines 294:4-294:52 *) Definition hashMap_remove_back (T : Type) (n : nat) (self : HashMap_t T) (key : usize) : result (HashMap_t T) @@ -593,7 +630,8 @@ Definition hashMap_remove_back end . -(** [hashmap::test1]: forward function *) +(** [hashmap::test1]: forward function + Source: 'src/hashmap.rs', lines 315:0-315:10 *) Definition test1 (n : nat) : result unit := hm <- hashMap_new u64 n; hm0 <- hashMap_insert u64 n hm 0%usize 42%u64; diff --git a/tests/coq/hashmap/Hashmap_Types.v b/tests/coq/hashmap/Hashmap_Types.v index 8529803d..bfb5ae4b 100644 --- a/tests/coq/hashmap/Hashmap_Types.v +++ b/tests/coq/hashmap/Hashmap_Types.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module Hashmap_Types. -(** [hashmap::List] *) +(** [hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 *) Inductive List_t (T : Type) := | List_Cons : usize -> T -> List_t T -> List_t T | List_Nil : List_t T @@ -17,7 +18,8 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. -(** [hashmap::HashMap] *) +(** [hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 *) Record HashMap_t (T : Type) := mkHashMap_t { hashMap_num_entries : usize; diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index 6f3848e6..46d3ee29 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -12,11 +12,13 @@ Require Export HashmapMain_Opaque. Import HashmapMain_Opaque. Module HashmapMain_Funs. -(** [hashmap_main::hashmap::hash_key]: forward function *) +(** [hashmap_main::hashmap::hash_key]: forward function + Source: 'src/hashmap.rs', lines 27:0-27:32 *) Definition hashmap_hash_key (k : usize) : result usize := Return k. -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function + Source: 'src/hashmap.rs', lines 50:4-56:5 *) Fixpoint hashmap_HashMap_allocate_slots_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) : @@ -34,7 +36,8 @@ Fixpoint hashmap_HashMap_allocate_slots_loop end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function + Source: 'src/hashmap.rs', lines 50:4-50:76 *) Definition hashmap_HashMap_allocate_slots (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (n0 : usize) : @@ -43,7 +46,8 @@ Definition hashmap_HashMap_allocate_slots hashmap_HashMap_allocate_slots_loop T n slots n0 . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function + Source: 'src/hashmap.rs', lines 59:4-63:13 *) Definition hashmap_HashMap_new_with_capacity (T : Type) (n : nat) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -62,14 +66,16 @@ Definition hashmap_HashMap_new_with_capacity |} . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function + Source: 'src/hashmap.rs', lines 75:4-75:24 *) Definition hashmap_HashMap_new (T : Type) (n : nat) : result (hashmap_HashMap_t T) := hashmap_HashMap_new_with_capacity T n 32%usize 4%usize 5%usize . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-88:5 *) Fixpoint hashmap_HashMap_clear_loop (T : Type) (n : nat) (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : result (alloc_vec_Vec (hashmap_List_t T)) @@ -91,7 +97,8 @@ Fixpoint hashmap_HashMap_clear_loop . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-80:27 *) Definition hashmap_HashMap_clear (T : Type) (n : nat) (self : hashmap_HashMap_t T) : result (hashmap_HashMap_t T) @@ -106,13 +113,15 @@ Definition hashmap_HashMap_clear |} . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function + Source: 'src/hashmap.rs', lines 90:4-90:30 *) Definition hashmap_HashMap_len (T : Type) (self : hashmap_HashMap_t T) : result usize := Return self.(hashmap_HashMap_num_entries) . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 97:4-114:5 *) Fixpoint hashmap_HashMap_insert_in_list_loop (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool @@ -130,7 +139,8 @@ Fixpoint hashmap_HashMap_insert_in_list_loop end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function + Source: 'src/hashmap.rs', lines 97:4-97:71 *) Definition hashmap_HashMap_insert_in_list (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result bool @@ -138,7 +148,8 @@ Definition hashmap_HashMap_insert_in_list hashmap_HashMap_insert_in_list_loop T n key value ls . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-114:5 *) Fixpoint hashmap_HashMap_insert_in_list_loop_back (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -159,7 +170,8 @@ Fixpoint hashmap_HashMap_insert_in_list_loop_back end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-97:71 *) Definition hashmap_HashMap_insert_in_list_back (T : Type) (n : nat) (key : usize) (value : T) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -168,7 +180,8 @@ Definition hashmap_HashMap_insert_in_list_back . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 117:4-117:54 *) Definition hashmap_HashMap_insert_no_resize (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : result (hashmap_HashMap_t T) @@ -214,7 +227,8 @@ Definition hashmap_HashMap_insert_no_resize . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-196:5 *) Fixpoint hashmap_HashMap_move_elements_from_list_loop (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : result (hashmap_HashMap_t T) @@ -232,7 +246,8 @@ Fixpoint hashmap_HashMap_move_elements_from_list_loop . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-183:72 *) Definition hashmap_HashMap_move_elements_from_list (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (ls : hashmap_List_t T) : result (hashmap_HashMap_t T) @@ -241,7 +256,8 @@ Definition hashmap_HashMap_move_elements_from_list . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-180:5 *) Fixpoint hashmap_HashMap_move_elements_loop (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : @@ -271,7 +287,8 @@ Fixpoint hashmap_HashMap_move_elements_loop . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-171:95 *) Definition hashmap_HashMap_move_elements (T : Type) (n : nat) (ntable : hashmap_HashMap_t T) (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : @@ -281,7 +298,8 @@ Definition hashmap_HashMap_move_elements . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 140:4-140:28 *) Definition hashmap_HashMap_try_resize (T : Type) (n : nat) (self : hashmap_HashMap_t T) : result (hashmap_HashMap_t T) @@ -318,7 +336,8 @@ Definition hashmap_HashMap_try_resize . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 129:4-129:48 *) Definition hashmap_HashMap_insert (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (value : T) : result (hashmap_HashMap_t T) @@ -330,7 +349,8 @@ Definition hashmap_HashMap_insert else Return self0 . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 206:4-219:5 *) Fixpoint hashmap_HashMap_contains_key_in_list_loop (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := match n with @@ -346,13 +366,15 @@ Fixpoint hashmap_HashMap_contains_key_in_list_loop end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function + Source: 'src/hashmap.rs', lines 206:4-206:68 *) Definition hashmap_HashMap_contains_key_in_list (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result bool := hashmap_HashMap_contains_key_in_list_loop T n key ls . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function + Source: 'src/hashmap.rs', lines 199:4-199:49 *) Definition hashmap_HashMap_contains_key (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result bool @@ -367,7 +389,8 @@ Definition hashmap_HashMap_contains_key hashmap_HashMap_contains_key_in_list T n key l . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 224:4-237:5 *) Fixpoint hashmap_HashMap_get_in_list_loop (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := match n with @@ -383,13 +406,15 @@ Fixpoint hashmap_HashMap_get_in_list_loop end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function + Source: 'src/hashmap.rs', lines 224:4-224:70 *) Definition hashmap_HashMap_get_in_list (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result T := hashmap_HashMap_get_in_list_loop T n key ls . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function + Source: 'src/hashmap.rs', lines 239:4-239:55 *) Definition hashmap_HashMap_get (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := hash <- hashmap_hash_key key; @@ -402,7 +427,8 @@ Definition hashmap_HashMap_get hashmap_HashMap_get_in_list T n key l . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 245:4-254:5 *) Fixpoint hashmap_HashMap_get_mut_in_list_loop (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := match n with @@ -418,13 +444,15 @@ Fixpoint hashmap_HashMap_get_mut_in_list_loop end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function + Source: 'src/hashmap.rs', lines 245:4-245:86 *) Definition hashmap_HashMap_get_mut_in_list (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) : result T := hashmap_HashMap_get_mut_in_list_loop T n ls key . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-254:5 *) Fixpoint hashmap_HashMap_get_mut_in_list_loop_back (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : result (hashmap_List_t T) @@ -444,7 +472,8 @@ Fixpoint hashmap_HashMap_get_mut_in_list_loop_back end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-245:86 *) Definition hashmap_HashMap_get_mut_in_list_back (T : Type) (n : nat) (ls : hashmap_List_t T) (key : usize) (ret : T) : result (hashmap_List_t T) @@ -452,7 +481,8 @@ Definition hashmap_HashMap_get_mut_in_list_back hashmap_HashMap_get_mut_in_list_loop_back T n ls key ret . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function + Source: 'src/hashmap.rs', lines 257:4-257:67 *) Definition hashmap_HashMap_get_mut (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result T := hash <- hashmap_hash_key key; @@ -465,7 +495,8 @@ Definition hashmap_HashMap_get_mut hashmap_HashMap_get_mut_in_list T n l key . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 + Source: 'src/hashmap.rs', lines 257:4-257:67 *) Definition hashmap_HashMap_get_mut_back (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) (ret : T) : result (hashmap_HashMap_t T) @@ -491,7 +522,8 @@ Definition hashmap_HashMap_get_mut_back |} . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 265:4-291:5 *) Fixpoint hashmap_HashMap_remove_from_list_loop (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) @@ -516,7 +548,8 @@ Fixpoint hashmap_HashMap_remove_from_list_loop end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function + Source: 'src/hashmap.rs', lines 265:4-265:69 *) Definition hashmap_HashMap_remove_from_list (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (option T) @@ -524,7 +557,8 @@ Definition hashmap_HashMap_remove_from_list hashmap_HashMap_remove_from_list_loop T n key ls . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-291:5 *) Fixpoint hashmap_HashMap_remove_from_list_loop_back (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -551,7 +585,8 @@ Fixpoint hashmap_HashMap_remove_from_list_loop_back end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-265:69 *) Definition hashmap_HashMap_remove_from_list_back (T : Type) (n : nat) (key : usize) (ls : hashmap_List_t T) : result (hashmap_List_t T) @@ -559,7 +594,8 @@ Definition hashmap_HashMap_remove_from_list_back hashmap_HashMap_remove_from_list_loop_back T n key ls . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function + Source: 'src/hashmap.rs', lines 294:4-294:52 *) Definition hashmap_HashMap_remove (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result (option T) @@ -579,7 +615,8 @@ Definition hashmap_HashMap_remove end . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 + Source: 'src/hashmap.rs', lines 294:4-294:52 *) Definition hashmap_HashMap_remove_back (T : Type) (n : nat) (self : hashmap_HashMap_t T) (key : usize) : result (hashmap_HashMap_t T) @@ -625,7 +662,8 @@ Definition hashmap_HashMap_remove_back end . -(** [hashmap_main::hashmap::test1]: forward function *) +(** [hashmap_main::hashmap::test1]: forward function + Source: 'src/hashmap.rs', lines 315:0-315:10 *) Definition hashmap_test1 (n : nat) : result unit := hm <- hashmap_HashMap_new u64 n; hm0 <- hashmap_HashMap_insert u64 n hm 0%usize 42%u64; @@ -662,7 +700,8 @@ Definition hashmap_test1 (n : nat) : result unit := end)) . -(** [hashmap_main::insert_on_disk]: forward function *) +(** [hashmap_main::insert_on_disk]: forward function + Source: 'src/hashmap_main.rs', lines 7:0-7:43 *) Definition insert_on_disk (n : nat) (key : usize) (value : u64) (st : state) : result (state * unit) := p <- hashmap_utils_deserialize st; @@ -673,7 +712,8 @@ Definition insert_on_disk Return (st1, tt) . -(** [hashmap_main::main]: forward function *) +(** [hashmap_main::main]: forward function + Source: 'src/hashmap_main.rs', lines 16:0-16:13 *) Definition main : result unit := Return tt. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v index 5e376239..a0e9003d 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v @@ -10,12 +10,14 @@ Require Export HashmapMain_Types. Import HashmapMain_Types. Module HashmapMain_Opaque. -(** [hashmap_main::hashmap_utils::deserialize]: forward function *) +(** [hashmap_main::hashmap_utils::deserialize]: forward function + Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) Axiom hashmap_utils_deserialize : state -> result (state * (hashmap_HashMap_t u64)) . -(** [hashmap_main::hashmap_utils::serialize]: forward function *) +(** [hashmap_main::hashmap_utils::serialize]: forward function + Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) Axiom hashmap_utils_serialize : hashmap_HashMap_t u64 -> state -> result (state * unit) . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Types.v b/tests/coq/hashmap_on_disk/HashmapMain_Types.v index 95e5f35b..039b7e72 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Types.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Types.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module HashmapMain_Types. -(** [hashmap_main::hashmap::List] *) +(** [hashmap_main::hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 *) Inductive hashmap_List_t (T : Type) := | Hashmap_List_Cons : usize -> T -> hashmap_List_t T -> hashmap_List_t T | Hashmap_List_Nil : hashmap_List_t T @@ -17,7 +18,8 @@ Inductive hashmap_List_t (T : Type) := Arguments Hashmap_List_Cons { _ }. Arguments Hashmap_List_Nil { _ }. -(** [hashmap_main::hashmap::HashMap] *) +(** [hashmap_main::hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 *) Record hashmap_HashMap_t (T : Type) := mkhashmap_HashMap_t { hashmap_HashMap_num_entries : usize; diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index 1f2ab812..20edb2b1 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -8,124 +8,152 @@ Import ListNotations. Local Open Scope Primitives_scope. Module Constants. -(** [constants::X0] *) +(** [constants::X0] + Source: 'src/constants.rs', lines 5:0-5:17 *) Definition x0_body : result u32 := Return 0%u32. Definition x0_c : u32 := x0_body%global. -(** [constants::X1] *) +(** [constants::X1] + Source: 'src/constants.rs', lines 7:0-7:17 *) Definition x1_body : result u32 := Return core_u32_max. Definition x1_c : u32 := x1_body%global. -(** [constants::X2] *) +(** [constants::X2] + Source: 'src/constants.rs', lines 10:0-10:17 *) Definition x2_body : result u32 := Return 3%u32. Definition x2_c : u32 := x2_body%global. -(** [constants::incr]: forward function *) +(** [constants::incr]: forward function + Source: 'src/constants.rs', lines 17:0-17:32 *) Definition incr (n : u32) : result u32 := u32_add n 1%u32. -(** [constants::X3] *) +(** [constants::X3] + Source: 'src/constants.rs', lines 15:0-15:17 *) Definition x3_body : result u32 := incr 32%u32. Definition x3_c : u32 := x3_body%global. -(** [constants::mk_pair0]: forward function *) +(** [constants::mk_pair0]: forward function + Source: 'src/constants.rs', lines 23:0-23:51 *) Definition mk_pair0 (x : u32) (y : u32) : result (u32 * u32) := Return (x, y). -(** [constants::Pair] *) +(** [constants::Pair] + Source: 'src/constants.rs', lines 36:0-36:23 *) Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. Arguments mkPair_t { _ _ }. Arguments pair_x { _ _ }. Arguments pair_y { _ _ }. -(** [constants::mk_pair1]: forward function *) +(** [constants::mk_pair1]: forward function + Source: 'src/constants.rs', lines 27:0-27:55 *) Definition mk_pair1 (x : u32) (y : u32) : result (Pair_t u32 u32) := Return {| pair_x := x; pair_y := y |} . -(** [constants::P0] *) +(** [constants::P0] + Source: 'src/constants.rs', lines 31:0-31:24 *) Definition p0_body : result (u32 * u32) := mk_pair0 0%u32 1%u32. Definition p0_c : (u32 * u32) := p0_body%global. -(** [constants::P1] *) +(** [constants::P1] + Source: 'src/constants.rs', lines 32:0-32:28 *) Definition p1_body : result (Pair_t u32 u32) := mk_pair1 0%u32 1%u32. Definition p1_c : Pair_t u32 u32 := p1_body%global. -(** [constants::P2] *) +(** [constants::P2] + Source: 'src/constants.rs', lines 33:0-33:24 *) Definition p2_body : result (u32 * u32) := Return (0%u32, 1%u32). Definition p2_c : (u32 * u32) := p2_body%global. -(** [constants::P3] *) +(** [constants::P3] + Source: 'src/constants.rs', lines 34:0-34:28 *) Definition p3_body : result (Pair_t u32 u32) := Return {| pair_x := 0%u32; pair_y := 1%u32 |} . Definition p3_c : Pair_t u32 u32 := p3_body%global. -(** [constants::Wrap] *) +(** [constants::Wrap] + Source: 'src/constants.rs', lines 49:0-49:18 *) Record Wrap_t (T : Type) := mkWrap_t { wrap_value : T; }. Arguments mkWrap_t { _ }. Arguments wrap_value { _ }. -(** [constants::{constants::Wrap}::new]: forward function *) +(** [constants::{constants::Wrap}::new]: forward function + Source: 'src/constants.rs', lines 54:4-54:41 *) Definition wrap_new (T : Type) (value : T) : result (Wrap_t T) := Return {| wrap_value := value |} . -(** [constants::Y] *) +(** [constants::Y] + Source: 'src/constants.rs', lines 41:0-41:22 *) Definition y_body : result (Wrap_t i32) := wrap_new i32 2%i32. Definition y_c : Wrap_t i32 := y_body%global. -(** [constants::unwrap_y]: forward function *) +(** [constants::unwrap_y]: forward function + Source: 'src/constants.rs', lines 43:0-43:30 *) Definition unwrap_y : result i32 := Return y_c.(wrap_value). -(** [constants::YVAL] *) +(** [constants::YVAL] + Source: 'src/constants.rs', lines 47:0-47:19 *) Definition yval_body : result i32 := unwrap_y. Definition yval_c : i32 := yval_body%global. -(** [constants::get_z1::Z1] *) +(** [constants::get_z1::Z1] + Source: 'src/constants.rs', lines 62:4-62:17 *) Definition get_z1_z1_body : result i32 := Return 3%i32. Definition get_z1_z1_c : i32 := get_z1_z1_body%global. -(** [constants::get_z1]: forward function *) +(** [constants::get_z1]: forward function + Source: 'src/constants.rs', lines 61:0-61:28 *) Definition get_z1 : result i32 := Return get_z1_z1_c. -(** [constants::add]: forward function *) +(** [constants::add]: forward function + Source: 'src/constants.rs', lines 66:0-66:39 *) Definition add (a : i32) (b : i32) : result i32 := i32_add a b. -(** [constants::Q1] *) +(** [constants::Q1] + Source: 'src/constants.rs', lines 74:0-74:17 *) Definition q1_body : result i32 := Return 5%i32. Definition q1_c : i32 := q1_body%global. -(** [constants::Q2] *) +(** [constants::Q2] + Source: 'src/constants.rs', lines 75:0-75:17 *) Definition q2_body : result i32 := Return q1_c. Definition q2_c : i32 := q2_body%global. -(** [constants::Q3] *) +(** [constants::Q3] + Source: 'src/constants.rs', lines 76:0-76:17 *) Definition q3_body : result i32 := add q2_c 3%i32. Definition q3_c : i32 := q3_body%global. -(** [constants::get_z2]: forward function *) +(** [constants::get_z2]: forward function + Source: 'src/constants.rs', lines 70:0-70:28 *) Definition get_z2 : result i32 := i <- get_z1; i0 <- add i q3_c; add q1_c i0. -(** [constants::S1] *) +(** [constants::S1] + Source: 'src/constants.rs', lines 80:0-80:18 *) Definition s1_body : result u32 := Return 6%u32. Definition s1_c : u32 := s1_body%global. -(** [constants::S2] *) +(** [constants::S2] + Source: 'src/constants.rs', lines 81:0-81:18 *) Definition s2_body : result u32 := incr s1_c. Definition s2_c : u32 := s2_body%global. -(** [constants::S3] *) +(** [constants::S3] + Source: 'src/constants.rs', lines 82:0-82:29 *) Definition s3_body : result (Pair_t u32 u32) := Return p3_c. Definition s3_c : Pair_t u32 u32 := s3_body%global. -(** [constants::S4] *) +(** [constants::S4] + Source: 'src/constants.rs', lines 83:0-83:29 *) Definition s4_body : result (Pair_t u32 u32) := mk_pair1 7%u32 8%u32. Definition s4_c : Pair_t u32 u32 := s4_body%global. diff --git a/tests/coq/misc/External_Funs.v b/tests/coq/misc/External_Funs.v index 018ce13c..0a14c7d1 100644 --- a/tests/coq/misc/External_Funs.v +++ b/tests/coq/misc/External_Funs.v @@ -12,7 +12,8 @@ Require Export External_Opaque. Import External_Opaque. Module External_Funs. -(** [external::swap]: forward function *) +(** [external::swap]: forward function + Source: 'src/external.rs', lines 6:0-6:46 *) Definition swap (T : Type) (x : T) (y : T) (st : state) : result (state * unit) := p <- core_mem_swap T x y st; @@ -24,7 +25,8 @@ Definition swap Return (st2, tt) . -(** [external::swap]: backward function 0 *) +(** [external::swap]: backward function 0 + Source: 'src/external.rs', lines 6:0-6:46 *) Definition swap_back (T : Type) (x : T) (y : T) (st : state) (st0 : state) : result (state * (T * T)) @@ -38,7 +40,8 @@ Definition swap_back Return (st0, (x0, y0)) . -(** [external::test_new_non_zero_u32]: forward function *) +(** [external::test_new_non_zero_u32]: forward function + Source: 'src/external.rs', lines 11:0-11:60 *) Definition test_new_non_zero_u32 (x : u32) (st : state) : result (state * core_num_nonzero_NonZeroU32_t) := p <- core_num_nonzero_NonZeroU32_new x st; @@ -46,7 +49,8 @@ Definition test_new_non_zero_u32 core_option_Option_unwrap core_num_nonzero_NonZeroU32_t o st0 . -(** [external::test_vec]: forward function *) +(** [external::test_vec]: forward function + Source: 'src/external.rs', lines 17:0-17:17 *) Definition test_vec : result unit := let v := alloc_vec_Vec_new u32 in _ <- alloc_vec_Vec_push u32 v 0%u32; @@ -56,7 +60,8 @@ Definition test_vec : result unit := (** Unit test for [external::test_vec] *) Check (test_vec )%return. -(** [external::custom_swap]: forward function *) +(** [external::custom_swap]: forward function + Source: 'src/external.rs', lines 24:0-24:66 *) Definition custom_swap (T : Type) (x : T) (y : T) (st : state) : result (state * T) := p <- core_mem_swap T x y st; @@ -68,7 +73,8 @@ Definition custom_swap Return (st2, x0) . -(** [external::custom_swap]: backward function 0 *) +(** [external::custom_swap]: backward function 0 + Source: 'src/external.rs', lines 24:0-24:66 *) Definition custom_swap_back (T : Type) (x : T) (y : T) (st : state) (ret : T) (st0 : state) : result (state * (T * T)) @@ -82,13 +88,15 @@ Definition custom_swap_back Return (st0, (ret, y0)) . -(** [external::test_custom_swap]: forward function *) +(** [external::test_custom_swap]: forward function + Source: 'src/external.rs', lines 29:0-29:59 *) Definition test_custom_swap (x : u32) (y : u32) (st : state) : result (state * unit) := p <- custom_swap u32 x y st; let (st0, _) := p in Return (st0, tt) . -(** [external::test_custom_swap]: backward function 0 *) +(** [external::test_custom_swap]: backward function 0 + Source: 'src/external.rs', lines 29:0-29:59 *) Definition test_custom_swap_back (x : u32) (y : u32) (st : state) (st0 : state) : result (state * (u32 * u32)) @@ -96,7 +104,8 @@ Definition test_custom_swap_back custom_swap_back u32 x y st 1%u32 st0 . -(** [external::test_swap_non_zero]: forward function *) +(** [external::test_swap_non_zero]: forward function + Source: 'src/external.rs', lines 35:0-35:44 *) Definition test_swap_non_zero (x : u32) (st : state) : result (state * u32) := p <- swap u32 x 0%u32 st; let (st0, _) := p in diff --git a/tests/coq/misc/External_Opaque.v b/tests/coq/misc/External_Opaque.v index 10c05583..b482431f 100644 --- a/tests/coq/misc/External_Opaque.v +++ b/tests/coq/misc/External_Opaque.v @@ -10,27 +10,32 @@ Require Export External_Types. Import External_Types. Module External_Opaque. -(** [core::mem::swap]: forward function *) +(** [core::mem::swap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) Axiom core_mem_swap : forall(T : Type), T -> T -> state -> result (state * unit) . -(** [core::mem::swap]: backward function 0 *) +(** [core::mem::swap]: backward function 0 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) Axiom core_mem_swap_back0 : forall(T : Type), T -> T -> state -> state -> result (state * T) . -(** [core::mem::swap]: backward function 1 *) +(** [core::mem::swap]: backward function 1 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) Axiom core_mem_swap_back1 : forall(T : Type), T -> T -> state -> state -> result (state * T) . -(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function *) +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) Axiom core_num_nonzero_NonZeroU32_new : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) . -(** [core::option::{core::option::Option}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . diff --git a/tests/coq/misc/External_Types.v b/tests/coq/misc/External_Types.v index 9e49ca41..c638670c 100644 --- a/tests/coq/misc/External_Types.v +++ b/tests/coq/misc/External_Types.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module External_Types. -(** [core::num::nonzero::NonZeroU32] *) +(** [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) Axiom core_num_nonzero_NonZeroU32_t : Type. (** The state type used in the state-error monad *) diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index e5ff6c8e..4929ddd0 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module Loops. -(** [loops::sum]: loop 0: forward function *) +(** [loops::sum]: loop 0: forward function + Source: 'src/loops.rs', lines 4:0-14:1 *) Fixpoint sum_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := match n with | O => Fail_ OutOfFuel @@ -19,12 +20,14 @@ Fixpoint sum_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := end . -(** [loops::sum]: forward function *) +(** [loops::sum]: forward function + Source: 'src/loops.rs', lines 4:0-4:27 *) Definition sum (n : nat) (max : u32) : result u32 := sum_loop n max 0%u32 0%u32 . -(** [loops::sum_with_mut_borrows]: loop 0: forward function *) +(** [loops::sum_with_mut_borrows]: loop 0: forward function + Source: 'src/loops.rs', lines 19:0-31:1 *) Fixpoint sum_with_mut_borrows_loop (n : nat) (max : u32) (mi : u32) (ms : u32) : result u32 := match n with @@ -39,12 +42,14 @@ Fixpoint sum_with_mut_borrows_loop end . -(** [loops::sum_with_mut_borrows]: forward function *) +(** [loops::sum_with_mut_borrows]: forward function + Source: 'src/loops.rs', lines 19:0-19:44 *) Definition sum_with_mut_borrows (n : nat) (max : u32) : result u32 := sum_with_mut_borrows_loop n max 0%u32 0%u32 . -(** [loops::sum_with_shared_borrows]: loop 0: forward function *) +(** [loops::sum_with_shared_borrows]: loop 0: forward function + Source: 'src/loops.rs', lines 34:0-48:1 *) Fixpoint sum_with_shared_borrows_loop (n : nat) (max : u32) (i : u32) (s : u32) : result u32 := match n with @@ -59,13 +64,15 @@ Fixpoint sum_with_shared_borrows_loop end . -(** [loops::sum_with_shared_borrows]: forward function *) +(** [loops::sum_with_shared_borrows]: forward function + Source: 'src/loops.rs', lines 34:0-34:47 *) Definition sum_with_shared_borrows (n : nat) (max : u32) : result u32 := sum_with_shared_borrows_loop n max 0%u32 0%u32 . (** [loops::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/loops.rs', lines 52:0-58:1 *) Fixpoint clear_loop (n : nat) (v : alloc_vec_Vec u32) (i : usize) : result (alloc_vec_Vec u32) := match n with @@ -84,13 +91,15 @@ Fixpoint clear_loop . (** [loops::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/loops.rs', lines 52:0-52:30 *) Definition clear (n : nat) (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) := clear_loop n v 0%usize . -(** [loops::List] *) +(** [loops::List] + Source: 'src/loops.rs', lines 60:0-60:16 *) Inductive List_t (T : Type) := | List_Cons : T -> List_t T -> List_t T | List_Nil : List_t T @@ -99,7 +108,8 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. -(** [loops::list_mem]: loop 0: forward function *) +(** [loops::list_mem]: loop 0: forward function + Source: 'src/loops.rs', lines 66:0-75:1 *) Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := match n with | O => Fail_ OutOfFuel @@ -111,12 +121,14 @@ Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := end . -(** [loops::list_mem]: forward function *) +(** [loops::list_mem]: forward function + Source: 'src/loops.rs', lines 66:0-66:52 *) Definition list_mem (n : nat) (x : u32) (ls : List_t u32) : result bool := list_mem_loop n x ls . -(** [loops::list_nth_mut_loop]: loop 0: forward function *) +(** [loops::list_nth_mut_loop]: loop 0: forward function + Source: 'src/loops.rs', lines 78:0-88:1 *) Fixpoint list_nth_mut_loop_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := match n with @@ -132,13 +144,15 @@ Fixpoint list_nth_mut_loop_loop end . -(** [loops::list_nth_mut_loop]: forward function *) +(** [loops::list_nth_mut_loop]: forward function + Source: 'src/loops.rs', lines 78:0-78:71 *) Definition list_nth_mut_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := list_nth_mut_loop_loop T n ls i . -(** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 78:0-88:1 *) Fixpoint list_nth_mut_loop_loop_back (T : Type) (n : nat) (ls : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -159,7 +173,8 @@ Fixpoint list_nth_mut_loop_loop_back end . -(** [loops::list_nth_mut_loop]: backward function 0 *) +(** [loops::list_nth_mut_loop]: backward function 0 + Source: 'src/loops.rs', lines 78:0-78:71 *) Definition list_nth_mut_loop_back (T : Type) (n : nat) (ls : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -167,7 +182,8 @@ Definition list_nth_mut_loop_back list_nth_mut_loop_loop_back T n ls i ret . -(** [loops::list_nth_shared_loop]: loop 0: forward function *) +(** [loops::list_nth_shared_loop]: loop 0: forward function + Source: 'src/loops.rs', lines 91:0-101:1 *) Fixpoint list_nth_shared_loop_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := match n with @@ -183,13 +199,15 @@ Fixpoint list_nth_shared_loop_loop end . -(** [loops::list_nth_shared_loop]: forward function *) +(** [loops::list_nth_shared_loop]: forward function + Source: 'src/loops.rs', lines 91:0-91:66 *) Definition list_nth_shared_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := list_nth_shared_loop_loop T n ls i . -(** [loops::get_elem_mut]: loop 0: forward function *) +(** [loops::get_elem_mut]: loop 0: forward function + Source: 'src/loops.rs', lines 103:0-117:1 *) Fixpoint get_elem_mut_loop (n : nat) (x : usize) (ls : List_t usize) : result usize := match n with @@ -202,7 +220,8 @@ Fixpoint get_elem_mut_loop end . -(** [loops::get_elem_mut]: forward function *) +(** [loops::get_elem_mut]: forward function + Source: 'src/loops.rs', lines 103:0-103:73 *) Definition get_elem_mut (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : result usize @@ -213,7 +232,8 @@ Definition get_elem_mut get_elem_mut_loop n x l . -(** [loops::get_elem_mut]: loop 0: backward function 0 *) +(** [loops::get_elem_mut]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 103:0-117:1 *) Fixpoint get_elem_mut_loop_back (n : nat) (x : usize) (ls : List_t usize) (ret : usize) : result (List_t usize) @@ -232,7 +252,8 @@ Fixpoint get_elem_mut_loop_back end . -(** [loops::get_elem_mut]: backward function 0 *) +(** [loops::get_elem_mut]: backward function 0 + Source: 'src/loops.rs', lines 103:0-103:73 *) Definition get_elem_mut_back (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) (ret : usize) : result (alloc_vec_Vec (List_t usize)) @@ -246,7 +267,8 @@ Definition get_elem_mut_back l0 . -(** [loops::get_elem_shared]: loop 0: forward function *) +(** [loops::get_elem_shared]: loop 0: forward function + Source: 'src/loops.rs', lines 119:0-133:1 *) Fixpoint get_elem_shared_loop (n : nat) (x : usize) (ls : List_t usize) : result usize := match n with @@ -260,7 +282,8 @@ Fixpoint get_elem_shared_loop end . -(** [loops::get_elem_shared]: forward function *) +(** [loops::get_elem_shared]: forward function + Source: 'src/loops.rs', lines 119:0-119:68 *) Definition get_elem_shared (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : result usize @@ -271,22 +294,26 @@ Definition get_elem_shared get_elem_shared_loop n x l . -(** [loops::id_mut]: forward function *) +(** [loops::id_mut]: forward function + Source: 'src/loops.rs', lines 135:0-135:50 *) Definition id_mut (T : Type) (ls : List_t T) : result (List_t T) := Return ls. -(** [loops::id_mut]: backward function 0 *) +(** [loops::id_mut]: backward function 0 + Source: 'src/loops.rs', lines 135:0-135:50 *) Definition id_mut_back (T : Type) (ls : List_t T) (ret : List_t T) : result (List_t T) := Return ret . -(** [loops::id_shared]: forward function *) +(** [loops::id_shared]: forward function + Source: 'src/loops.rs', lines 139:0-139:45 *) Definition id_shared (T : Type) (ls : List_t T) : result (List_t T) := Return ls . -(** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) +(** [loops::list_nth_mut_loop_with_id]: loop 0: forward function + Source: 'src/loops.rs', lines 144:0-155:1 *) Fixpoint list_nth_mut_loop_with_id_loop (T : Type) (n : nat) (i : u32) (ls : List_t T) : result T := match n with @@ -302,13 +329,15 @@ Fixpoint list_nth_mut_loop_with_id_loop end . -(** [loops::list_nth_mut_loop_with_id]: forward function *) +(** [loops::list_nth_mut_loop_with_id]: forward function + Source: 'src/loops.rs', lines 144:0-144:75 *) Definition list_nth_mut_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := ls0 <- id_mut T ls; list_nth_mut_loop_with_id_loop T n i ls0 . -(** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 144:0-155:1 *) Fixpoint list_nth_mut_loop_with_id_loop_back (T : Type) (n : nat) (i : u32) (ls : List_t T) (ret : T) : result (List_t T) @@ -329,7 +358,8 @@ Fixpoint list_nth_mut_loop_with_id_loop_back end . -(** [loops::list_nth_mut_loop_with_id]: backward function 0 *) +(** [loops::list_nth_mut_loop_with_id]: backward function 0 + Source: 'src/loops.rs', lines 144:0-144:75 *) Definition list_nth_mut_loop_with_id_back (T : Type) (n : nat) (ls : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -339,7 +369,8 @@ Definition list_nth_mut_loop_with_id_back id_mut_back T ls l . -(** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) +(** [loops::list_nth_shared_loop_with_id]: loop 0: forward function + Source: 'src/loops.rs', lines 158:0-169:1 *) Fixpoint list_nth_shared_loop_with_id_loop (T : Type) (n : nat) (i : u32) (ls : List_t T) : result T := match n with @@ -356,13 +387,15 @@ Fixpoint list_nth_shared_loop_with_id_loop end . -(** [loops::list_nth_shared_loop_with_id]: forward function *) +(** [loops::list_nth_shared_loop_with_id]: forward function + Source: 'src/loops.rs', lines 158:0-158:70 *) Definition list_nth_shared_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := ls0 <- id_shared T ls; list_nth_shared_loop_with_id_loop T n i ls0 . -(** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_mut_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 174:0-195:1 *) Fixpoint list_nth_mut_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -385,7 +418,8 @@ Fixpoint list_nth_mut_loop_pair_loop end . -(** [loops::list_nth_mut_loop_pair]: forward function *) +(** [loops::list_nth_mut_loop_pair]: forward function + Source: 'src/loops.rs', lines 174:0-178:27 *) Definition list_nth_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -393,7 +427,8 @@ Definition list_nth_mut_loop_pair list_nth_mut_loop_pair_loop T n ls0 ls1 i . -(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 174:0-195:1 *) Fixpoint list_nth_mut_loop_pair_loop_back'a (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -418,7 +453,8 @@ Fixpoint list_nth_mut_loop_pair_loop_back'a end . -(** [loops::list_nth_mut_loop_pair]: backward function 0 *) +(** [loops::list_nth_mut_loop_pair]: backward function 0 + Source: 'src/loops.rs', lines 174:0-178:27 *) Definition list_nth_mut_loop_pair_back'a (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -426,7 +462,8 @@ Definition list_nth_mut_loop_pair_back'a list_nth_mut_loop_pair_loop_back'a T n ls0 ls1 i ret . -(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 *) +(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 + Source: 'src/loops.rs', lines 174:0-195:1 *) Fixpoint list_nth_mut_loop_pair_loop_back'b (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -451,7 +488,8 @@ Fixpoint list_nth_mut_loop_pair_loop_back'b end . -(** [loops::list_nth_mut_loop_pair]: backward function 1 *) +(** [loops::list_nth_mut_loop_pair]: backward function 1 + Source: 'src/loops.rs', lines 174:0-178:27 *) Definition list_nth_mut_loop_pair_back'b (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -459,7 +497,8 @@ Definition list_nth_mut_loop_pair_back'b list_nth_mut_loop_pair_loop_back'b T n ls0 ls1 i ret . -(** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_shared_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 198:0-219:1 *) Fixpoint list_nth_shared_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -482,7 +521,8 @@ Fixpoint list_nth_shared_loop_pair_loop end . -(** [loops::list_nth_shared_loop_pair]: forward function *) +(** [loops::list_nth_shared_loop_pair]: forward function + Source: 'src/loops.rs', lines 198:0-202:19 *) Definition list_nth_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -490,7 +530,8 @@ Definition list_nth_shared_loop_pair list_nth_shared_loop_pair_loop T n ls0 ls1 i . -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 223:0-238:1 *) Fixpoint list_nth_mut_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -514,7 +555,8 @@ Fixpoint list_nth_mut_loop_pair_merge_loop end . -(** [loops::list_nth_mut_loop_pair_merge]: forward function *) +(** [loops::list_nth_mut_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 223:0-227:27 *) Definition list_nth_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -522,7 +564,8 @@ Definition list_nth_mut_loop_pair_merge list_nth_mut_loop_pair_merge_loop T n ls0 ls1 i . -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 223:0-238:1 *) Fixpoint list_nth_mut_loop_pair_merge_loop_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : (T * T)) : @@ -549,7 +592,8 @@ Fixpoint list_nth_mut_loop_pair_merge_loop_back end . -(** [loops::list_nth_mut_loop_pair_merge]: backward function 0 *) +(** [loops::list_nth_mut_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 223:0-227:27 *) Definition list_nth_mut_loop_pair_merge_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : (T * T)) : @@ -558,7 +602,8 @@ Definition list_nth_mut_loop_pair_merge_back list_nth_mut_loop_pair_merge_loop_back T n ls0 ls1 i ret . -(** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 241:0-256:1 *) Fixpoint list_nth_shared_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -582,7 +627,8 @@ Fixpoint list_nth_shared_loop_pair_merge_loop end . -(** [loops::list_nth_shared_loop_pair_merge]: forward function *) +(** [loops::list_nth_shared_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 241:0-245:19 *) Definition list_nth_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -590,7 +636,8 @@ Definition list_nth_shared_loop_pair_merge list_nth_shared_loop_pair_merge_loop T n ls0 ls1 i . -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 259:0-274:1 *) Fixpoint list_nth_mut_shared_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -614,7 +661,8 @@ Fixpoint list_nth_mut_shared_loop_pair_loop end . -(** [loops::list_nth_mut_shared_loop_pair]: forward function *) +(** [loops::list_nth_mut_shared_loop_pair]: forward function + Source: 'src/loops.rs', lines 259:0-263:23 *) Definition list_nth_mut_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -622,7 +670,8 @@ Definition list_nth_mut_shared_loop_pair list_nth_mut_shared_loop_pair_loop T n ls0 ls1 i . -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 259:0-274:1 *) Fixpoint list_nth_mut_shared_loop_pair_loop_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -647,7 +696,8 @@ Fixpoint list_nth_mut_shared_loop_pair_loop_back end . -(** [loops::list_nth_mut_shared_loop_pair]: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair]: backward function 0 + Source: 'src/loops.rs', lines 259:0-263:23 *) Definition list_nth_mut_shared_loop_pair_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -655,7 +705,8 @@ Definition list_nth_mut_shared_loop_pair_back list_nth_mut_shared_loop_pair_loop_back T n ls0 ls1 i ret . -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 278:0-293:1 *) Fixpoint list_nth_mut_shared_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -679,7 +730,8 @@ Fixpoint list_nth_mut_shared_loop_pair_merge_loop end . -(** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 278:0-282:23 *) Definition list_nth_mut_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -687,7 +739,8 @@ Definition list_nth_mut_shared_loop_pair_merge list_nth_mut_shared_loop_pair_merge_loop T n ls0 ls1 i . -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 278:0-293:1 *) Fixpoint list_nth_mut_shared_loop_pair_merge_loop_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -713,7 +766,8 @@ Fixpoint list_nth_mut_shared_loop_pair_merge_loop_back end . -(** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 278:0-282:23 *) Definition list_nth_mut_shared_loop_pair_merge_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -721,7 +775,8 @@ Definition list_nth_mut_shared_loop_pair_merge_back list_nth_mut_shared_loop_pair_merge_loop_back T n ls0 ls1 i ret . -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 297:0-312:1 *) Fixpoint list_nth_shared_mut_loop_pair_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -745,7 +800,8 @@ Fixpoint list_nth_shared_mut_loop_pair_loop end . -(** [loops::list_nth_shared_mut_loop_pair]: forward function *) +(** [loops::list_nth_shared_mut_loop_pair]: forward function + Source: 'src/loops.rs', lines 297:0-301:23 *) Definition list_nth_shared_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -753,7 +809,8 @@ Definition list_nth_shared_mut_loop_pair list_nth_shared_mut_loop_pair_loop T n ls0 ls1 i . -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 + Source: 'src/loops.rs', lines 297:0-312:1 *) Fixpoint list_nth_shared_mut_loop_pair_loop_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -778,7 +835,8 @@ Fixpoint list_nth_shared_mut_loop_pair_loop_back end . -(** [loops::list_nth_shared_mut_loop_pair]: backward function 1 *) +(** [loops::list_nth_shared_mut_loop_pair]: backward function 1 + Source: 'src/loops.rs', lines 297:0-301:23 *) Definition list_nth_shared_mut_loop_pair_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -786,7 +844,8 @@ Definition list_nth_shared_mut_loop_pair_back list_nth_shared_mut_loop_pair_loop_back T n ls0 ls1 i ret . -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 316:0-331:1 *) Fixpoint list_nth_shared_mut_loop_pair_merge_loop (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -810,7 +869,8 @@ Fixpoint list_nth_shared_mut_loop_pair_merge_loop end . -(** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 316:0-320:23 *) Definition list_nth_shared_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) @@ -818,7 +878,8 @@ Definition list_nth_shared_mut_loop_pair_merge list_nth_shared_mut_loop_pair_merge_loop T n ls0 ls1 i . -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 316:0-331:1 *) Fixpoint list_nth_shared_mut_loop_pair_merge_loop_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) @@ -844,7 +905,8 @@ Fixpoint list_nth_shared_mut_loop_pair_merge_loop_back end . -(** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 316:0-320:23 *) Definition list_nth_shared_mut_loop_pair_merge_back (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) (ret : T) : result (List_t T) diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index 376e722c..b044d24f 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -8,14 +8,16 @@ Import ListNotations. Local Open Scope Primitives_scope. Module NoNestedBorrows. -(** [no_nested_borrows::Pair] *) +(** [no_nested_borrows::Pair] + Source: 'src/no_nested_borrows.rs', lines 4:0-4:23 *) Record Pair_t (T1 T2 : Type) := mkPair_t { pair_x : T1; pair_y : T2; }. Arguments mkPair_t { _ _ }. Arguments pair_x { _ _ }. Arguments pair_y { _ _ }. -(** [no_nested_borrows::List] *) +(** [no_nested_borrows::List] + Source: 'src/no_nested_borrows.rs', lines 9:0-9:16 *) Inductive List_t (T : Type) := | List_Cons : T -> List_t T -> List_t T | List_Nil : List_t T @@ -24,21 +26,26 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. -(** [no_nested_borrows::One] *) +(** [no_nested_borrows::One] + Source: 'src/no_nested_borrows.rs', lines 20:0-20:16 *) Inductive One_t (T1 : Type) := | One_One : T1 -> One_t T1. Arguments One_One { _ }. -(** [no_nested_borrows::EmptyEnum] *) +(** [no_nested_borrows::EmptyEnum] + Source: 'src/no_nested_borrows.rs', lines 26:0-26:18 *) Inductive EmptyEnum_t := | EmptyEnum_Empty : EmptyEnum_t. -(** [no_nested_borrows::Enum] *) +(** [no_nested_borrows::Enum] + Source: 'src/no_nested_borrows.rs', lines 32:0-32:13 *) Inductive Enum_t := | Enum_Variant1 : Enum_t | Enum_Variant2 : Enum_t. -(** [no_nested_borrows::EmptyStruct] *) +(** [no_nested_borrows::EmptyStruct] + Source: 'src/no_nested_borrows.rs', lines 39:0-39:22 *) Record EmptyStruct_t := mkEmptyStruct_t { }. -(** [no_nested_borrows::Sum] *) +(** [no_nested_borrows::Sum] + Source: 'src/no_nested_borrows.rs', lines 41:0-41:20 *) Inductive Sum_t (T1 T2 : Type) := | Sum_Left : T1 -> Sum_t T1 T2 | Sum_Right : T2 -> Sum_t T1 T2 @@ -47,59 +54,72 @@ Inductive Sum_t (T1 T2 : Type) := Arguments Sum_Left { _ _ }. Arguments Sum_Right { _ _ }. -(** [no_nested_borrows::neg_test]: forward function *) +(** [no_nested_borrows::neg_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 48:0-48:30 *) Definition neg_test (x : i32) : result i32 := i32_neg x. -(** [no_nested_borrows::add_test]: forward function *) +(** [no_nested_borrows::add_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 54:0-54:38 *) Definition add_test (x : u32) (y : u32) : result u32 := u32_add x y. -(** [no_nested_borrows::subs_test]: forward function *) +(** [no_nested_borrows::subs_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 60:0-60:39 *) Definition subs_test (x : u32) (y : u32) : result u32 := u32_sub x y. -(** [no_nested_borrows::div_test]: forward function *) +(** [no_nested_borrows::div_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 66:0-66:38 *) Definition div_test (x : u32) (y : u32) : result u32 := u32_div x y. -(** [no_nested_borrows::div_test1]: forward function *) +(** [no_nested_borrows::div_test1]: forward function + Source: 'src/no_nested_borrows.rs', lines 73:0-73:31 *) Definition div_test1 (x : u32) : result u32 := u32_div x 2%u32. -(** [no_nested_borrows::rem_test]: forward function *) +(** [no_nested_borrows::rem_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 78:0-78:38 *) Definition rem_test (x : u32) (y : u32) : result u32 := u32_rem x y. -(** [no_nested_borrows::mul_test]: forward function *) +(** [no_nested_borrows::mul_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 82:0-82:38 *) Definition mul_test (x : u32) (y : u32) : result u32 := u32_mul x y. -(** [no_nested_borrows::CONST0] *) +(** [no_nested_borrows::CONST0] + Source: 'src/no_nested_borrows.rs', lines 91:0-91:23 *) Definition const0_body : result usize := usize_add 1%usize 1%usize. Definition const0_c : usize := const0_body%global. -(** [no_nested_borrows::CONST1] *) +(** [no_nested_borrows::CONST1] + Source: 'src/no_nested_borrows.rs', lines 92:0-92:23 *) Definition const1_body : result usize := usize_mul 2%usize 2%usize. Definition const1_c : usize := const1_body%global. -(** [no_nested_borrows::cast_test]: forward function *) +(** [no_nested_borrows::cast_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 94:0-94:31 *) Definition cast_test (x : u32) : result i32 := scalar_cast U32 I32 x. -(** [no_nested_borrows::test2]: forward function *) +(** [no_nested_borrows::test2]: forward function + Source: 'src/no_nested_borrows.rs', lines 99:0-99:14 *) Definition test2 : result unit := _ <- u32_add 23%u32 44%u32; Return tt. (** Unit test for [no_nested_borrows::test2] *) Check (test2 )%return. -(** [no_nested_borrows::get_max]: forward function *) +(** [no_nested_borrows::get_max]: forward function + Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 *) Definition get_max (x : u32) (y : u32) : result u32 := if x s>= y then Return x else Return y . -(** [no_nested_borrows::test3]: forward function *) +(** [no_nested_borrows::test3]: forward function + Source: 'src/no_nested_borrows.rs', lines 119:0-119:14 *) Definition test3 : result unit := x <- get_max 4%u32 3%u32; y <- get_max 10%u32 11%u32; @@ -110,7 +130,8 @@ Definition test3 : result unit := (** Unit test for [no_nested_borrows::test3] *) Check (test3 )%return. -(** [no_nested_borrows::test_neg1]: forward function *) +(** [no_nested_borrows::test_neg1]: forward function + Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 *) Definition test_neg1 : result unit := y <- i32_neg 3%i32; if negb (y s= (-3)%i32) then Fail_ Failure else Return tt . @@ -118,7 +139,8 @@ Definition test_neg1 : result unit := (** Unit test for [no_nested_borrows::test_neg1] *) Check (test_neg1 )%return. -(** [no_nested_borrows::refs_test1]: forward function *) +(** [no_nested_borrows::refs_test1]: forward function + Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 *) Definition refs_test1 : result unit := if negb (1%i32 s= 1%i32) then Fail_ Failure else Return tt . @@ -126,7 +148,8 @@ Definition refs_test1 : result unit := (** Unit test for [no_nested_borrows::refs_test1] *) Check (refs_test1 )%return. -(** [no_nested_borrows::refs_test2]: forward function *) +(** [no_nested_borrows::refs_test2]: forward function + Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 *) Definition refs_test2 : result unit := if negb (2%i32 s= 2%i32) then Fail_ Failure @@ -142,14 +165,16 @@ Definition refs_test2 : result unit := (** Unit test for [no_nested_borrows::refs_test2] *) Check (refs_test2 )%return. -(** [no_nested_borrows::test_list1]: forward function *) +(** [no_nested_borrows::test_list1]: forward function + Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 *) Definition test_list1 : result unit := Return tt. (** Unit test for [no_nested_borrows::test_list1] *) Check (test_list1 )%return. -(** [no_nested_borrows::test_box1]: forward function *) +(** [no_nested_borrows::test_box1]: forward function + Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 *) Definition test_box1 : result unit := let b := 0%i32 in b0 <- alloc_boxed_Box_deref_mut_back i32 b 1%i32; @@ -160,21 +185,25 @@ Definition test_box1 : result unit := (** Unit test for [no_nested_borrows::test_box1] *) Check (test_box1 )%return. -(** [no_nested_borrows::copy_int]: forward function *) +(** [no_nested_borrows::copy_int]: forward function + Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 *) Definition copy_int (x : i32) : result i32 := Return x. -(** [no_nested_borrows::test_unreachable]: forward function *) +(** [no_nested_borrows::test_unreachable]: forward function + Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 *) Definition test_unreachable (b : bool) : result unit := if b then Fail_ Failure else Return tt . -(** [no_nested_borrows::test_panic]: forward function *) +(** [no_nested_borrows::test_panic]: forward function + Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 *) Definition test_panic (b : bool) : result unit := if b then Fail_ Failure else Return tt . -(** [no_nested_borrows::test_copy_int]: forward function *) +(** [no_nested_borrows::test_copy_int]: forward function + Source: 'src/no_nested_borrows.rs', lines 196:0-196:22 *) Definition test_copy_int : result unit := y <- copy_int 0%i32; if negb (0%i32 s= y) then Fail_ Failure else Return tt . @@ -182,12 +211,14 @@ Definition test_copy_int : result unit := (** Unit test for [no_nested_borrows::test_copy_int] *) Check (test_copy_int )%return. -(** [no_nested_borrows::is_cons]: forward function *) +(** [no_nested_borrows::is_cons]: forward function + Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 *) Definition is_cons (T : Type) (l : List_t T) : result bool := match l with | List_Cons t l0 => Return true | List_Nil => Return false end . -(** [no_nested_borrows::test_is_cons]: forward function *) +(** [no_nested_borrows::test_is_cons]: forward function + Source: 'src/no_nested_borrows.rs', lines 210:0-210:21 *) Definition test_is_cons : result unit := let l := List_Nil in b <- is_cons i32 (List_Cons 0%i32 l); @@ -197,7 +228,8 @@ Definition test_is_cons : result unit := (** Unit test for [no_nested_borrows::test_is_cons] *) Check (test_is_cons )%return. -(** [no_nested_borrows::split_list]: forward function *) +(** [no_nested_borrows::split_list]: forward function + Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 *) Definition split_list (T : Type) (l : List_t T) : result (T * (List_t T)) := match l with | List_Cons hd tl => Return (hd, tl) @@ -205,7 +237,8 @@ Definition split_list (T : Type) (l : List_t T) : result (T * (List_t T)) := end . -(** [no_nested_borrows::test_split_list]: forward function *) +(** [no_nested_borrows::test_split_list]: forward function + Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 *) Definition test_split_list : result unit := let l := List_Nil in p <- split_list i32 (List_Cons 0%i32 l); @@ -216,18 +249,21 @@ Definition test_split_list : result unit := (** Unit test for [no_nested_borrows::test_split_list] *) Check (test_split_list )%return. -(** [no_nested_borrows::choose]: forward function *) +(** [no_nested_borrows::choose]: forward function + Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . -(** [no_nested_borrows::choose]: backward function 0 *) +(** [no_nested_borrows::choose]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) Definition choose_back (T : Type) (b : bool) (x : T) (y : T) (ret : T) : result (T * T) := if b then Return (ret, y) else Return (x, ret) . -(** [no_nested_borrows::choose_test]: forward function *) +(** [no_nested_borrows::choose_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 *) Definition choose_test : result unit := z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; @@ -244,16 +280,19 @@ Definition choose_test : result unit := (** Unit test for [no_nested_borrows::choose_test] *) Check (choose_test )%return. -(** [no_nested_borrows::test_char]: forward function *) +(** [no_nested_borrows::test_char]: forward function + Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 *) Definition test_char : result char := Return (char_of_byte Coq.Init.Byte.x61). -(** [no_nested_borrows::Tree] *) +(** [no_nested_borrows::Tree] + Source: 'src/no_nested_borrows.rs', lines 256:0-256:16 *) Inductive Tree_t (T : Type) := | Tree_Leaf : T -> Tree_t T | Tree_Node : T -> NodeElem_t T -> Tree_t T -> Tree_t T -(** [no_nested_borrows::NodeElem] *) +(** [no_nested_borrows::NodeElem] + Source: 'src/no_nested_borrows.rs', lines 261:0-261:20 *) with NodeElem_t (T : Type) := | NodeElem_Cons : Tree_t T -> NodeElem_t T -> NodeElem_t T | NodeElem_Nil : NodeElem_t T @@ -265,7 +304,8 @@ Arguments Tree_Node { _ }. Arguments NodeElem_Cons { _ }. Arguments NodeElem_Nil { _ }. -(** [no_nested_borrows::list_length]: forward function *) +(** [no_nested_borrows::list_length]: forward function + Source: 'src/no_nested_borrows.rs', lines 296:0-296:48 *) Fixpoint list_length (T : Type) (l : List_t T) : result u32 := match l with | List_Cons t l1 => i <- list_length T l1; u32_add 1%u32 i @@ -273,7 +313,8 @@ Fixpoint list_length (T : Type) (l : List_t T) : result u32 := end . -(** [no_nested_borrows::list_nth_shared]: forward function *) +(** [no_nested_borrows::list_nth_shared]: forward function + Source: 'src/no_nested_borrows.rs', lines 304:0-304:62 *) Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := match l with | List_Cons x tl => @@ -284,7 +325,8 @@ Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := end . -(** [no_nested_borrows::list_nth_mut]: forward function *) +(** [no_nested_borrows::list_nth_mut]: forward function + Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with | List_Cons x tl => @@ -295,7 +337,8 @@ Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := end . -(** [no_nested_borrows::list_nth_mut]: backward function 0 *) +(** [no_nested_borrows::list_nth_mut]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with @@ -310,7 +353,8 @@ Fixpoint list_nth_mut_back end . -(** [no_nested_borrows::list_rev_aux]: forward function *) +(** [no_nested_borrows::list_rev_aux]: forward function + Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 *) Fixpoint list_rev_aux (T : Type) (li : List_t T) (lo : List_t T) : result (List_t T) := match li with @@ -320,13 +364,15 @@ Fixpoint list_rev_aux . (** [no_nested_borrows::list_rev]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/no_nested_borrows.rs', lines 350:0-350:42 *) Definition list_rev (T : Type) (l : List_t T) : result (List_t T) := let li := core_mem_replace (List_t T) l List_Nil in list_rev_aux T li List_Nil . -(** [no_nested_borrows::test_list_functions]: forward function *) +(** [no_nested_borrows::test_list_functions]: forward function + Source: 'src/no_nested_borrows.rs', lines 355:0-355:28 *) Definition test_list_functions : result unit := let l := List_Nil in let l0 := List_Cons 2%i32 l in @@ -363,63 +409,74 @@ Definition test_list_functions : result unit := (** Unit test for [no_nested_borrows::test_list_functions] *) Check (test_list_functions )%return. -(** [no_nested_borrows::id_mut_pair1]: forward function *) +(** [no_nested_borrows::id_mut_pair1]: forward function + Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) Definition id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . -(** [no_nested_borrows::id_mut_pair1]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair1]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) Definition id_mut_pair1_back (T1 T2 : Type) (x : T1) (y : T2) (ret : (T1 * T2)) : result (T1 * T2) := let (t, t0) := ret in Return (t, t0) . -(** [no_nested_borrows::id_mut_pair2]: forward function *) +(** [no_nested_borrows::id_mut_pair2]: forward function + Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) Definition id_mut_pair2 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . -(** [no_nested_borrows::id_mut_pair2]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair2]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) Definition id_mut_pair2_back (T1 T2 : Type) (p : (T1 * T2)) (ret : (T1 * T2)) : result (T1 * T2) := let (t, t0) := ret in Return (t, t0) . -(** [no_nested_borrows::id_mut_pair3]: forward function *) +(** [no_nested_borrows::id_mut_pair3]: forward function + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) Definition id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . -(** [no_nested_borrows::id_mut_pair3]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair3]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) Definition id_mut_pair3_back'a (T1 T2 : Type) (x : T1) (y : T2) (ret : T1) : result T1 := Return ret . -(** [no_nested_borrows::id_mut_pair3]: backward function 1 *) +(** [no_nested_borrows::id_mut_pair3]: backward function 1 + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) Definition id_mut_pair3_back'b (T1 T2 : Type) (x : T1) (y : T2) (ret : T2) : result T2 := Return ret . -(** [no_nested_borrows::id_mut_pair4]: forward function *) +(** [no_nested_borrows::id_mut_pair4]: forward function + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) Definition id_mut_pair4 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . -(** [no_nested_borrows::id_mut_pair4]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair4]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) Definition id_mut_pair4_back'a (T1 T2 : Type) (p : (T1 * T2)) (ret : T1) : result T1 := Return ret . -(** [no_nested_borrows::id_mut_pair4]: backward function 1 *) +(** [no_nested_borrows::id_mut_pair4]: backward function 1 + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) Definition id_mut_pair4_back'b (T1 T2 : Type) (p : (T1 * T2)) (ret : T2) : result T2 := Return ret . -(** [no_nested_borrows::StructWithTuple] *) +(** [no_nested_borrows::StructWithTuple] + Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 *) Record StructWithTuple_t (T1 T2 : Type) := mkStructWithTuple_t { structWithTuple_p : (T1 * T2); @@ -429,22 +486,26 @@ mkStructWithTuple_t { Arguments mkStructWithTuple_t { _ _ }. Arguments structWithTuple_p { _ _ }. -(** [no_nested_borrows::new_tuple1]: forward function *) +(** [no_nested_borrows::new_tuple1]: forward function + Source: 'src/no_nested_borrows.rs', lines 394:0-394:48 *) Definition new_tuple1 : result (StructWithTuple_t u32 u32) := Return {| structWithTuple_p := (1%u32, 2%u32) |} . -(** [no_nested_borrows::new_tuple2]: forward function *) +(** [no_nested_borrows::new_tuple2]: forward function + Source: 'src/no_nested_borrows.rs', lines 398:0-398:48 *) Definition new_tuple2 : result (StructWithTuple_t i16 i16) := Return {| structWithTuple_p := (1%i16, 2%i16) |} . -(** [no_nested_borrows::new_tuple3]: forward function *) +(** [no_nested_borrows::new_tuple3]: forward function + Source: 'src/no_nested_borrows.rs', lines 402:0-402:48 *) Definition new_tuple3 : result (StructWithTuple_t u64 i64) := Return {| structWithTuple_p := (1%u64, 2%i64) |} . -(** [no_nested_borrows::StructWithPair] *) +(** [no_nested_borrows::StructWithPair] + Source: 'src/no_nested_borrows.rs', lines 407:0-407:33 *) Record StructWithPair_t (T1 T2 : Type) := mkStructWithPair_t { structWithPair_p : Pair_t T1 T2; @@ -454,12 +515,14 @@ mkStructWithPair_t { Arguments mkStructWithPair_t { _ _ }. Arguments structWithPair_p { _ _ }. -(** [no_nested_borrows::new_pair1]: forward function *) +(** [no_nested_borrows::new_pair1]: forward function + Source: 'src/no_nested_borrows.rs', lines 411:0-411:46 *) Definition new_pair1 : result (StructWithPair_t u32 u32) := Return {| structWithPair_p := {| pair_x := 1%u32; pair_y := 2%u32 |} |} . -(** [no_nested_borrows::test_constants]: forward function *) +(** [no_nested_borrows::test_constants]: forward function + Source: 'src/no_nested_borrows.rs', lines 419:0-419:23 *) Definition test_constants : result unit := swt <- new_tuple1; let (i, _) := swt.(structWithTuple_p) in @@ -485,7 +548,8 @@ Definition test_constants : result unit := (** Unit test for [no_nested_borrows::test_constants] *) Check (test_constants )%return. -(** [no_nested_borrows::test_weird_borrows1]: forward function *) +(** [no_nested_borrows::test_weird_borrows1]: forward function + Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 *) Definition test_weird_borrows1 : result unit := Return tt. @@ -493,27 +557,32 @@ Definition test_weird_borrows1 : result unit := Check (test_weird_borrows1 )%return. (** [no_nested_borrows::test_mem_replace]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/no_nested_borrows.rs', lines 438:0-438:37 *) Definition test_mem_replace (px : u32) : result u32 := let y := core_mem_replace u32 px 1%u32 in if negb (y s= 0%u32) then Fail_ Failure else Return 2%u32 . -(** [no_nested_borrows::test_shared_borrow_bool1]: forward function *) +(** [no_nested_borrows::test_shared_borrow_bool1]: forward function + Source: 'src/no_nested_borrows.rs', lines 445:0-445:47 *) Definition test_shared_borrow_bool1 (b : bool) : result u32 := if b then Return 0%u32 else Return 1%u32 . -(** [no_nested_borrows::test_shared_borrow_bool2]: forward function *) +(** [no_nested_borrows::test_shared_borrow_bool2]: forward function + Source: 'src/no_nested_borrows.rs', lines 458:0-458:40 *) Definition test_shared_borrow_bool2 : result u32 := Return 0%u32. -(** [no_nested_borrows::test_shared_borrow_enum1]: forward function *) +(** [no_nested_borrows::test_shared_borrow_enum1]: forward function + Source: 'src/no_nested_borrows.rs', lines 473:0-473:52 *) Definition test_shared_borrow_enum1 (l : List_t u32) : result u32 := match l with | List_Cons i l0 => Return 1%u32 | List_Nil => Return 0%u32 end . -(** [no_nested_borrows::test_shared_borrow_enum2]: forward function *) +(** [no_nested_borrows::test_shared_borrow_enum2]: forward function + Source: 'src/no_nested_borrows.rs', lines 485:0-485:40 *) Definition test_shared_borrow_enum2 : result u32 := Return 0%u32. diff --git a/tests/coq/misc/Paper.v b/tests/coq/misc/Paper.v index d3852e6b..4a49096f 100644 --- a/tests/coq/misc/Paper.v +++ b/tests/coq/misc/Paper.v @@ -9,11 +9,13 @@ Local Open Scope Primitives_scope. Module Paper. (** [paper::ref_incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/paper.rs', lines 4:0-4:28 *) Definition ref_incr (x : i32) : result i32 := i32_add x 1%i32. -(** [paper::test_incr]: forward function *) +(** [paper::test_incr]: forward function + Source: 'src/paper.rs', lines 8:0-8:18 *) Definition test_incr : result unit := x <- ref_incr 0%i32; if negb (x s= 1%i32) then Fail_ Failure else Return tt . @@ -21,18 +23,21 @@ Definition test_incr : result unit := (** Unit test for [paper::test_incr] *) Check (test_incr )%return. -(** [paper::choose]: forward function *) +(** [paper::choose]: forward function + Source: 'src/paper.rs', lines 15:0-15:70 *) Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . -(** [paper::choose]: backward function 0 *) +(** [paper::choose]: backward function 0 + Source: 'src/paper.rs', lines 15:0-15:70 *) Definition choose_back (T : Type) (b : bool) (x : T) (y : T) (ret : T) : result (T * T) := if b then Return (ret, y) else Return (x, ret) . -(** [paper::test_choose]: forward function *) +(** [paper::test_choose]: forward function + Source: 'src/paper.rs', lines 23:0-23:20 *) Definition test_choose : result unit := z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; @@ -49,7 +54,8 @@ Definition test_choose : result unit := (** Unit test for [paper::test_choose] *) Check (test_choose )%return. -(** [paper::List] *) +(** [paper::List] + Source: 'src/paper.rs', lines 35:0-35:16 *) Inductive List_t (T : Type) := | List_Cons : T -> List_t T -> List_t T | List_Nil : List_t T @@ -58,7 +64,8 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. -(** [paper::list_nth_mut]: forward function *) +(** [paper::list_nth_mut]: forward function + Source: 'src/paper.rs', lines 42:0-42:67 *) Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with | List_Cons x tl => @@ -69,7 +76,8 @@ Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := end . -(** [paper::list_nth_mut]: backward function 0 *) +(** [paper::list_nth_mut]: backward function 0 + Source: 'src/paper.rs', lines 42:0-42:67 *) Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with @@ -84,7 +92,8 @@ Fixpoint list_nth_mut_back end . -(** [paper::sum]: forward function *) +(** [paper::sum]: forward function + Source: 'src/paper.rs', lines 57:0-57:32 *) Fixpoint sum (l : List_t i32) : result i32 := match l with | List_Cons x tl => i <- sum tl; i32_add x i @@ -92,7 +101,8 @@ Fixpoint sum (l : List_t i32) : result i32 := end . -(** [paper::test_nth]: forward function *) +(** [paper::test_nth]: forward function + Source: 'src/paper.rs', lines 68:0-68:17 *) Definition test_nth : result unit := let l := List_Nil in let l0 := List_Cons 3%i32 l in @@ -107,7 +117,8 @@ Definition test_nth : result unit := (** Unit test for [paper::test_nth] *) Check (test_nth )%return. -(** [paper::call_choose]: forward function *) +(** [paper::call_choose]: forward function + Source: 'src/paper.rs', lines 76:0-76:44 *) Definition call_choose (p : (u32 * u32)) : result u32 := let (px, py) := p in pz <- choose u32 true px py; diff --git a/tests/coq/misc/PoloniusList.v b/tests/coq/misc/PoloniusList.v index 4848444f..a0820e40 100644 --- a/tests/coq/misc/PoloniusList.v +++ b/tests/coq/misc/PoloniusList.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module PoloniusList. -(** [polonius_list::List] *) +(** [polonius_list::List] + Source: 'src/polonius_list.rs', lines 3:0-3:16 *) Inductive List_t (T : Type) := | List_Cons : T -> List_t T -> List_t T | List_Nil : List_t T @@ -17,7 +18,8 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. -(** [polonius_list::get_list_at_x]: forward function *) +(** [polonius_list::get_list_at_x]: forward function + Source: 'src/polonius_list.rs', lines 13:0-13:76 *) Fixpoint get_list_at_x (ls : List_t u32) (x : u32) : result (List_t u32) := match ls with | List_Cons hd tl => @@ -26,7 +28,8 @@ Fixpoint get_list_at_x (ls : List_t u32) (x : u32) : result (List_t u32) := end . -(** [polonius_list::get_list_at_x]: backward function 0 *) +(** [polonius_list::get_list_at_x]: backward function 0 + Source: 'src/polonius_list.rs', lines 13:0-13:76 *) Fixpoint get_list_at_x_back (ls : List_t u32) (x : u32) (ret : List_t u32) : result (List_t u32) := match ls with diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index a25d5089..f0875a29 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -8,7 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Module Traits. -(** Trait declaration: [traits::BoolTrait] *) +(** Trait declaration: [traits::BoolTrait] + Source: 'src/traits.rs', lines 1:0-1:19 *) Record BoolTrait_t (Self : Type) := mkBoolTrait_t { BoolTrait_t_get_bool : Self -> result bool; }. @@ -16,39 +17,46 @@ Record BoolTrait_t (Self : Type) := mkBoolTrait_t { Arguments mkBoolTrait_t { _ }. Arguments BoolTrait_t_get_bool { _ }. -(** [traits::{bool}::get_bool]: forward function *) +(** [traits::{bool}::get_bool]: forward function + Source: 'src/traits.rs', lines 12:4-12:30 *) Definition bool_get_bool (self : bool) : result bool := Return self. -(** Trait implementation: [traits::{bool}] *) +(** Trait implementation: [traits::{bool}] + Source: 'src/traits.rs', lines 11:0-11:23 *) Definition traits_BoolTraitBoolInst : BoolTrait_t bool := {| BoolTrait_t_get_bool := bool_get_bool; |}. -(** [traits::BoolTrait::ret_true]: forward function *) +(** [traits::BoolTrait::ret_true]: forward function + Source: 'src/traits.rs', lines 6:4-6:30 *) Definition boolTrait_ret_true {Self : Type} (self_clause : BoolTrait_t Self) (self : Self) : result bool := Return true . -(** [traits::test_bool_trait_bool]: forward function *) +(** [traits::test_bool_trait_bool]: forward function + Source: 'src/traits.rs', lines 17:0-17:44 *) Definition test_bool_trait_bool (x : bool) : result bool := b <- bool_get_bool x; if b then boolTrait_ret_true traits_BoolTraitBoolInst x else Return false . -(** [traits::{core::option::Option#1}::get_bool]: forward function *) +(** [traits::{core::option::Option#1}::get_bool]: forward function + Source: 'src/traits.rs', lines 23:4-23:30 *) Definition option_get_bool (T : Type) (self : option T) : result bool := match self with | None => Return false | Some t => Return true end . -(** Trait implementation: [traits::{core::option::Option#1}] *) +(** Trait implementation: [traits::{core::option::Option#1}] + Source: 'src/traits.rs', lines 22:0-22:31 *) Definition traits_BoolTraitcoreoptionOptionTInst (T : Type) : BoolTrait_t (option T) := {| BoolTrait_t_get_bool := option_get_bool T; |}. -(** [traits::test_bool_trait_option]: forward function *) +(** [traits::test_bool_trait_option]: forward function + Source: 'src/traits.rs', lines 31:0-31:54 *) Definition test_bool_trait_option (T : Type) (x : option T) : result bool := b <- option_get_bool T x; if b @@ -56,13 +64,15 @@ Definition test_bool_trait_option (T : Type) (x : option T) : result bool := else Return false . -(** [traits::test_bool_trait]: forward function *) +(** [traits::test_bool_trait]: forward function + Source: 'src/traits.rs', lines 35:0-35:50 *) Definition test_bool_trait (T : Type) (inst : BoolTrait_t T) (x : T) : result bool := inst.(BoolTrait_t_get_bool) x . -(** Trait declaration: [traits::ToU64] *) +(** Trait declaration: [traits::ToU64] + Source: 'src/traits.rs', lines 39:0-39:15 *) Record ToU64_t (Self : Type) := mkToU64_t { ToU64_t_to_u64 : Self -> result u64; }. @@ -70,16 +80,19 @@ Record ToU64_t (Self : Type) := mkToU64_t { Arguments mkToU64_t { _ }. Arguments ToU64_t_to_u64 { _ }. -(** [traits::{u64#2}::to_u64]: forward function *) +(** [traits::{u64#2}::to_u64]: forward function + Source: 'src/traits.rs', lines 44:4-44:26 *) Definition u64_to_u64 (self : u64) : result u64 := Return self. -(** Trait implementation: [traits::{u64#2}] *) +(** Trait implementation: [traits::{u64#2}] + Source: 'src/traits.rs', lines 43:0-43:18 *) Definition traits_ToU64U64Inst : ToU64_t u64 := {| ToU64_t_to_u64 := u64_to_u64; |}. -(** [traits::{(A, A)#3}::to_u64]: forward function *) +(** [traits::{(A, A)#3}::to_u64]: forward function + Source: 'src/traits.rs', lines 50:4-50:26 *) Definition pair_to_u64 (A : Type) (inst : ToU64_t A) (self : (A * A)) : result u64 := let (t, t0) := self in @@ -88,55 +101,65 @@ Definition pair_to_u64 u64_add i i0 . -(** Trait implementation: [traits::{(A, A)#3}] *) +(** Trait implementation: [traits::{(A, A)#3}] + Source: 'src/traits.rs', lines 49:0-49:31 *) Definition traits_ToU64TupleAAInst (A : Type) (inst : ToU64_t A) : ToU64_t (A * A) := {| ToU64_t_to_u64 := pair_to_u64 A inst; |}. -(** [traits::f]: forward function *) +(** [traits::f]: forward function + Source: 'src/traits.rs', lines 55:0-55:36 *) Definition f (T : Type) (inst : ToU64_t T) (x : (T * T)) : result u64 := pair_to_u64 T inst x . -(** [traits::g]: forward function *) +(** [traits::g]: forward function + Source: 'src/traits.rs', lines 59:0-61:18 *) Definition g (T : Type) (inst : ToU64_t (T * T)) (x : (T * T)) : result u64 := inst.(ToU64_t_to_u64) x . -(** [traits::h0]: forward function *) +(** [traits::h0]: forward function + Source: 'src/traits.rs', lines 66:0-66:24 *) Definition h0 (x : u64) : result u64 := u64_to_u64 x. -(** [traits::Wrapper] *) +(** [traits::Wrapper] + Source: 'src/traits.rs', lines 70:0-70:21 *) Record Wrapper_t (T : Type) := mkWrapper_t { wrapper_x : T; }. Arguments mkWrapper_t { _ }. Arguments wrapper_x { _ }. -(** [traits::{traits::Wrapper#4}::to_u64]: forward function *) +(** [traits::{traits::Wrapper#4}::to_u64]: forward function + Source: 'src/traits.rs', lines 75:4-75:26 *) Definition wrapper_to_u64 (T : Type) (inst : ToU64_t T) (self : Wrapper_t T) : result u64 := inst.(ToU64_t_to_u64) self.(wrapper_x) . -(** Trait implementation: [traits::{traits::Wrapper#4}] *) +(** Trait implementation: [traits::{traits::Wrapper#4}] + Source: 'src/traits.rs', lines 74:0-74:35 *) Definition traits_ToU64traitsWrapperTInst (T : Type) (inst : ToU64_t T) : ToU64_t (Wrapper_t T) := {| ToU64_t_to_u64 := wrapper_to_u64 T inst; |}. -(** [traits::h1]: forward function *) +(** [traits::h1]: forward function + Source: 'src/traits.rs', lines 80:0-80:33 *) Definition h1 (x : Wrapper_t u64) : result u64 := wrapper_to_u64 u64 traits_ToU64U64Inst x . -(** [traits::h2]: forward function *) +(** [traits::h2]: forward function + Source: 'src/traits.rs', lines 84:0-84:41 *) Definition h2 (T : Type) (inst : ToU64_t T) (x : Wrapper_t T) : result u64 := wrapper_to_u64 T inst x . -(** Trait declaration: [traits::ToType] *) +(** Trait declaration: [traits::ToType] + Source: 'src/traits.rs', lines 88:0-88:19 *) Record ToType_t (Self T : Type) := mkToType_t { ToType_t_to_type : Self -> result T; }. @@ -144,16 +167,19 @@ Record ToType_t (Self T : Type) := mkToType_t { Arguments mkToType_t { _ _ }. Arguments ToType_t_to_type { _ _ }. -(** [traits::{u64#5}::to_type]: forward function *) +(** [traits::{u64#5}::to_type]: forward function + Source: 'src/traits.rs', lines 93:4-93:28 *) Definition u64_to_type (self : u64) : result bool := Return (self s> 0%u64). -(** Trait implementation: [traits::{u64#5}] *) +(** Trait implementation: [traits::{u64#5}] + Source: 'src/traits.rs', lines 92:0-92:25 *) Definition traits_ToTypeU64BoolInst : ToType_t u64 bool := {| ToType_t_to_type := u64_to_type; |}. -(** Trait declaration: [traits::OfType] *) +(** Trait declaration: [traits::OfType] + Source: 'src/traits.rs', lines 98:0-98:16 *) Record OfType_t (Self : Type) := mkOfType_t { OfType_t_of_type : forall (T : Type) (inst : ToType_t T Self), T -> result Self; @@ -162,7 +188,8 @@ Record OfType_t (Self : Type) := mkOfType_t { Arguments mkOfType_t { _ }. Arguments OfType_t_of_type { _ }. -(** [traits::h3]: forward function *) +(** [traits::h3]: forward function + Source: 'src/traits.rs', lines 104:0-104:50 *) Definition h3 (T1 T2 : Type) (inst : OfType_t T1) (inst0 : ToType_t T2 T1) (y : T2) : result T1 @@ -170,7 +197,8 @@ Definition h3 inst.(OfType_t_of_type) T2 inst0 y . -(** Trait declaration: [traits::OfTypeBis] *) +(** Trait declaration: [traits::OfTypeBis] + Source: 'src/traits.rs', lines 109:0-109:36 *) Record OfTypeBis_t (Self T : Type) := mkOfTypeBis_t { OfTypeBis_tOfTypeBis_t_parent_clause_0 : ToType_t T Self; OfTypeBis_t_of_type : T -> result Self; @@ -180,7 +208,8 @@ Arguments mkOfTypeBis_t { _ _ }. Arguments OfTypeBis_tOfTypeBis_t_parent_clause_0 { _ _ }. Arguments OfTypeBis_t_of_type { _ _ }. -(** [traits::h4]: forward function *) +(** [traits::h4]: forward function + Source: 'src/traits.rs', lines 118:0-118:57 *) Definition h4 (T1 T2 : Type) (inst : OfTypeBis_t T1 T2) (inst0 : ToType_t T2 T1) (y : T2) : result T1 @@ -188,20 +217,23 @@ Definition h4 inst.(OfTypeBis_t_of_type) y . -(** [traits::TestType] *) +(** [traits::TestType] + Source: 'src/traits.rs', lines 122:0-122:22 *) Record TestType_t (T : Type) := mkTestType_t { testType_0 : T; }. Arguments mkTestType_t { _ }. Arguments testType_0 { _ }. -(** [traits::{traits::TestType#6}::test::TestType1] *) +(** [traits::{traits::TestType#6}::test::TestType1] + Source: 'src/traits.rs', lines 127:8-127:24 *) Record TestType_test_TestType1_t := mkTestType_test_TestType1_t { testType_test_TestType1_0 : u64; } . -(** Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] *) +(** Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] + Source: 'src/traits.rs', lines 128:8-128:23 *) Record TestType_test_TestTrait_t (Self : Type) := mkTestType_test_TestTrait_t { TestType_test_TestTrait_t_test : Self -> result bool; }. @@ -209,19 +241,22 @@ Record TestType_test_TestTrait_t (Self : Type) := mkTestType_test_TestTrait_t { Arguments mkTestType_test_TestTrait_t { _ }. Arguments TestType_test_TestTrait_t_test { _ }. -(** [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function *) +(** [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function + Source: 'src/traits.rs', lines 139:12-139:34 *) Definition testType_test_TestType1_test (self : TestType_test_TestType1_t) : result bool := Return (self.(testType_test_TestType1_0) s> 1%u64) . -(** Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] *) +(** Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] + Source: 'src/traits.rs', lines 138:8-138:36 *) Definition traits_TestType_test_TestTraittraitstraitsTestTypeTtestTestType1Inst : TestType_test_TestTrait_t TestType_test_TestType1_t := {| TestType_test_TestTrait_t_test := testType_test_TestType1_test; |}. -(** [traits::{traits::TestType#6}::test]: forward function *) +(** [traits::{traits::TestType#6}::test]: forward function + Source: 'src/traits.rs', lines 126:4-126:36 *) Definition testType_test (T : Type) (inst : ToU64_t T) (self : TestType_t T) (x : T) : result bool := x0 <- inst.(ToU64_t_to_u64) x; @@ -230,26 +265,31 @@ Definition testType_test else Return false . -(** [traits::BoolWrapper] *) +(** [traits::BoolWrapper] + Source: 'src/traits.rs', lines 150:0-150:22 *) Record BoolWrapper_t := mkBoolWrapper_t { boolWrapper_0 : bool; }. -(** [traits::{traits::BoolWrapper#7}::to_type]: forward function *) +(** [traits::{traits::BoolWrapper#7}::to_type]: forward function + Source: 'src/traits.rs', lines 156:4-156:25 *) Definition boolWrapper_to_type (T : Type) (inst : ToType_t bool T) (self : BoolWrapper_t) : result T := inst.(ToType_t_to_type) self.(boolWrapper_0) . -(** Trait implementation: [traits::{traits::BoolWrapper#7}] *) +(** Trait implementation: [traits::{traits::BoolWrapper#7}] + Source: 'src/traits.rs', lines 152:0-152:33 *) Definition traits_ToTypetraitsBoolWrapperTInst (T : Type) (inst : ToType_t bool T) : ToType_t BoolWrapper_t T := {| ToType_t_to_type := boolWrapper_to_type T inst; |}. -(** [traits::WithConstTy::LEN2] *) +(** [traits::WithConstTy::LEN2] + Source: 'src/traits.rs', lines 164:4-164:21 *) Definition with_const_ty_len2_body : result usize := Return 32%usize. Definition with_const_ty_len2_c : usize := with_const_ty_len2_body%global. -(** Trait declaration: [traits::WithConstTy] *) +(** Trait declaration: [traits::WithConstTy] + Source: 'src/traits.rs', lines 161:0-161:39 *) Record WithConstTy_t (Self : Type) (LEN : usize) := mkWithConstTy_t { WithConstTy_tWithConstTy_t_LEN1 : usize; WithConstTy_tWithConstTy_t_LEN2 : usize; @@ -268,16 +308,19 @@ Arguments WithConstTy_tWithConstTy_t_W { _ _ }. Arguments WithConstTy_tWithConstTy_t_W_clause_0 { _ _ }. Arguments WithConstTy_t_f { _ _ }. -(** [traits::{bool#8}::LEN1] *) +(** [traits::{bool#8}::LEN1] + Source: 'src/traits.rs', lines 175:4-175:21 *) Definition bool_len1_body : result usize := Return 12%usize. Definition bool_len1_c : usize := bool_len1_body%global. (** [traits::{bool#8}::f]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/traits.rs', lines 180:4-180:39 *) Definition bool_f (i : u64) (a : array u8 32%usize) : result u64 := Return i. -(** Trait implementation: [traits::{bool#8}] *) +(** Trait implementation: [traits::{bool#8}] + Source: 'src/traits.rs', lines 174:0-174:29 *) Definition traits_WithConstTyBool32Inst : WithConstTy_t bool 32%usize := {| WithConstTy_tWithConstTy_t_LEN1 := bool_len1_c; WithConstTy_tWithConstTy_t_LEN2 := with_const_ty_len2_c; @@ -287,13 +330,15 @@ Definition traits_WithConstTyBool32Inst : WithConstTy_t bool 32%usize := {| WithConstTy_t_f := bool_f; |}. -(** [traits::use_with_const_ty1]: forward function *) +(** [traits::use_with_const_ty1]: forward function + Source: 'src/traits.rs', lines 183:0-183:75 *) Definition use_with_const_ty1 (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) : result usize := let i := inst.(WithConstTy_tWithConstTy_t_LEN1) in Return i . -(** [traits::use_with_const_ty2]: forward function *) +(** [traits::use_with_const_ty2]: forward function + Source: 'src/traits.rs', lines 187:0-187:73 *) Definition use_with_const_ty2 (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) (w : inst.(WithConstTy_tWithConstTy_t_W)) : @@ -302,7 +347,8 @@ Definition use_with_const_ty2 Return tt . -(** [traits::use_with_const_ty3]: forward function *) +(** [traits::use_with_const_ty3]: forward function + Source: 'src/traits.rs', lines 189:0-189:80 *) Definition use_with_const_ty3 (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) (x : inst.(WithConstTy_tWithConstTy_t_W)) : @@ -311,20 +357,24 @@ Definition use_with_const_ty3 inst.(WithConstTy_tWithConstTy_t_W_clause_0).(ToU64_t_to_u64) x . -(** [traits::test_where1]: forward function *) +(** [traits::test_where1]: forward function + Source: 'src/traits.rs', lines 193:0-193:40 *) Definition test_where1 (T : Type) (_x : T) : result unit := Return tt. -(** [traits::test_where2]: forward function *) +(** [traits::test_where2]: forward function + Source: 'src/traits.rs', lines 194:0-194:57 *) Definition test_where2 (T : Type) (inst : WithConstTy_t T 32%usize) (_x : u32) : result unit := Return tt . -(** [alloc::string::String] *) +(** [alloc::string::String] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/alloc/src/string.rs', lines 365:0-365:17 *) Axiom alloc_string_String_t : Type. -(** Trait declaration: [traits::ParentTrait0] *) +(** Trait declaration: [traits::ParentTrait0] + Source: 'src/traits.rs', lines 200:0-200:22 *) Record ParentTrait0_t (Self : Type) := mkParentTrait0_t { ParentTrait0_tParentTrait0_t_W : Type; ParentTrait0_t_get_name : Self -> result alloc_string_String_t; @@ -336,12 +386,14 @@ Arguments ParentTrait0_tParentTrait0_t_W { _ }. Arguments ParentTrait0_t_get_name { _ }. Arguments ParentTrait0_t_get_w { _ }. -(** Trait declaration: [traits::ParentTrait1] *) +(** Trait declaration: [traits::ParentTrait1] + Source: 'src/traits.rs', lines 205:0-205:22 *) Record ParentTrait1_t (Self : Type) := mkParentTrait1_t{}. Arguments mkParentTrait1_t { _ }. -(** Trait declaration: [traits::ChildTrait] *) +(** Trait declaration: [traits::ChildTrait] + Source: 'src/traits.rs', lines 206:0-206:49 *) Record ChildTrait_t (Self : Type) := mkChildTrait_t { ChildTrait_tChildTrait_t_parent_clause_0 : ParentTrait0_t Self; ChildTrait_tChildTrait_t_parent_clause_1 : ParentTrait1_t Self; @@ -351,13 +403,15 @@ Arguments mkChildTrait_t { _ }. Arguments ChildTrait_tChildTrait_t_parent_clause_0 { _ }. Arguments ChildTrait_tChildTrait_t_parent_clause_1 { _ }. -(** [traits::test_child_trait1]: forward function *) +(** [traits::test_child_trait1]: forward function + Source: 'src/traits.rs', lines 209:0-209:56 *) Definition test_child_trait1 (T : Type) (inst : ChildTrait_t T) (x : T) : result alloc_string_String_t := inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_name) x . -(** [traits::test_child_trait2]: forward function *) +(** [traits::test_child_trait2]: forward function + Source: 'src/traits.rs', lines 213:0-213:54 *) Definition test_child_trait2 (T : Type) (inst : ChildTrait_t T) (x : T) : result @@ -366,7 +420,8 @@ Definition test_child_trait2 inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_w) x . -(** [traits::order1]: forward function *) +(** [traits::order1]: forward function + Source: 'src/traits.rs', lines 219:0-219:59 *) Definition order1 (T U : Type) (inst : ParentTrait0_t T) (inst0 : ParentTrait0_t U) : result unit @@ -374,7 +429,8 @@ Definition order1 Return tt . -(** Trait declaration: [traits::ChildTrait1] *) +(** Trait declaration: [traits::ChildTrait1] + Source: 'src/traits.rs', lines 222:0-222:35 *) Record ChildTrait1_t (Self : Type) := mkChildTrait1_t { ChildTrait1_tChildTrait1_t_parent_clause_0 : ParentTrait1_t Self; }. @@ -382,16 +438,19 @@ Record ChildTrait1_t (Self : Type) := mkChildTrait1_t { Arguments mkChildTrait1_t { _ }. Arguments ChildTrait1_tChildTrait1_t_parent_clause_0 { _ }. -(** Trait implementation: [traits::{usize#9}] *) +(** Trait implementation: [traits::{usize#9}] + Source: 'src/traits.rs', lines 224:0-224:27 *) Definition traits_ParentTrait1UsizeInst : ParentTrait1_t usize := mkParentTrait1_t. -(** Trait implementation: [traits::{usize#10}] *) +(** Trait implementation: [traits::{usize#10}] + Source: 'src/traits.rs', lines 225:0-225:26 *) Definition traits_ChildTrait1UsizeInst : ChildTrait1_t usize := {| ChildTrait1_tChildTrait1_t_parent_clause_0 := traits_ParentTrait1UsizeInst; |}. -(** Trait declaration: [traits::Iterator] *) +(** Trait declaration: [traits::Iterator] + Source: 'src/traits.rs', lines 229:0-229:18 *) Record Iterator_t (Self : Type) := mkIterator_t { Iterator_tIterator_t_Item : Type; }. @@ -399,7 +458,8 @@ Record Iterator_t (Self : Type) := mkIterator_t { Arguments mkIterator_t { _ }. Arguments Iterator_tIterator_t_Item { _ }. -(** Trait declaration: [traits::IntoIterator] *) +(** Trait declaration: [traits::IntoIterator] + Source: 'src/traits.rs', lines 233:0-233:22 *) Record IntoIterator_t (Self : Type) := mkIntoIterator_t { IntoIterator_tIntoIterator_t_Item : Type; IntoIterator_tIntoIterator_t_IntoIter : Type; @@ -415,12 +475,14 @@ Arguments IntoIterator_tIntoIterator_t_IntoIter { _ }. Arguments IntoIterator_tIntoIterator_t_IntoIter_clause_0 { _ }. Arguments IntoIterator_t_into_iter { _ }. -(** Trait declaration: [traits::FromResidual] *) +(** Trait declaration: [traits::FromResidual] + Source: 'src/traits.rs', lines 250:0-250:21 *) Record FromResidual_t (Self T : Type) := mkFromResidual_t{}. Arguments mkFromResidual_t { _ _ }. -(** Trait declaration: [traits::Try] *) +(** Trait declaration: [traits::Try] + Source: 'src/traits.rs', lines 246:0-246:48 *) Record Try_t (Self : Type) := mkTry_t { Try_tTry_t_Residual : Type; Try_tTry_t_parent_clause_0 : FromResidual_t Self Try_tTry_t_Residual; @@ -430,7 +492,8 @@ Arguments mkTry_t { _ }. Arguments Try_tTry_t_Residual { _ }. Arguments Try_tTry_t_parent_clause_0 { _ }. -(** Trait declaration: [traits::WithTarget] *) +(** Trait declaration: [traits::WithTarget] + Source: 'src/traits.rs', lines 252:0-252:20 *) Record WithTarget_t (Self : Type) := mkWithTarget_t { WithTarget_tWithTarget_t_Target : Type; }. @@ -438,7 +501,8 @@ Record WithTarget_t (Self : Type) := mkWithTarget_t { Arguments mkWithTarget_t { _ }. Arguments WithTarget_tWithTarget_t_Target { _ }. -(** Trait declaration: [traits::ParentTrait2] *) +(** Trait declaration: [traits::ParentTrait2] + Source: 'src/traits.rs', lines 256:0-256:22 *) Record ParentTrait2_t (Self : Type) := mkParentTrait2_t { ParentTrait2_tParentTrait2_t_U : Type; ParentTrait2_tParentTrait2_t_U_clause_0 : WithTarget_t @@ -449,7 +513,8 @@ Arguments mkParentTrait2_t { _ }. Arguments ParentTrait2_tParentTrait2_t_U { _ }. Arguments ParentTrait2_tParentTrait2_t_U_clause_0 { _ }. -(** Trait declaration: [traits::ChildTrait2] *) +(** Trait declaration: [traits::ChildTrait2] + Source: 'src/traits.rs', lines 260:0-260:35 *) Record ChildTrait2_t (Self : Type) := mkChildTrait2_t { ChildTrait2_tChildTrait2_t_parent_clause_0 : ParentTrait2_t Self; ChildTrait2_t_convert : @@ -462,28 +527,33 @@ Arguments mkChildTrait2_t { _ }. Arguments ChildTrait2_tChildTrait2_t_parent_clause_0 { _ }. Arguments ChildTrait2_t_convert { _ }. -(** Trait implementation: [traits::{u32#11}] *) +(** Trait implementation: [traits::{u32#11}] + Source: 'src/traits.rs', lines 264:0-264:23 *) Definition traits_WithTargetU32Inst : WithTarget_t u32 := {| WithTarget_tWithTarget_t_Target := u32; |}. -(** Trait implementation: [traits::{u32#12}] *) +(** Trait implementation: [traits::{u32#12}] + Source: 'src/traits.rs', lines 268:0-268:25 *) Definition traits_ParentTrait2U32Inst : ParentTrait2_t u32 := {| ParentTrait2_tParentTrait2_t_U := u32; ParentTrait2_tParentTrait2_t_U_clause_0 := traits_WithTargetU32Inst; |}. -(** [traits::{u32#13}::convert]: forward function *) +(** [traits::{u32#13}::convert]: forward function + Source: 'src/traits.rs', lines 273:4-273:29 *) Definition u32_convert (x : u32) : result u32 := Return x. -(** Trait implementation: [traits::{u32#13}] *) +(** Trait implementation: [traits::{u32#13}] + Source: 'src/traits.rs', lines 272:0-272:24 *) Definition traits_ChildTrait2U32Inst : ChildTrait2_t u32 := {| ChildTrait2_tChildTrait2_t_parent_clause_0 := traits_ParentTrait2U32Inst; ChildTrait2_t_convert := u32_convert; |}. -(** Trait declaration: [traits::CFnOnce] *) +(** Trait declaration: [traits::CFnOnce] + Source: 'src/traits.rs', lines 286:0-286:23 *) Record CFnOnce_t (Self Args : Type) := mkCFnOnce_t { CFnOnce_tCFnOnce_t_Output : Type; CFnOnce_t_call_once : Self -> Args -> result CFnOnce_tCFnOnce_t_Output; @@ -493,7 +563,8 @@ Arguments mkCFnOnce_t { _ _ }. Arguments CFnOnce_tCFnOnce_t_Output { _ _ }. Arguments CFnOnce_t_call_once { _ _ }. -(** Trait declaration: [traits::CFnMut] *) +(** Trait declaration: [traits::CFnMut] + Source: 'src/traits.rs', lines 292:0-292:37 *) Record CFnMut_t (Self Args : Type) := mkCFnMut_t { CFnMut_tCFnMut_t_parent_clause_0 : CFnOnce_t Self Args; CFnMut_t_call_mut : Self -> Args -> result @@ -508,7 +579,8 @@ Arguments CFnMut_tCFnMut_t_parent_clause_0 { _ _ }. Arguments CFnMut_t_call_mut { _ _ }. Arguments CFnMut_t_call_mut_back { _ _ }. -(** Trait declaration: [traits::CFn] *) +(** Trait declaration: [traits::CFn] + Source: 'src/traits.rs', lines 296:0-296:33 *) Record CFn_t (Self Args : Type) := mkCFn_t { CFn_tCFn_t_parent_clause_0 : CFnMut_t Self Args; CFn_t_call_mut : Self -> Args -> result @@ -519,7 +591,8 @@ Arguments mkCFn_t { _ _ }. Arguments CFn_tCFn_t_parent_clause_0 { _ _ }. Arguments CFn_t_call_mut { _ _ }. -(** [traits::incr_u32]: forward function *) +(** [traits::incr_u32]: forward function + Source: 'src/traits.rs', lines 300:0-300:30 *) Definition incr_u32 (x : u32) : result u32 := u32_add x 1%u32. diff --git a/tests/fstar/array/Array.Clauses.Template.fst b/tests/fstar/array/Array.Clauses.Template.fst index 06056d61..08a2925f 100644 --- a/tests/fstar/array/Array.Clauses.Template.fst +++ b/tests/fstar/array/Array.Clauses.Template.fst @@ -6,12 +6,14 @@ open Array.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [array::sum]: decreases clause *) +(** [array::sum]: decreases clause + Source: 'src/array.rs', lines 228:0-236:1 *) unfold let sum_loop_decreases (s : slice u32) (sum0 : u32) (i : usize) : nat = admit () -(** [array::sum2]: decreases clause *) +(** [array::sum2]: decreases clause + Source: 'src/array.rs', lines 238:0-247:1 *) unfold let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : nat = diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index 50fff38d..a8722a4f 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -8,84 +8,102 @@ include Array.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [array::incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 8:0-8:24 *) let incr (x : u32) : result u32 = u32_add x 1 -(** [array::array_to_shared_slice_]: forward function *) +(** [array::array_to_shared_slice_]: forward function + Source: 'src/array.rs', lines 16:0-16:53 *) let array_to_shared_slice_ (t : Type0) (s : array t 32) : result (slice t) = array_to_slice t 32 s -(** [array::array_to_mut_slice_]: forward function *) +(** [array::array_to_mut_slice_]: forward function + Source: 'src/array.rs', lines 21:0-21:58 *) let array_to_mut_slice_ (t : Type0) (s : array t 32) : result (slice t) = array_to_slice t 32 s -(** [array::array_to_mut_slice_]: backward function 0 *) +(** [array::array_to_mut_slice_]: backward function 0 + Source: 'src/array.rs', lines 21:0-21:58 *) let array_to_mut_slice__back (t : Type0) (s : array t 32) (ret : slice t) : result (array t 32) = array_from_slice t 32 s ret -(** [array::array_len]: forward function *) +(** [array::array_len]: forward function + Source: 'src/array.rs', lines 25:0-25:40 *) let array_len (t : Type0) (s : array t 32) : result usize = let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i -(** [array::shared_array_len]: forward function *) +(** [array::shared_array_len]: forward function + Source: 'src/array.rs', lines 29:0-29:48 *) let shared_array_len (t : Type0) (s : array t 32) : result usize = let* s0 = array_to_slice t 32 s in let i = slice_len t s0 in Return i -(** [array::shared_slice_len]: forward function *) +(** [array::shared_slice_len]: forward function + Source: 'src/array.rs', lines 33:0-33:44 *) let shared_slice_len (t : Type0) (s : slice t) : result usize = let i = slice_len t s in Return i -(** [array::index_array_shared]: forward function *) +(** [array::index_array_shared]: forward function + Source: 'src/array.rs', lines 37:0-37:57 *) let index_array_shared (t : Type0) (s : array t 32) (i : usize) : result t = array_index_usize t 32 s i -(** [array::index_array_u32]: forward function *) +(** [array::index_array_u32]: forward function + Source: 'src/array.rs', lines 44:0-44:53 *) let index_array_u32 (s : array u32 32) (i : usize) : result u32 = array_index_usize u32 32 s i -(** [array::index_array_copy]: forward function *) +(** [array::index_array_copy]: forward function + Source: 'src/array.rs', lines 48:0-48:45 *) let index_array_copy (x : array u32 32) : result u32 = array_index_usize u32 32 x 0 -(** [array::index_mut_array]: forward function *) +(** [array::index_mut_array]: forward function + Source: 'src/array.rs', lines 52:0-52:62 *) let index_mut_array (t : Type0) (s : array t 32) (i : usize) : result t = array_index_usize t 32 s i -(** [array::index_mut_array]: backward function 0 *) +(** [array::index_mut_array]: backward function 0 + Source: 'src/array.rs', lines 52:0-52:62 *) let index_mut_array_back (t : Type0) (s : array t 32) (i : usize) (ret : t) : result (array t 32) = array_update_usize t 32 s i ret -(** [array::index_slice]: forward function *) +(** [array::index_slice]: forward function + Source: 'src/array.rs', lines 56:0-56:46 *) let index_slice (t : Type0) (s : slice t) (i : usize) : result t = slice_index_usize t s i -(** [array::index_mut_slice]: forward function *) +(** [array::index_mut_slice]: forward function + Source: 'src/array.rs', lines 60:0-60:58 *) let index_mut_slice (t : Type0) (s : slice t) (i : usize) : result t = slice_index_usize t s i -(** [array::index_mut_slice]: backward function 0 *) +(** [array::index_mut_slice]: backward function 0 + Source: 'src/array.rs', lines 60:0-60:58 *) let index_mut_slice_back (t : Type0) (s : slice t) (i : usize) (ret : t) : result (slice t) = slice_update_usize t s i ret -(** [array::slice_subslice_shared_]: forward function *) +(** [array::slice_subslice_shared_]: forward function + Source: 'src/array.rs', lines 64:0-64:70 *) let slice_subslice_shared_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = core_slice_index_Slice_index u32 (core_ops_range_Range usize) (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x { start = y; end_ = z } -(** [array::slice_subslice_mut_]: forward function *) +(** [array::slice_subslice_mut_]: forward function + Source: 'src/array.rs', lines 68:0-68:75 *) let slice_subslice_mut_ (x : slice u32) (y : usize) (z : usize) : result (slice u32) = core_slice_index_Slice_index_mut u32 (core_ops_range_Range usize) (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x { start = y; end_ = z } -(** [array::slice_subslice_mut_]: backward function 0 *) +(** [array::slice_subslice_mut_]: backward function 0 + Source: 'src/array.rs', lines 68:0-68:75 *) let slice_subslice_mut__back (x : slice u32) (y : usize) (z : usize) (ret : slice u32) : result (slice u32) @@ -94,20 +112,24 @@ let slice_subslice_mut__back (core_slice_index_SliceIndexRangeUsizeSliceTInst u32) x { start = y; end_ = z } ret -(** [array::array_to_slice_shared_]: forward function *) +(** [array::array_to_slice_shared_]: forward function + Source: 'src/array.rs', lines 72:0-72:54 *) let array_to_slice_shared_ (x : array u32 32) : result (slice u32) = array_to_slice u32 32 x -(** [array::array_to_slice_mut_]: forward function *) +(** [array::array_to_slice_mut_]: forward function + Source: 'src/array.rs', lines 76:0-76:59 *) let array_to_slice_mut_ (x : array u32 32) : result (slice u32) = array_to_slice u32 32 x -(** [array::array_to_slice_mut_]: backward function 0 *) +(** [array::array_to_slice_mut_]: backward function 0 + Source: 'src/array.rs', lines 76:0-76:59 *) let array_to_slice_mut__back (x : array u32 32) (ret : slice u32) : result (array u32 32) = array_from_slice u32 32 x ret -(** [array::array_subslice_shared_]: forward function *) +(** [array::array_subslice_shared_]: forward function + Source: 'src/array.rs', lines 80:0-80:74 *) let array_subslice_shared_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index u32 (core_ops_range_Range usize) 32 @@ -115,7 +137,8 @@ let array_subslice_shared_ (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } -(** [array::array_subslice_mut_]: forward function *) +(** [array::array_subslice_mut_]: forward function + Source: 'src/array.rs', lines 84:0-84:79 *) let array_subslice_mut_ (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index_mut u32 (core_ops_range_Range usize) 32 @@ -123,7 +146,8 @@ let array_subslice_mut_ (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } -(** [array::array_subslice_mut_]: backward function 0 *) +(** [array::array_subslice_mut_]: backward function 0 + Source: 'src/array.rs', lines 84:0-84:79 *) let array_subslice_mut__back (x : array u32 32) (y : usize) (z : usize) (ret : slice u32) : result (array u32 32) @@ -133,21 +157,25 @@ let array_subslice_mut__back (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } ret -(** [array::index_slice_0]: forward function *) +(** [array::index_slice_0]: forward function + Source: 'src/array.rs', lines 88:0-88:38 *) let index_slice_0 (t : Type0) (s : slice t) : result t = slice_index_usize t s 0 -(** [array::index_array_0]: forward function *) +(** [array::index_array_0]: forward function + Source: 'src/array.rs', lines 92:0-92:42 *) let index_array_0 (t : Type0) (s : array t 32) : result t = array_index_usize t 32 s 0 -(** [array::index_index_array]: forward function *) +(** [array::index_index_array]: forward function + Source: 'src/array.rs', lines 103:0-103:71 *) let index_index_array (s : array (array u32 32) 32) (i : usize) (j : usize) : result u32 = let* a = array_index_usize (array u32 32) 32 s i in array_index_usize u32 32 a j -(** [array::update_update_array]: forward function *) +(** [array::update_update_array]: forward function + Source: 'src/array.rs', lines 114:0-114:70 *) let update_update_array (s : array (array u32 32) 32) (i : usize) (j : usize) : result unit = let* a = array_index_usize (array u32 32) 32 s i in @@ -155,28 +183,34 @@ let update_update_array let* _ = array_update_usize (array u32 32) 32 s i a0 in Return () -(** [array::array_local_deep_copy]: forward function *) +(** [array::array_local_deep_copy]: forward function + Source: 'src/array.rs', lines 118:0-118:43 *) let array_local_deep_copy (x : array u32 32) : result unit = Return () -(** [array::take_array]: forward function *) +(** [array::take_array]: forward function + Source: 'src/array.rs', lines 122:0-122:30 *) let take_array (a : array u32 2) : result unit = Return () -(** [array::take_array_borrow]: forward function *) +(** [array::take_array_borrow]: forward function + Source: 'src/array.rs', lines 123:0-123:38 *) let take_array_borrow (a : array u32 2) : result unit = Return () -(** [array::take_slice]: forward function *) +(** [array::take_slice]: forward function + Source: 'src/array.rs', lines 124:0-124:28 *) let take_slice (s : slice u32) : result unit = Return () (** [array::take_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 125:0-125:36 *) let take_mut_slice (s : slice u32) : result (slice u32) = Return s -(** [array::take_all]: forward function *) +(** [array::take_all]: forward function + Source: 'src/array.rs', lines 127:0-127:17 *) let take_all : result unit = let* _ = take_array (mk_array u32 2 [ 0; 0 ]) in let* _ = take_array_borrow (mk_array u32 2 [ 0; 0 ]) in @@ -187,27 +221,33 @@ let take_all : result unit = let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in Return () -(** [array::index_array]: forward function *) +(** [array::index_array]: forward function + Source: 'src/array.rs', lines 141:0-141:38 *) let index_array (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 -(** [array::index_array_borrow]: forward function *) +(** [array::index_array_borrow]: forward function + Source: 'src/array.rs', lines 144:0-144:46 *) let index_array_borrow (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 -(** [array::index_slice_u32_0]: forward function *) +(** [array::index_slice_u32_0]: forward function + Source: 'src/array.rs', lines 148:0-148:42 *) let index_slice_u32_0 (x : slice u32) : result u32 = slice_index_usize u32 x 0 -(** [array::index_mut_slice_u32_0]: forward function *) +(** [array::index_mut_slice_u32_0]: forward function + Source: 'src/array.rs', lines 152:0-152:50 *) let index_mut_slice_u32_0 (x : slice u32) : result u32 = slice_index_usize u32 x 0 -(** [array::index_mut_slice_u32_0]: backward function 0 *) +(** [array::index_mut_slice_u32_0]: backward function 0 + Source: 'src/array.rs', lines 152:0-152:50 *) let index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) = let* _ = slice_index_usize u32 x 0 in Return x -(** [array::index_all]: forward function *) +(** [array::index_all]: forward function + Source: 'src/array.rs', lines 156:0-156:25 *) let index_all : result u32 = let* i = index_array (mk_array u32 2 [ 0; 0 ]) in let* i0 = index_array (mk_array u32 2 [ 0; 0 ]) in @@ -224,21 +264,25 @@ let index_all : result u32 = let* _ = array_from_slice u32 2 (mk_array u32 2 [ 0; 0 ]) s1 in Return i7 -(** [array::update_array]: forward function *) +(** [array::update_array]: forward function + Source: 'src/array.rs', lines 170:0-170:36 *) let update_array (x : array u32 2) : result unit = let* _ = array_update_usize u32 2 x 0 1 in Return () (** [array::update_array_mut_borrow]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 173:0-173:48 *) let update_array_mut_borrow (x : array u32 2) : result (array u32 2) = array_update_usize u32 2 x 0 1 (** [array::update_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 176:0-176:38 *) let update_mut_slice (x : slice u32) : result (slice u32) = slice_update_usize u32 x 0 1 -(** [array::update_all]: forward function *) +(** [array::update_all]: forward function + Source: 'src/array.rs', lines 180:0-180:19 *) let update_all : result unit = let* _ = update_array (mk_array u32 2 [ 0; 0 ]) in let* x = update_array_mut_borrow (mk_array u32 2 [ 0; 0 ]) in @@ -247,7 +291,8 @@ let update_all : result unit = let* _ = array_from_slice u32 2 x s0 in Return () -(** [array::range_all]: forward function *) +(** [array::range_all]: forward function + Source: 'src/array.rs', lines 191:0-191:18 *) let range_all : result unit = let* s = core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 @@ -262,27 +307,33 @@ let range_all : result unit = (mk_array u32 4 [ 0; 0; 0; 0 ]) { start = 1; end_ = 3 } s0 in Return () -(** [array::deref_array_borrow]: forward function *) +(** [array::deref_array_borrow]: forward function + Source: 'src/array.rs', lines 200:0-200:46 *) let deref_array_borrow (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 -(** [array::deref_array_mut_borrow]: forward function *) +(** [array::deref_array_mut_borrow]: forward function + Source: 'src/array.rs', lines 205:0-205:54 *) let deref_array_mut_borrow (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 -(** [array::deref_array_mut_borrow]: backward function 0 *) +(** [array::deref_array_mut_borrow]: backward function 0 + Source: 'src/array.rs', lines 205:0-205:54 *) let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = let* _ = array_index_usize u32 2 x 0 in Return x -(** [array::take_array_t]: forward function *) +(** [array::take_array_t]: forward function + Source: 'src/array.rs', lines 213:0-213:31 *) let take_array_t (a : array aB_t 2) : result unit = Return () -(** [array::non_copyable_array]: forward function *) +(** [array::non_copyable_array]: forward function + Source: 'src/array.rs', lines 215:0-215:27 *) let non_copyable_array : result unit = let* _ = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) in Return () -(** [array::sum]: loop 0: forward function *) +(** [array::sum]: loop 0: forward function + Source: 'src/array.rs', lines 228:0-236:1 *) let rec sum_loop (s : slice u32) (sum0 : u32) (i : usize) : Tot (result u32) (decreases (sum_loop_decreases s sum0 i)) @@ -296,11 +347,13 @@ let rec sum_loop sum_loop s sum1 i2 else Return sum0 -(** [array::sum]: forward function *) +(** [array::sum]: forward function + Source: 'src/array.rs', lines 228:0-228:28 *) let sum (s : slice u32) : result u32 = sum_loop s 0 0 -(** [array::sum2]: loop 0: forward function *) +(** [array::sum2]: loop 0: forward function + Source: 'src/array.rs', lines 238:0-247:1 *) let rec sum2_loop (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : Tot (result u32) (decreases (sum2_loop_decreases s s2 sum0 i)) @@ -316,35 +369,41 @@ let rec sum2_loop sum2_loop s s2 sum1 i4 else Return sum0 -(** [array::sum2]: forward function *) +(** [array::sum2]: forward function + Source: 'src/array.rs', lines 238:0-238:41 *) let sum2 (s : slice u32) (s2 : slice u32) : result u32 = let i = slice_len u32 s in let i0 = slice_len u32 s2 in if not (i = i0) then Fail Failure else sum2_loop s s2 0 0 -(** [array::f0]: forward function *) +(** [array::f0]: forward function + Source: 'src/array.rs', lines 249:0-249:11 *) let f0 : result unit = let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in let* s0 = slice_update_usize u32 s 0 1 in let* _ = array_from_slice u32 2 (mk_array u32 2 [ 1; 2 ]) s0 in Return () -(** [array::f1]: forward function *) +(** [array::f1]: forward function + Source: 'src/array.rs', lines 254:0-254:11 *) let f1 : result unit = let* _ = array_update_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in Return () -(** [array::f2]: forward function *) +(** [array::f2]: forward function + Source: 'src/array.rs', lines 259:0-259:17 *) let f2 (i : u32) : result unit = Return () -(** [array::f4]: forward function *) +(** [array::f4]: forward function + Source: 'src/array.rs', lines 268:0-268:54 *) let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index u32 (core_ops_range_Range usize) 32 (core_ops_index_IndexSliceTIInst u32 (core_ops_range_Range usize) (core_slice_index_SliceIndexRangeUsizeSliceTInst u32)) x { start = y; end_ = z } -(** [array::f3]: forward function *) +(** [array::f3]: forward function + Source: 'src/array.rs', lines 261:0-261:18 *) let f3 : result u32 = let* i = array_index_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in let* _ = f2 i in @@ -353,15 +412,18 @@ let f3 : result u32 = let* s0 = f4 b 16 18 in sum2 s s0 -(** [array::SZ] *) +(** [array::SZ] + Source: 'src/array.rs', lines 272:0-272:19 *) let sz_body : result usize = Return 32 let sz_c : usize = eval_global sz_body -(** [array::f5]: forward function *) +(** [array::f5]: forward function + Source: 'src/array.rs', lines 275:0-275:31 *) let f5 (x : array u32 32) : result u32 = array_index_usize u32 32 x 0 -(** [array::ite]: forward function *) +(** [array::ite]: forward function + Source: 'src/array.rs', lines 280:0-280:12 *) let ite : result unit = let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in diff --git a/tests/fstar/array/Array.Types.fst b/tests/fstar/array/Array.Types.fst index 4e8d5566..312f6018 100644 --- a/tests/fstar/array/Array.Types.fst +++ b/tests/fstar/array/Array.Types.fst @@ -5,6 +5,7 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [array::AB] *) +(** [array::AB] + Source: 'src/array.rs', lines 3:0-3:11 *) type aB_t = | AB_A : aB_t | AB_B : aB_t diff --git a/tests/fstar/betree/BetreeMain.Clauses.Template.fst b/tests/fstar/betree/BetreeMain.Clauses.Template.fst index 4d16d8d3..4ae29302 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.Template.fst @@ -6,94 +6,109 @@ open BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::{betree_main::betree::List#1}::len]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: decreases clause + Source: 'src/betree.rs', lines 276:4-276:24 *) unfold let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () -(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: decreases clause + Source: 'src/betree.rs', lines 284:4-284:51 *) unfold let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: decreases clause + Source: 'src/betree.rs', lines 339:4-339:73 *) unfold let betree_ListTupleU64T_partition_at_pivot_decreases (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: decreases clause + Source: 'src/betree.rs', lines 789:4-792:34 *) unfold let betree_Node_lookup_first_message_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause + Source: 'src/betree.rs', lines 819:4-819:90 *) unfold let betree_Node_apply_upserts_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause + Source: 'src/betree.rs', lines 636:4-636:80 *) unfold let betree_Node_lookup_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause + Source: 'src/betree.rs', lines 395:4-395:63 *) unfold let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: decreases clause + Source: 'src/betree.rs', lines 709:4-709:58 *) unfold let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: decreases clause + Source: 'src/betree.rs', lines 674:4-674:77 *) unfold let betree_Node_filter_messages_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: decreases clause + Source: 'src/betree.rs', lines 689:4-692:34 *) unfold let betree_Node_lookup_first_message_after_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: decreases clause + Source: 'src/betree.rs', lines 502:4-505:5 *) unfold let betree_Node_apply_messages_to_internal_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: decreases clause + Source: 'src/betree.rs', lines 653:4-656:32 *) unfold let betree_Node_lookup_mut_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: decreases clause + Source: 'src/betree.rs', lines 444:4-447:5 *) unfold let betree_Node_apply_messages_to_leaf_decreases (bindings : betree_List_t (u64 & u64)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: decreases clause + Source: 'src/betree.rs', lines 410:4-415:26 *) unfold let betree_Internal_flush_decreases (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: decreases clause + Source: 'src/betree.rs', lines 588:4-593:5 *) unfold let betree_Node_apply_messages_decreases (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index 2ccbac60..537ec32e 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -8,14 +8,16 @@ include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::load_internal_node]: forward function *) +(** [betree_main::betree::load_internal_node]: forward function + Source: 'src/betree.rs', lines 36:0-36:52 *) let betree_load_internal_node (id : u64) (st : state) : result (state & (betree_List_t (u64 & betree_Message_t))) = betree_utils_load_internal_node id st -(** [betree_main::betree::store_internal_node]: forward function *) +(** [betree_main::betree::store_internal_node]: forward function + Source: 'src/betree.rs', lines 41:0-41:60 *) let betree_store_internal_node (id : u64) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : result (state & unit) @@ -23,12 +25,14 @@ let betree_store_internal_node let* (st0, _) = betree_utils_store_internal_node id content st in Return (st0, ()) -(** [betree_main::betree::load_leaf_node]: forward function *) +(** [betree_main::betree::load_leaf_node]: forward function + Source: 'src/betree.rs', lines 46:0-46:44 *) let betree_load_leaf_node (id : u64) (st : state) : result (state & (betree_List_t (u64 & u64))) = betree_utils_load_leaf_node id st -(** [betree_main::betree::store_leaf_node]: forward function *) +(** [betree_main::betree::store_leaf_node]: forward function + Source: 'src/betree.rs', lines 51:0-51:52 *) let betree_store_leaf_node (id : u64) (content : betree_List_t (u64 & u64)) (st : state) : result (state & unit) @@ -36,29 +40,35 @@ let betree_store_leaf_node let* (st0, _) = betree_utils_store_leaf_node id content st in Return (st0, ()) -(** [betree_main::betree::fresh_node_id]: forward function *) +(** [betree_main::betree::fresh_node_id]: forward function + Source: 'src/betree.rs', lines 55:0-55:48 *) let betree_fresh_node_id (counter : u64) : result u64 = let* _ = u64_add counter 1 in Return counter -(** [betree_main::betree::fresh_node_id]: backward function 0 *) +(** [betree_main::betree::fresh_node_id]: backward function 0 + Source: 'src/betree.rs', lines 55:0-55:48 *) let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function + Source: 'src/betree.rs', lines 206:4-206:20 *) let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = Return { next_node_id = 0 } -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function + Source: 'src/betree.rs', lines 210:4-210:36 *) let betree_NodeIdCounter_fresh_id (self : betree_NodeIdCounter_t) : result u64 = let* _ = u64_add self.next_node_id 1 in Return self.next_node_id -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 + Source: 'src/betree.rs', lines 210:4-210:36 *) let betree_NodeIdCounter_fresh_id_back (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } -(** [betree_main::betree::upsert_update]: forward function *) +(** [betree_main::betree::upsert_update]: forward function + Source: 'src/betree.rs', lines 234:0-234:70 *) let betree_upsert_update (prev : option u64) (st : betree_UpsertFunState_t) : result u64 = begin match prev with @@ -77,7 +87,8 @@ let betree_upsert_update end end -(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function + Source: 'src/betree.rs', lines 276:4-276:24 *) let rec betree_List_len (t : Type0) (self : betree_List_t t) : Tot (result u64) (decreases (betree_List_len_decreases t self)) @@ -87,7 +98,8 @@ let rec betree_List_len | Betree_List_Nil -> Return 0 end -(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function + Source: 'src/betree.rs', lines 284:4-284:51 *) let rec betree_List_split_at (t : Type0) (self : betree_List_t t) (n : u64) : Tot (result ((betree_List_t t) & (betree_List_t t))) @@ -107,14 +119,16 @@ let rec betree_List_split_at end (** [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 299:4-299:34 *) let betree_List_push_front (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = let tl = core_mem_replace (betree_List_t t) self Betree_List_Nil in let l = tl in Return (Betree_List_Cons x l) -(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function + Source: 'src/betree.rs', lines 306:4-306:32 *) let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with @@ -122,7 +136,8 @@ let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 + Source: 'src/betree.rs', lines 306:4-306:32 *) let betree_List_pop_front_back (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in @@ -131,14 +146,16 @@ let betree_List_pop_front_back | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function + Source: 'src/betree.rs', lines 318:4-318:22 *) let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with | Betree_List_Cons hd l -> Return hd | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function + Source: 'src/betree.rs', lines 327:4-327:44 *) let betree_ListTupleU64T_head_has_key (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with @@ -146,7 +163,8 @@ let betree_ListTupleU64T_head_has_key | Betree_List_Nil -> Return false end -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function + Source: 'src/betree.rs', lines 339:4-339:73 *) let rec betree_ListTupleU64T_partition_at_pivot (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) @@ -165,7 +183,8 @@ let rec betree_ListTupleU64T_partition_at_pivot | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function + Source: 'src/betree.rs', lines 359:4-364:17 *) let betree_Leaf_split (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -185,7 +204,8 @@ let betree_Leaf_split let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 + Source: 'src/betree.rs', lines 359:4-364:17 *) let betree_Leaf_split_back (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -202,7 +222,8 @@ let betree_Leaf_split_back let* _ = betree_store_leaf_node id1 content1 st0 in betree_NodeIdCounter_fresh_id_back node_id_cnt0 -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function + Source: 'src/betree.rs', lines 789:4-792:34 *) let rec betree_Node_lookup_first_message_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -217,7 +238,8 @@ let rec betree_Node_lookup_first_message_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 + Source: 'src/betree.rs', lines 789:4-792:34 *) let rec betree_Node_lookup_first_message_for_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -236,7 +258,8 @@ let rec betree_Node_lookup_first_message_for_key_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function + Source: 'src/betree.rs', lines 819:4-819:90 *) let rec betree_Node_apply_upserts (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -263,7 +286,8 @@ let rec betree_Node_apply_upserts Betree_Message_Insert v) in Return (st0, v) -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 + Source: 'src/betree.rs', lines 819:4-819:90 *) let rec betree_Node_apply_upserts_back (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -288,7 +312,8 @@ let rec betree_Node_apply_upserts_back betree_List_push_front (u64 & betree_Message_t) msgs (key, Betree_Message_Insert v) -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 *) let rec betree_Node_lookup_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) @@ -303,7 +328,8 @@ let rec betree_Node_lookup_in_bindings | Betree_List_Nil -> Return None end -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function + Source: 'src/betree.rs', lines 395:4-395:63 *) let rec betree_Internal_lookup_in_children (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -313,7 +339,8 @@ let rec betree_Internal_lookup_in_children then betree_Node_lookup self.left key st else betree_Node_lookup self.right key st -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 + Source: 'src/betree.rs', lines 395:4-395:63 *) and betree_Internal_lookup_in_children_back (self : betree_Internal_t) (key : u64) (st : state) : Tot (result betree_Internal_t) @@ -327,7 +354,8 @@ and betree_Internal_lookup_in_children_back let* n = betree_Node_lookup_back self.right key st in Return { self with right = n } -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function + Source: 'src/betree.rs', lines 709:4-709:58 *) and betree_Node_lookup (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -386,7 +414,8 @@ and betree_Node_lookup Return (st0, o) end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 709:4-709:58 *) and betree_Node_lookup_back (self : betree_Node_t) (key : u64) (st : state) : Tot (result betree_Node_t) @@ -446,7 +475,8 @@ and betree_Node_lookup_back end (** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 674:4-674:77 *) let rec betree_Node_filter_messages_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -465,7 +495,8 @@ let rec betree_Node_filter_messages_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function + Source: 'src/betree.rs', lines 689:4-692:34 *) let rec betree_Node_lookup_first_message_after_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -480,7 +511,8 @@ let rec betree_Node_lookup_first_message_after_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 + Source: 'src/betree.rs', lines 689:4-692:34 *) let rec betree_Node_lookup_first_message_after_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -500,7 +532,8 @@ let rec betree_Node_lookup_first_message_after_key_back end (** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 521:4-521:89 *) let betree_Node_apply_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) (new_msg : betree_Message_t) : @@ -559,7 +592,8 @@ let betree_Node_apply_to_internal betree_Node_lookup_first_message_for_key_back key msgs msgs1 (** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 502:4-505:5 *) let rec betree_Node_apply_messages_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : @@ -574,7 +608,8 @@ let rec betree_Node_apply_messages_to_internal | Betree_List_Nil -> Return msgs end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function + Source: 'src/betree.rs', lines 653:4-656:32 *) let rec betree_Node_lookup_mut_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (betree_List_t (u64 & u64))) @@ -589,7 +624,8 @@ let rec betree_Node_lookup_mut_in_bindings | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 + Source: 'src/betree.rs', lines 653:4-656:32 *) let rec betree_Node_lookup_mut_in_bindings_back (key : u64) (bindings : betree_List_t (u64 & u64)) (ret : betree_List_t (u64 & u64)) : @@ -608,7 +644,8 @@ let rec betree_Node_lookup_mut_in_bindings_back end (** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 460:4-460:87 *) let betree_Node_apply_to_leaf (bindings : betree_List_t (u64 & u64)) (key : u64) (new_msg : betree_Message_t) : @@ -648,7 +685,8 @@ let betree_Node_apply_to_leaf end (** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 444:4-447:5 *) let rec betree_Node_apply_messages_to_leaf (bindings : betree_List_t (u64 & u64)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : @@ -663,7 +701,8 @@ let rec betree_Node_apply_messages_to_leaf | Betree_List_Nil -> Return bindings end -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function + Source: 'src/betree.rs', lines 410:4-415:26 *) let rec betree_Internal_flush (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -703,7 +742,8 @@ let rec betree_Internal_flush st in Return (st0, msgs_left) -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 + Source: 'src/betree.rs', lines 410:4-415:26 *) and betree_Internal_flush_back (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -738,7 +778,8 @@ and betree_Internal_flush_back st in Return ({ self with right = n }, node_id_cnt0) -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function + Source: 'src/betree.rs', lines 588:4-593:5 *) and betree_Node_apply_messages (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -778,7 +819,8 @@ and betree_Node_apply_messages Return (st1, ()) end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 + Source: 'src/betree.rs', lines 588:4-593:5 *) and betree_Node_apply_messages_back (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -821,7 +863,8 @@ and betree_Node_apply_messages_back Return (Betree_Node_Leaf { node with size = len }, node_id_cnt) end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function + Source: 'src/betree.rs', lines 576:4-582:5 *) let betree_Node_apply (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -837,7 +880,8 @@ let betree_Node_apply (key, new_msg) l) st in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 + Source: 'src/betree.rs', lines 576:4-582:5 *) let betree_Node_apply_back (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -848,7 +892,8 @@ let betree_Node_apply_back betree_Node_apply_messages_back self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st -(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function + Source: 'src/betree.rs', lines 849:4-849:60 *) let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : result (state & betree_BeTree_t) @@ -864,7 +909,8 @@ let betree_BeTree_new root = (Betree_Node_Leaf { id = id; size = 0 }) }) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function + Source: 'src/betree.rs', lines 868:4-868:47 *) let betree_BeTree_apply (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) @@ -875,7 +921,8 @@ let betree_BeTree_apply betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 + Source: 'src/betree.rs', lines 868:4-868:47 *) let betree_BeTree_apply_back (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result betree_BeTree_t @@ -884,7 +931,8 @@ let betree_BeTree_apply_back betree_Node_apply_back self.root self.params self.node_id_cnt key msg st in Return { self with node_id_cnt = nic; root = n } -(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function + Source: 'src/betree.rs', lines 874:4-874:52 *) let betree_BeTree_insert (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) @@ -895,26 +943,30 @@ let betree_BeTree_insert in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 + Source: 'src/betree.rs', lines 874:4-874:52 *) let betree_BeTree_insert_back (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result betree_BeTree_t = betree_BeTree_apply_back self key (Betree_Message_Insert value) st -(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function + Source: 'src/betree.rs', lines 880:4-880:38 *) let betree_BeTree_delete (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in let* _ = betree_BeTree_apply_back self key Betree_Message_Delete st in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 + Source: 'src/betree.rs', lines 880:4-880:38 *) let betree_BeTree_delete_back (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = betree_BeTree_apply_back self key Betree_Message_Delete st -(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function + Source: 'src/betree.rs', lines 886:4-886:59 *) let betree_BeTree_upsert (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -925,7 +977,8 @@ let betree_BeTree_upsert let* _ = betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 + Source: 'src/betree.rs', lines 886:4-886:59 *) let betree_BeTree_upsert_back (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -933,20 +986,23 @@ let betree_BeTree_upsert_back = betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st -(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function + Source: 'src/betree.rs', lines 895:4-895:62 *) let betree_BeTree_lookup (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = betree_Node_lookup self.root key st -(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 895:4-895:62 *) let betree_BeTree_lookup_back (self : betree_BeTree_t) (key : u64) (st : state) : result betree_BeTree_t = let* n = betree_Node_lookup_back self.root key st in Return { self with root = n } -(** [betree_main::main]: forward function *) +(** [betree_main::main]: forward function + Source: 'src/betree_main.rs', lines 5:0-5:9 *) let main : result unit = Return () diff --git a/tests/fstar/betree/BetreeMain.Opaque.fsti b/tests/fstar/betree/BetreeMain.Opaque.fsti index 23d2e60e..b89c8718 100644 --- a/tests/fstar/betree/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree/BetreeMain.Opaque.fsti @@ -6,25 +6,30 @@ include BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree_utils::load_internal_node]: forward function *) +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) val betree_utils_load_internal_node : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) -(** [betree_main::betree_utils::store_internal_node]: forward function *) +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) val betree_utils_store_internal_node : u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & unit) -(** [betree_main::betree_utils::load_leaf_node]: forward function *) +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) val betree_utils_load_leaf_node : u64 -> state -> result (state & (betree_List_t (u64 & u64))) -(** [betree_main::betree_utils::store_leaf_node]: forward function *) +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) val betree_utils_store_leaf_node : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) -(** [core::option::{core::option::Option}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree/BetreeMain.Types.fsti b/tests/fstar/betree/BetreeMain.Types.fsti index 9320f6b7..a098ec19 100644 --- a/tests/fstar/betree/BetreeMain.Types.fsti +++ b/tests/fstar/betree/BetreeMain.Types.fsti @@ -5,43 +5,52 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::List] *) +(** [betree_main::betree::List] + Source: 'src/betree.rs', lines 17:0-17:23 *) type betree_List_t (t : Type0) = | Betree_List_Cons : t -> betree_List_t t -> betree_List_t t | Betree_List_Nil : betree_List_t t -(** [betree_main::betree::UpsertFunState] *) +(** [betree_main::betree::UpsertFunState] + Source: 'src/betree.rs', lines 63:0-63:23 *) type betree_UpsertFunState_t = | Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t | Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t -(** [betree_main::betree::Message] *) +(** [betree_main::betree::Message] + Source: 'src/betree.rs', lines 69:0-69:23 *) type betree_Message_t = | Betree_Message_Insert : u64 -> betree_Message_t | Betree_Message_Delete : betree_Message_t | Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t -(** [betree_main::betree::Leaf] *) +(** [betree_main::betree::Leaf] + Source: 'src/betree.rs', lines 167:0-167:11 *) type betree_Leaf_t = { id : u64; size : u64; } -(** [betree_main::betree::Internal] *) +(** [betree_main::betree::Internal] + Source: 'src/betree.rs', lines 156:0-156:15 *) type betree_Internal_t = { id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; } -(** [betree_main::betree::Node] *) +(** [betree_main::betree::Node] + Source: 'src/betree.rs', lines 179:0-179:9 *) and betree_Node_t = | Betree_Node_Internal : betree_Internal_t -> betree_Node_t | Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t -(** [betree_main::betree::Params] *) +(** [betree_main::betree::Params] + Source: 'src/betree.rs', lines 187:0-187:13 *) type betree_Params_t = { min_flush_size : u64; split_size : u64; } -(** [betree_main::betree::NodeIdCounter] *) +(** [betree_main::betree::NodeIdCounter] + Source: 'src/betree.rs', lines 201:0-201:20 *) type betree_NodeIdCounter_t = { next_node_id : u64; } -(** [betree_main::betree::BeTree] *) +(** [betree_main::betree::BeTree] + Source: 'src/betree.rs', lines 218:0-218:17 *) type betree_BeTree_t = { params : betree_Params_t; diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst index 4d16d8d3..4ae29302 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst @@ -6,94 +6,109 @@ open BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::{betree_main::betree::List#1}::len]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: decreases clause + Source: 'src/betree.rs', lines 276:4-276:24 *) unfold let betree_List_len_decreases (t : Type0) (self : betree_List_t t) : nat = admit () -(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: decreases clause + Source: 'src/betree.rs', lines 284:4-284:51 *) unfold let betree_List_split_at_decreases (t : Type0) (self : betree_List_t t) (n : u64) : nat = admit () -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: decreases clause + Source: 'src/betree.rs', lines 339:4-339:73 *) unfold let betree_ListTupleU64T_partition_at_pivot_decreases (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: decreases clause + Source: 'src/betree.rs', lines 789:4-792:34 *) unfold let betree_Node_lookup_first_message_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause + Source: 'src/betree.rs', lines 819:4-819:90 *) unfold let betree_Node_apply_upserts_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause + Source: 'src/betree.rs', lines 636:4-636:80 *) unfold let betree_Node_lookup_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause + Source: 'src/betree.rs', lines 395:4-395:63 *) unfold let betree_Internal_lookup_in_children_decreases (self : betree_Internal_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: decreases clause + Source: 'src/betree.rs', lines 709:4-709:58 *) unfold let betree_Node_lookup_decreases (self : betree_Node_t) (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: decreases clause + Source: 'src/betree.rs', lines 674:4-674:77 *) unfold let betree_Node_filter_messages_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: decreases clause + Source: 'src/betree.rs', lines 689:4-692:34 *) unfold let betree_Node_lookup_first_message_after_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: decreases clause + Source: 'src/betree.rs', lines 502:4-505:5 *) unfold let betree_Node_apply_messages_to_internal_decreases (msgs : betree_List_t (u64 & betree_Message_t)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: decreases clause + Source: 'src/betree.rs', lines 653:4-656:32 *) unfold let betree_Node_lookup_mut_in_bindings_decreases (key : u64) (bindings : betree_List_t (u64 & u64)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: decreases clause + Source: 'src/betree.rs', lines 444:4-447:5 *) unfold let betree_Node_apply_messages_to_leaf_decreases (bindings : betree_List_t (u64 & u64)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: decreases clause + Source: 'src/betree.rs', lines 410:4-415:26 *) unfold let betree_Internal_flush_decreases (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: decreases clause *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: decreases clause + Source: 'src/betree.rs', lines 588:4-593:5 *) unfold let betree_Node_apply_messages_decreases (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index b46ca0a0..a2586431 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -8,14 +8,16 @@ include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::load_internal_node]: forward function *) +(** [betree_main::betree::load_internal_node]: forward function + Source: 'src/betree.rs', lines 36:0-36:52 *) let betree_load_internal_node (id : u64) (st : state) : result (state & (betree_List_t (u64 & betree_Message_t))) = betree_utils_load_internal_node id st -(** [betree_main::betree::store_internal_node]: forward function *) +(** [betree_main::betree::store_internal_node]: forward function + Source: 'src/betree.rs', lines 41:0-41:60 *) let betree_store_internal_node (id : u64) (content : betree_List_t (u64 & betree_Message_t)) (st : state) : result (state & unit) @@ -23,12 +25,14 @@ let betree_store_internal_node let* (st0, _) = betree_utils_store_internal_node id content st in Return (st0, ()) -(** [betree_main::betree::load_leaf_node]: forward function *) +(** [betree_main::betree::load_leaf_node]: forward function + Source: 'src/betree.rs', lines 46:0-46:44 *) let betree_load_leaf_node (id : u64) (st : state) : result (state & (betree_List_t (u64 & u64))) = betree_utils_load_leaf_node id st -(** [betree_main::betree::store_leaf_node]: forward function *) +(** [betree_main::betree::store_leaf_node]: forward function + Source: 'src/betree.rs', lines 51:0-51:52 *) let betree_store_leaf_node (id : u64) (content : betree_List_t (u64 & u64)) (st : state) : result (state & unit) @@ -36,29 +40,35 @@ let betree_store_leaf_node let* (st0, _) = betree_utils_store_leaf_node id content st in Return (st0, ()) -(** [betree_main::betree::fresh_node_id]: forward function *) +(** [betree_main::betree::fresh_node_id]: forward function + Source: 'src/betree.rs', lines 55:0-55:48 *) let betree_fresh_node_id (counter : u64) : result u64 = let* _ = u64_add counter 1 in Return counter -(** [betree_main::betree::fresh_node_id]: backward function 0 *) +(** [betree_main::betree::fresh_node_id]: backward function 0 + Source: 'src/betree.rs', lines 55:0-55:48 *) let betree_fresh_node_id_back (counter : u64) : result u64 = u64_add counter 1 -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function + Source: 'src/betree.rs', lines 206:4-206:20 *) let betree_NodeIdCounter_new : result betree_NodeIdCounter_t = Return { next_node_id = 0 } -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function + Source: 'src/betree.rs', lines 210:4-210:36 *) let betree_NodeIdCounter_fresh_id (self : betree_NodeIdCounter_t) : result u64 = let* _ = u64_add self.next_node_id 1 in Return self.next_node_id -(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 + Source: 'src/betree.rs', lines 210:4-210:36 *) let betree_NodeIdCounter_fresh_id_back (self : betree_NodeIdCounter_t) : result betree_NodeIdCounter_t = let* i = u64_add self.next_node_id 1 in Return { next_node_id = i } -(** [betree_main::betree::upsert_update]: forward function *) +(** [betree_main::betree::upsert_update]: forward function + Source: 'src/betree.rs', lines 234:0-234:70 *) let betree_upsert_update (prev : option u64) (st : betree_UpsertFunState_t) : result u64 = begin match prev with @@ -77,7 +87,8 @@ let betree_upsert_update end end -(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::len]: forward function + Source: 'src/betree.rs', lines 276:4-276:24 *) let rec betree_List_len (t : Type0) (self : betree_List_t t) : Tot (result u64) (decreases (betree_List_len_decreases t self)) @@ -87,7 +98,8 @@ let rec betree_List_len | Betree_List_Nil -> Return 0 end -(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function + Source: 'src/betree.rs', lines 284:4-284:51 *) let rec betree_List_split_at (t : Type0) (self : betree_List_t t) (n : u64) : Tot (result ((betree_List_t t) & (betree_List_t t))) @@ -107,14 +119,16 @@ let rec betree_List_split_at end (** [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 299:4-299:34 *) let betree_List_push_front (t : Type0) (self : betree_List_t t) (x : t) : result (betree_List_t t) = let tl = core_mem_replace (betree_List_t t) self Betree_List_Nil in let l = tl in Return (Betree_List_Cons x l) -(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function + Source: 'src/betree.rs', lines 306:4-306:32 *) let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in begin match ls with @@ -122,7 +136,8 @@ let betree_List_pop_front (t : Type0) (self : betree_List_t t) : result t = | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 + Source: 'src/betree.rs', lines 306:4-306:32 *) let betree_List_pop_front_back (t : Type0) (self : betree_List_t t) : result (betree_List_t t) = let ls = core_mem_replace (betree_List_t t) self Betree_List_Nil in @@ -131,14 +146,16 @@ let betree_List_pop_front_back | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function *) +(** [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function + Source: 'src/betree.rs', lines 318:4-318:22 *) let betree_List_hd (t : Type0) (self : betree_List_t t) : result t = begin match self with | Betree_List_Cons hd l -> Return hd | Betree_List_Nil -> Fail Failure end -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function + Source: 'src/betree.rs', lines 327:4-327:44 *) let betree_ListTupleU64T_head_has_key (t : Type0) (self : betree_List_t (u64 & t)) (key : u64) : result bool = begin match self with @@ -146,7 +163,8 @@ let betree_ListTupleU64T_head_has_key | Betree_List_Nil -> Return false end -(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function *) +(** [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function + Source: 'src/betree.rs', lines 339:4-339:73 *) let rec betree_ListTupleU64T_partition_at_pivot (t : Type0) (self : betree_List_t (u64 & t)) (pivot : u64) : Tot (result ((betree_List_t (u64 & t)) & (betree_List_t (u64 & t)))) @@ -165,7 +183,8 @@ let rec betree_ListTupleU64T_partition_at_pivot | Betree_List_Nil -> Return (Betree_List_Nil, Betree_List_Nil) end -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function + Source: 'src/betree.rs', lines 359:4-364:17 *) let betree_Leaf_split (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -185,7 +204,8 @@ let betree_Leaf_split let n0 = Betree_Node_Leaf { id = id1; size = params.split_size } in Return (st1, { id = self.id; pivot = pivot; left = n; right = n0 }) -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 0 + Source: 'src/betree.rs', lines 359:4-364:17 *) let betree_Leaf_split_back0 (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -202,7 +222,8 @@ let betree_Leaf_split_back0 let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 1 + Source: 'src/betree.rs', lines 359:4-364:17 *) let betree_Leaf_split_back1 (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -219,7 +240,8 @@ let betree_Leaf_split_back1 let* _ = betree_store_leaf_node id1 content1 st1 in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 *) +(** [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 + Source: 'src/betree.rs', lines 359:4-364:17 *) let betree_Leaf_split_back2 (self : betree_Leaf_t) (content : betree_List_t (u64 & u64)) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -237,7 +259,8 @@ let betree_Leaf_split_back2 let* node_id_cnt1 = betree_NodeIdCounter_fresh_id_back node_id_cnt0 in Return (st0, node_id_cnt1) -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function + Source: 'src/betree.rs', lines 789:4-792:34 *) let rec betree_Node_lookup_first_message_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -252,7 +275,8 @@ let rec betree_Node_lookup_first_message_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 + Source: 'src/betree.rs', lines 789:4-792:34 *) let rec betree_Node_lookup_first_message_for_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -271,7 +295,8 @@ let rec betree_Node_lookup_first_message_for_key_back | Betree_List_Nil -> Return ret end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function + Source: 'src/betree.rs', lines 819:4-819:90 *) let rec betree_Node_apply_upserts (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) : @@ -298,7 +323,8 @@ let rec betree_Node_apply_upserts Betree_Message_Insert v) in Return (st0, v) -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 + Source: 'src/betree.rs', lines 819:4-819:90 *) let rec betree_Node_apply_upserts_back (msgs : betree_List_t (u64 & betree_Message_t)) (prev : option u64) (key : u64) (st : state) (st0 : state) : @@ -325,7 +351,8 @@ let rec betree_Node_apply_upserts_back Betree_Message_Insert v) in Return (st0, msgs0) -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 *) let rec betree_Node_lookup_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (option u64)) @@ -340,7 +367,8 @@ let rec betree_Node_lookup_in_bindings | Betree_List_Nil -> Return None end -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function + Source: 'src/betree.rs', lines 395:4-395:63 *) let rec betree_Internal_lookup_in_children (self : betree_Internal_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -350,7 +378,8 @@ let rec betree_Internal_lookup_in_children then betree_Node_lookup self.left key st else betree_Node_lookup self.right key st -(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 + Source: 'src/betree.rs', lines 395:4-395:63 *) and betree_Internal_lookup_in_children_back (self : betree_Internal_t) (key : u64) (st : state) (st0 : state) : Tot (result (state & betree_Internal_t)) @@ -364,7 +393,8 @@ and betree_Internal_lookup_in_children_back let* (st1, n) = betree_Node_lookup_back self.right key st st0 in Return (st1, { self with right = n }) -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function + Source: 'src/betree.rs', lines 709:4-709:58 *) and betree_Node_lookup (self : betree_Node_t) (key : u64) (st : state) : Tot (result (state & (option u64))) @@ -424,7 +454,8 @@ and betree_Node_lookup Return (st0, o) end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 709:4-709:58 *) and betree_Node_lookup_back (self : betree_Node_t) (key : u64) (st : state) (st0 : state) : Tot (result (state & betree_Node_t)) @@ -487,7 +518,8 @@ and betree_Node_lookup_back end (** [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 674:4-674:77 *) let rec betree_Node_filter_messages_for_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -506,7 +538,8 @@ let rec betree_Node_filter_messages_for_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function + Source: 'src/betree.rs', lines 689:4-692:34 *) let rec betree_Node_lookup_first_message_after_key (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : Tot (result (betree_List_t (u64 & betree_Message_t))) @@ -521,7 +554,8 @@ let rec betree_Node_lookup_first_message_after_key | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 + Source: 'src/betree.rs', lines 689:4-692:34 *) let rec betree_Node_lookup_first_message_after_key_back (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) (ret : betree_List_t (u64 & betree_Message_t)) : @@ -541,7 +575,8 @@ let rec betree_Node_lookup_first_message_after_key_back end (** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 521:4-521:89 *) let betree_Node_apply_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) (key : u64) (new_msg : betree_Message_t) : @@ -600,7 +635,8 @@ let betree_Node_apply_to_internal betree_Node_lookup_first_message_for_key_back key msgs msgs1 (** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 502:4-505:5 *) let rec betree_Node_apply_messages_to_internal (msgs : betree_List_t (u64 & betree_Message_t)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : @@ -615,7 +651,8 @@ let rec betree_Node_apply_messages_to_internal | Betree_List_Nil -> Return msgs end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function + Source: 'src/betree.rs', lines 653:4-656:32 *) let rec betree_Node_lookup_mut_in_bindings (key : u64) (bindings : betree_List_t (u64 & u64)) : Tot (result (betree_List_t (u64 & u64))) @@ -630,7 +667,8 @@ let rec betree_Node_lookup_mut_in_bindings | Betree_List_Nil -> Return Betree_List_Nil end -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 + Source: 'src/betree.rs', lines 653:4-656:32 *) let rec betree_Node_lookup_mut_in_bindings_back (key : u64) (bindings : betree_List_t (u64 & u64)) (ret : betree_List_t (u64 & u64)) : @@ -649,7 +687,8 @@ let rec betree_Node_lookup_mut_in_bindings_back end (** [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 460:4-460:87 *) let betree_Node_apply_to_leaf (bindings : betree_List_t (u64 & u64)) (key : u64) (new_msg : betree_Message_t) : @@ -689,7 +728,8 @@ let betree_Node_apply_to_leaf end (** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 444:4-447:5 *) let rec betree_Node_apply_messages_to_leaf (bindings : betree_List_t (u64 & u64)) (new_msgs : betree_List_t (u64 & betree_Message_t)) : @@ -704,7 +744,8 @@ let rec betree_Node_apply_messages_to_leaf | Betree_List_Nil -> Return bindings end -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function + Source: 'src/betree.rs', lines 410:4-415:26 *) let rec betree_Internal_flush (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -753,7 +794,8 @@ let rec betree_Internal_flush st st1 in Return (st2, msgs_left) -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 + Source: 'src/betree.rs', lines 410:4-415:26 *) and betree_Internal_flush_back'a (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -803,7 +845,8 @@ and betree_Internal_flush_back'a st st2 in Return (st0, ({ self with right = n }, node_id_cnt0)) -(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 1 + Source: 'src/betree.rs', lines 410:4-415:26 *) and betree_Internal_flush_back1 (self : betree_Internal_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -853,7 +896,8 @@ and betree_Internal_flush_back1 st st2 in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function + Source: 'src/betree.rs', lines 588:4-593:5 *) and betree_Node_apply_messages (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -894,7 +938,8 @@ and betree_Node_apply_messages Return (st1, ()) end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 + Source: 'src/betree.rs', lines 588:4-593:5 *) and betree_Node_apply_messages_back'a (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -940,7 +985,8 @@ and betree_Node_apply_messages_back'a Return (st0, (Betree_Node_Leaf { node with size = len }, node_id_cnt)) end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 1 + Source: 'src/betree.rs', lines 588:4-593:5 *) and betree_Node_apply_messages_back1 (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) @@ -982,7 +1028,8 @@ and betree_Node_apply_messages_back1 let* _ = betree_store_leaf_node node.id content0 st1 in Return (st0, ()) end -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function + Source: 'src/betree.rs', lines 576:4-582:5 *) let betree_Node_apply (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -999,7 +1046,8 @@ let betree_Node_apply betree_Node_apply_messages_back1 self params node_id_cnt (Betree_List_Cons (key, new_msg) l) st st1 -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 + Source: 'src/betree.rs', lines 576:4-582:5 *) let betree_Node_apply_back'a (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1018,7 +1066,8 @@ let betree_Node_apply_back'a (key, new_msg) l) st st2 in Return (st0, (self0, node_id_cnt0)) -(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 1 *) +(** [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 1 + Source: 'src/betree.rs', lines 576:4-582:5 *) let betree_Node_apply_back1 (self : betree_Node_t) (params : betree_Params_t) (node_id_cnt : betree_NodeIdCounter_t) (key : u64) @@ -1037,7 +1086,8 @@ let betree_Node_apply_back1 (key, new_msg) l) st st2 in Return (st0, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function + Source: 'src/betree.rs', lines 849:4-849:60 *) let betree_BeTree_new (min_flush_size : u64) (split_size : u64) (st : state) : result (state & betree_BeTree_t) @@ -1053,7 +1103,8 @@ let betree_BeTree_new root = (Betree_Node_Leaf { id = id; size = 0 }) }) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function + Source: 'src/betree.rs', lines 868:4-868:47 *) let betree_BeTree_apply (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) : result (state & unit) @@ -1065,7 +1116,8 @@ let betree_BeTree_apply st0 in betree_Node_apply_back1 self.root self.params self.node_id_cnt key msg st st1 -(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 + Source: 'src/betree.rs', lines 868:4-868:47 *) let betree_BeTree_apply_back (self : betree_BeTree_t) (key : u64) (msg : betree_Message_t) (st : state) (st0 : state) : @@ -1081,7 +1133,8 @@ let betree_BeTree_apply_back st2 in Return (st0, { self with node_id_cnt = nic; root = n }) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function + Source: 'src/betree.rs', lines 874:4-874:52 *) let betree_BeTree_insert (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) : result (state & unit) @@ -1092,7 +1145,8 @@ let betree_BeTree_insert betree_BeTree_apply_back self key (Betree_Message_Insert value) st st0 in Return (st1, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 + Source: 'src/betree.rs', lines 874:4-874:52 *) let betree_BeTree_insert_back (self : betree_BeTree_t) (key : u64) (value : u64) (st : state) (st0 : state) : @@ -1104,7 +1158,8 @@ let betree_BeTree_insert_back betree_BeTree_apply_back self key (Betree_Message_Insert value) st st1 in Return (st0, self0) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function + Source: 'src/betree.rs', lines 880:4-880:38 *) let betree_BeTree_delete (self : betree_BeTree_t) (key : u64) (st : state) : result (state & unit) = let* (st0, _) = betree_BeTree_apply self key Betree_Message_Delete st in @@ -1112,7 +1167,8 @@ let betree_BeTree_delete betree_BeTree_apply_back self key Betree_Message_Delete st st0 in Return (st1, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 + Source: 'src/betree.rs', lines 880:4-880:38 *) let betree_BeTree_delete_back (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : result (state & betree_BeTree_t) @@ -1122,7 +1178,8 @@ let betree_BeTree_delete_back betree_BeTree_apply_back self key Betree_Message_Delete st st1 in Return (st0, self0) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function + Source: 'src/betree.rs', lines 886:4-886:59 *) let betree_BeTree_upsert (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) : @@ -1134,7 +1191,8 @@ let betree_BeTree_upsert betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st0 in Return (st1, ()) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 + Source: 'src/betree.rs', lines 886:4-886:59 *) let betree_BeTree_upsert_back (self : betree_BeTree_t) (key : u64) (upd : betree_UpsertFunState_t) (st : state) (st0 : state) : @@ -1146,14 +1204,16 @@ let betree_BeTree_upsert_back betree_BeTree_apply_back self key (Betree_Message_Upsert upd) st st1 in Return (st0, self0) -(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function + Source: 'src/betree.rs', lines 895:4-895:62 *) let betree_BeTree_lookup (self : betree_BeTree_t) (key : u64) (st : state) : result (state & (option u64)) = betree_Node_lookup self.root key st -(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 *) +(** [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 895:4-895:62 *) let betree_BeTree_lookup_back (self : betree_BeTree_t) (key : u64) (st : state) (st0 : state) : result (state & betree_BeTree_t) @@ -1161,7 +1221,8 @@ let betree_BeTree_lookup_back let* (st1, n) = betree_Node_lookup_back self.root key st st0 in Return (st1, { self with root = n }) -(** [betree_main::main]: forward function *) +(** [betree_main::main]: forward function + Source: 'src/betree_main.rs', lines 5:0-5:9 *) let main : result unit = Return () diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti index 23d2e60e..b89c8718 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti @@ -6,25 +6,30 @@ include BetreeMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree_utils::load_internal_node]: forward function *) +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) val betree_utils_load_internal_node : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) -(** [betree_main::betree_utils::store_internal_node]: forward function *) +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) val betree_utils_store_internal_node : u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & unit) -(** [betree_main::betree_utils::load_leaf_node]: forward function *) +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) val betree_utils_load_leaf_node : u64 -> state -> result (state & (betree_List_t (u64 & u64))) -(** [betree_main::betree_utils::store_leaf_node]: forward function *) +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) val betree_utils_store_leaf_node : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) -(** [core::option::{core::option::Option}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti index 9320f6b7..a098ec19 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti +++ b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti @@ -5,43 +5,52 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [betree_main::betree::List] *) +(** [betree_main::betree::List] + Source: 'src/betree.rs', lines 17:0-17:23 *) type betree_List_t (t : Type0) = | Betree_List_Cons : t -> betree_List_t t -> betree_List_t t | Betree_List_Nil : betree_List_t t -(** [betree_main::betree::UpsertFunState] *) +(** [betree_main::betree::UpsertFunState] + Source: 'src/betree.rs', lines 63:0-63:23 *) type betree_UpsertFunState_t = | Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t | Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t -(** [betree_main::betree::Message] *) +(** [betree_main::betree::Message] + Source: 'src/betree.rs', lines 69:0-69:23 *) type betree_Message_t = | Betree_Message_Insert : u64 -> betree_Message_t | Betree_Message_Delete : betree_Message_t | Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t -(** [betree_main::betree::Leaf] *) +(** [betree_main::betree::Leaf] + Source: 'src/betree.rs', lines 167:0-167:11 *) type betree_Leaf_t = { id : u64; size : u64; } -(** [betree_main::betree::Internal] *) +(** [betree_main::betree::Internal] + Source: 'src/betree.rs', lines 156:0-156:15 *) type betree_Internal_t = { id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; } -(** [betree_main::betree::Node] *) +(** [betree_main::betree::Node] + Source: 'src/betree.rs', lines 179:0-179:9 *) and betree_Node_t = | Betree_Node_Internal : betree_Internal_t -> betree_Node_t | Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t -(** [betree_main::betree::Params] *) +(** [betree_main::betree::Params] + Source: 'src/betree.rs', lines 187:0-187:13 *) type betree_Params_t = { min_flush_size : u64; split_size : u64; } -(** [betree_main::betree::NodeIdCounter] *) +(** [betree_main::betree::NodeIdCounter] + Source: 'src/betree.rs', lines 201:0-201:20 *) type betree_NodeIdCounter_t = { next_node_id : u64; } -(** [betree_main::betree::BeTree] *) +(** [betree_main::betree::BeTree] + Source: 'src/betree.rs', lines 218:0-218:17 *) type betree_BeTree_t = { params : betree_Params_t; diff --git a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst index d6156720..2733b371 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst @@ -6,55 +6,64 @@ open Hashmap.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap::{hashmap::HashMap}::allocate_slots]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: decreases clause + Source: 'src/hashmap.rs', lines 50:4-56:5 *) unfold let hashMap_allocate_slots_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : nat = admit () -(** [hashmap::{hashmap::HashMap}::clear]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::clear]: decreases clause + Source: 'src/hashmap.rs', lines 80:4-88:5 *) unfold let hashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () -(** [hashmap::{hashmap::HashMap}::insert_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 97:4-114:5 *) unfold let hashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) (ls : list_t t) : nat = admit () -(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: decreases clause + Source: 'src/hashmap.rs', lines 183:4-196:5 *) unfold let hashMap_move_elements_from_list_loop_decreases (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : nat = admit () -(** [hashmap::{hashmap::HashMap}::move_elements]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::move_elements]: decreases clause + Source: 'src/hashmap.rs', lines 171:4-180:5 *) unfold let hashMap_move_elements_loop_decreases (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) (i : usize) : nat = admit () -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 206:4-219:5 *) unfold let hashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () -(** [hashmap::{hashmap::HashMap}::get_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 224:4-237:5 *) unfold let hashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = admit () -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 245:4-254:5 *) unfold let hashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : list_t t) (key : usize) : nat = admit () -(** [hashmap::{hashmap::HashMap}::remove_from_list]: decreases clause *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: decreases clause + Source: 'src/hashmap.rs', lines 265:4-291:5 *) unfold let hashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : list_t t) : nat = diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index 77e0b46a..e6cd1411 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -7,11 +7,13 @@ include Hashmap.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap::hash_key]: forward function *) +(** [hashmap::hash_key]: forward function + Source: 'src/hashmap.rs', lines 27:0-27:32 *) let hash_key (k : usize) : result usize = Return k -(** [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function + Source: 'src/hashmap.rs', lines 50:4-56:5 *) let rec hashMap_allocate_slots_loop (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : Tot (result (alloc_vec_Vec (list_t t))) @@ -24,14 +26,16 @@ let rec hashMap_allocate_slots_loop hashMap_allocate_slots_loop t slots0 n0 else Return slots -(** [hashmap::{hashmap::HashMap}::allocate_slots]: forward function *) +(** [hashmap::{hashmap::HashMap}::allocate_slots]: forward function + Source: 'src/hashmap.rs', lines 50:4-50:76 *) let hashMap_allocate_slots (t : Type0) (slots : alloc_vec_Vec (list_t t)) (n : usize) : result (alloc_vec_Vec (list_t t)) = hashMap_allocate_slots_loop t slots n -(** [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function *) +(** [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function + Source: 'src/hashmap.rs', lines 59:4-63:13 *) let hashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -49,12 +53,14 @@ let hashMap_new_with_capacity slots = slots } -(** [hashmap::{hashmap::HashMap}::new]: forward function *) +(** [hashmap::{hashmap::HashMap}::new]: forward function + Source: 'src/hashmap.rs', lines 75:4-75:24 *) let hashMap_new (t : Type0) : result (hashMap_t t) = hashMap_new_with_capacity t 32 4 5 (** [hashmap::{hashmap::HashMap}::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-88:5 *) let rec hashMap_clear_loop (t : Type0) (slots : alloc_vec_Vec (list_t t)) (i : usize) : Tot (result (alloc_vec_Vec (list_t t))) @@ -72,16 +78,19 @@ let rec hashMap_clear_loop else Return slots (** [hashmap::{hashmap::HashMap}::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-80:27 *) let hashMap_clear (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = let* v = hashMap_clear_loop t self.slots 0 in Return { self with num_entries = 0; slots = v } -(** [hashmap::{hashmap::HashMap}::len]: forward function *) +(** [hashmap::{hashmap::HashMap}::len]: forward function + Source: 'src/hashmap.rs', lines 90:4-90:30 *) let hashMap_len (t : Type0) (self : hashMap_t t) : result usize = Return self.num_entries -(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 97:4-114:5 *) let rec hashMap_insert_in_list_loop (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result bool) @@ -95,12 +104,14 @@ let rec hashMap_insert_in_list_loop | List_Nil -> Return true end -(** [hashmap::{hashmap::HashMap}::insert_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: forward function + Source: 'src/hashmap.rs', lines 97:4-97:71 *) let hashMap_insert_in_list (t : Type0) (key : usize) (value : t) (ls : list_t t) : result bool = hashMap_insert_in_list_loop t key value ls -(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-114:5 *) let rec hashMap_insert_in_list_loop_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : Tot (result (list_t t)) @@ -116,13 +127,15 @@ let rec hashMap_insert_in_list_loop_back | List_Nil -> let l = List_Nil in Return (List_Cons key value l) end -(** [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-97:71 *) let hashMap_insert_in_list_back (t : Type0) (key : usize) (value : t) (ls : list_t t) : result (list_t t) = hashMap_insert_in_list_loop_back t key value ls (** [hashmap::{hashmap::HashMap}::insert_no_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 117:4-117:54 *) let hashMap_insert_no_resize (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : result (hashMap_t t) @@ -153,7 +166,8 @@ let hashMap_insert_no_resize Return { self with slots = v } (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-196:5 *) let rec hashMap_move_elements_from_list_loop (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : Tot (result (hashMap_t t)) @@ -167,13 +181,15 @@ let rec hashMap_move_elements_from_list_loop end (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-183:72 *) let hashMap_move_elements_from_list (t : Type0) (ntable : hashMap_t t) (ls : list_t t) : result (hashMap_t t) = hashMap_move_elements_from_list_loop t ntable ls (** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-180:5 *) let rec hashMap_move_elements_loop (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) (i : usize) : @@ -197,7 +213,8 @@ let rec hashMap_move_elements_loop else Return (ntable, slots) (** [hashmap::{hashmap::HashMap}::move_elements]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-171:95 *) let hashMap_move_elements (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) (i : usize) : @@ -206,7 +223,8 @@ let hashMap_move_elements hashMap_move_elements_loop t ntable slots i (** [hashmap::{hashmap::HashMap}::try_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 140:4-140:28 *) let hashMap_try_resize (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = let* max_usize = scalar_cast U32 Usize core_u32_max in @@ -225,7 +243,8 @@ let hashMap_try_resize else Return { self with max_load_factor = (i, i0) } (** [hashmap::{hashmap::HashMap}::insert]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 129:4-129:48 *) let hashMap_insert (t : Type0) (self : hashMap_t t) (key : usize) (value : t) : result (hashMap_t t) @@ -234,7 +253,8 @@ let hashMap_insert let* i = hashMap_len t self0 in if i > self0.max_load then hashMap_try_resize t self0 else Return self0 -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 206:4-219:5 *) let rec hashMap_contains_key_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result bool) @@ -248,12 +268,14 @@ let rec hashMap_contains_key_in_list_loop | List_Nil -> Return false end -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function + Source: 'src/hashmap.rs', lines 206:4-206:68 *) let hashMap_contains_key_in_list (t : Type0) (key : usize) (ls : list_t t) : result bool = hashMap_contains_key_in_list_loop t key ls -(** [hashmap::{hashmap::HashMap}::contains_key]: forward function *) +(** [hashmap::{hashmap::HashMap}::contains_key]: forward function + Source: 'src/hashmap.rs', lines 199:4-199:49 *) let hashMap_contains_key (t : Type0) (self : hashMap_t t) (key : usize) : result bool = let* hash = hash_key key in @@ -265,7 +287,8 @@ let hashMap_contains_key hash_mod in hashMap_contains_key_in_list t key l -(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 224:4-237:5 *) let rec hashMap_get_in_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result t) (decreases (hashMap_get_in_list_loop_decreases t key ls)) @@ -276,11 +299,13 @@ let rec hashMap_get_in_list_loop | List_Nil -> Fail Failure end -(** [hashmap::{hashmap::HashMap}::get_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_in_list]: forward function + Source: 'src/hashmap.rs', lines 224:4-224:70 *) let hashMap_get_in_list (t : Type0) (key : usize) (ls : list_t t) : result t = hashMap_get_in_list_loop t key ls -(** [hashmap::{hashmap::HashMap}::get]: forward function *) +(** [hashmap::{hashmap::HashMap}::get]: forward function + Source: 'src/hashmap.rs', lines 239:4-239:55 *) let hashMap_get (t : Type0) (self : hashMap_t t) (key : usize) : result t = let* hash = hash_key key in let i = alloc_vec_Vec_len (list_t t) self.slots in @@ -291,7 +316,8 @@ let hashMap_get (t : Type0) (self : hashMap_t t) (key : usize) : result t = hash_mod in hashMap_get_in_list t key l -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 245:4-254:5 *) let rec hashMap_get_mut_in_list_loop (t : Type0) (ls : list_t t) (key : usize) : Tot (result t) (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) @@ -302,12 +328,14 @@ let rec hashMap_get_mut_in_list_loop | List_Nil -> Fail Failure end -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function + Source: 'src/hashmap.rs', lines 245:4-245:86 *) let hashMap_get_mut_in_list (t : Type0) (ls : list_t t) (key : usize) : result t = hashMap_get_mut_in_list_loop t ls key -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-254:5 *) let rec hashMap_get_mut_in_list_loop_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : Tot (result (list_t t)) @@ -323,12 +351,14 @@ let rec hashMap_get_mut_in_list_loop_back | List_Nil -> Fail Failure end -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-245:86 *) let hashMap_get_mut_in_list_back (t : Type0) (ls : list_t t) (key : usize) (ret : t) : result (list_t t) = hashMap_get_mut_in_list_loop_back t ls key ret -(** [hashmap::{hashmap::HashMap}::get_mut]: forward function *) +(** [hashmap::{hashmap::HashMap}::get_mut]: forward function + Source: 'src/hashmap.rs', lines 257:4-257:67 *) let hashMap_get_mut (t : Type0) (self : hashMap_t t) (key : usize) : result t = let* hash = hash_key key in let i = alloc_vec_Vec_len (list_t t) self.slots in @@ -339,7 +369,8 @@ let hashMap_get_mut (t : Type0) (self : hashMap_t t) (key : usize) : result t = hash_mod in hashMap_get_mut_in_list t l key -(** [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 + Source: 'src/hashmap.rs', lines 257:4-257:67 *) let hashMap_get_mut_back (t : Type0) (self : hashMap_t t) (key : usize) (ret : t) : result (hashMap_t t) @@ -358,7 +389,8 @@ let hashMap_get_mut_back hash_mod l0 in Return { self with slots = v } -(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 265:4-291:5 *) let rec hashMap_remove_from_list_loop (t : Type0) (key : usize) (ls : list_t t) : Tot (result (option t)) @@ -377,12 +409,14 @@ let rec hashMap_remove_from_list_loop | List_Nil -> Return None end -(** [hashmap::{hashmap::HashMap}::remove_from_list]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: forward function + Source: 'src/hashmap.rs', lines 265:4-265:69 *) let hashMap_remove_from_list (t : Type0) (key : usize) (ls : list_t t) : result (option t) = hashMap_remove_from_list_loop t key ls -(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-291:5 *) let rec hashMap_remove_from_list_loop_back (t : Type0) (key : usize) (ls : list_t t) : Tot (result (list_t t)) @@ -403,12 +437,14 @@ let rec hashMap_remove_from_list_loop_back | List_Nil -> Return List_Nil end -(** [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 *) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-265:69 *) let hashMap_remove_from_list_back (t : Type0) (key : usize) (ls : list_t t) : result (list_t t) = hashMap_remove_from_list_loop_back t key ls -(** [hashmap::{hashmap::HashMap}::remove]: forward function *) +(** [hashmap::{hashmap::HashMap}::remove]: forward function + Source: 'src/hashmap.rs', lines 294:4-294:52 *) let hashMap_remove (t : Type0) (self : hashMap_t t) (key : usize) : result (option t) = let* hash = hash_key key in @@ -424,7 +460,8 @@ let hashMap_remove | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end -(** [hashmap::{hashmap::HashMap}::remove]: backward function 0 *) +(** [hashmap::{hashmap::HashMap}::remove]: backward function 0 + Source: 'src/hashmap.rs', lines 294:4-294:52 *) let hashMap_remove_back (t : Type0) (self : hashMap_t t) (key : usize) : result (hashMap_t t) = let* hash = hash_key key in @@ -453,7 +490,8 @@ let hashMap_remove_back Return { self with num_entries = i0; slots = v } end -(** [hashmap::test1]: forward function *) +(** [hashmap::test1]: forward function + Source: 'src/hashmap.rs', lines 315:0-315:10 *) let test1 : result unit = let* hm = hashMap_new u64 in let* hm0 = hashMap_insert u64 hm 0 42 in diff --git a/tests/fstar/hashmap/Hashmap.Types.fst b/tests/fstar/hashmap/Hashmap.Types.fst index 753730fe..ef96b1e9 100644 --- a/tests/fstar/hashmap/Hashmap.Types.fst +++ b/tests/fstar/hashmap/Hashmap.Types.fst @@ -5,12 +5,14 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap::List] *) +(** [hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 *) type list_t (t : Type0) = | List_Cons : usize -> t -> list_t t -> list_t t | List_Nil : list_t t -(** [hashmap::HashMap] *) +(** [hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 *) type hashMap_t (t : Type0) = { num_entries : usize; diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst index 106fa94b..7b274f59 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst @@ -6,56 +6,65 @@ open HashmapMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: decreases clause + Source: 'src/hashmap.rs', lines 50:4-56:5 *) unfold let hashmap_HashMap_allocate_slots_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: decreases clause + Source: 'src/hashmap.rs', lines 80:4-88:5 *) unfold let hashmap_HashMap_clear_loop_decreases (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 97:4-114:5 *) unfold let hashmap_HashMap_insert_in_list_loop_decreases (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: decreases clause + Source: 'src/hashmap.rs', lines 183:4-196:5 *) unfold let hashmap_HashMap_move_elements_from_list_loop_decreases (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: decreases clause + Source: 'src/hashmap.rs', lines 171:4-180:5 *) unfold let hashmap_HashMap_move_elements_loop_decreases (t : Type0) (ntable : hashmap_HashMap_t t) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 206:4-219:5 *) unfold let hashmap_HashMap_contains_key_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 224:4-237:5 *) unfold let hashmap_HashMap_get_in_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: decreases clause + Source: 'src/hashmap.rs', lines 245:4-254:5 *) unfold let hashmap_HashMap_get_mut_in_list_loop_decreases (t : Type0) (ls : hashmap_List_t t) (key : usize) : nat = admit () -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: decreases clause *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: decreases clause + Source: 'src/hashmap.rs', lines 265:4-291:5 *) unfold let hashmap_HashMap_remove_from_list_loop_decreases (t : Type0) (key : usize) (ls : hashmap_List_t t) : nat = diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 30bcfb2e..fa570309 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -8,11 +8,13 @@ include HashmapMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap_main::hashmap::hash_key]: forward function *) +(** [hashmap_main::hashmap::hash_key]: forward function + Source: 'src/hashmap.rs', lines 27:0-27:32 *) let hashmap_hash_key (k : usize) : result usize = Return k -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function + Source: 'src/hashmap.rs', lines 50:4-56:5 *) let rec hashmap_HashMap_allocate_slots_loop (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : Tot (result (alloc_vec_Vec (hashmap_List_t t))) @@ -26,14 +28,16 @@ let rec hashmap_HashMap_allocate_slots_loop hashmap_HashMap_allocate_slots_loop t slots0 n0 else Return slots -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function + Source: 'src/hashmap.rs', lines 50:4-50:76 *) let hashmap_HashMap_allocate_slots (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (n : usize) : result (alloc_vec_Vec (hashmap_List_t t)) = hashmap_HashMap_allocate_slots_loop t slots n -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function + Source: 'src/hashmap.rs', lines 59:4-63:13 *) let hashmap_HashMap_new_with_capacity (t : Type0) (capacity : usize) (max_load_dividend : usize) (max_load_divisor : usize) : @@ -51,12 +55,14 @@ let hashmap_HashMap_new_with_capacity slots = slots } -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function + Source: 'src/hashmap.rs', lines 75:4-75:24 *) let hashmap_HashMap_new (t : Type0) : result (hashmap_HashMap_t t) = hashmap_HashMap_new_with_capacity t 32 4 5 (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-88:5 *) let rec hashmap_HashMap_clear_loop (t : Type0) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : Tot (result (alloc_vec_Vec (hashmap_List_t t))) @@ -74,18 +80,21 @@ let rec hashmap_HashMap_clear_loop else Return slots (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-80:27 *) let hashmap_HashMap_clear (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = let* v = hashmap_HashMap_clear_loop t self.slots 0 in Return { self with num_entries = 0; slots = v } -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function + Source: 'src/hashmap.rs', lines 90:4-90:30 *) let hashmap_HashMap_len (t : Type0) (self : hashmap_HashMap_t t) : result usize = Return self.num_entries -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 97:4-114:5 *) let rec hashmap_HashMap_insert_in_list_loop (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : Tot (result bool) @@ -99,12 +108,14 @@ let rec hashmap_HashMap_insert_in_list_loop | Hashmap_List_Nil -> Return true end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function + Source: 'src/hashmap.rs', lines 97:4-97:71 *) let hashmap_HashMap_insert_in_list (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : result bool = hashmap_HashMap_insert_in_list_loop t key value ls -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-114:5 *) let rec hashmap_HashMap_insert_in_list_loop_back (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : Tot (result (hashmap_List_t t)) @@ -121,7 +132,8 @@ let rec hashmap_HashMap_insert_in_list_loop_back let l = Hashmap_List_Nil in Return (Hashmap_List_Cons key value l) end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-97:71 *) let hashmap_HashMap_insert_in_list_back (t : Type0) (key : usize) (value : t) (ls : hashmap_List_t t) : result (hashmap_List_t t) @@ -129,7 +141,8 @@ let hashmap_HashMap_insert_in_list_back hashmap_HashMap_insert_in_list_loop_back t key value ls (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 117:4-117:54 *) let hashmap_HashMap_insert_no_resize (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : result (hashmap_HashMap_t t) @@ -160,7 +173,8 @@ let hashmap_HashMap_insert_no_resize Return { self with slots = v } (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-196:5 *) let rec hashmap_HashMap_move_elements_from_list_loop (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : Tot (result (hashmap_HashMap_t t)) @@ -175,7 +189,8 @@ let rec hashmap_HashMap_move_elements_from_list_loop end (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-183:72 *) let hashmap_HashMap_move_elements_from_list (t : Type0) (ntable : hashmap_HashMap_t t) (ls : hashmap_List_t t) : result (hashmap_HashMap_t t) @@ -183,7 +198,8 @@ let hashmap_HashMap_move_elements_from_list hashmap_HashMap_move_elements_from_list_loop t ntable ls (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-180:5 *) let rec hashmap_HashMap_move_elements_loop (t : Type0) (ntable : hashmap_HashMap_t t) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : @@ -209,7 +225,8 @@ let rec hashmap_HashMap_move_elements_loop else Return (ntable, slots) (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-171:95 *) let hashmap_HashMap_move_elements (t : Type0) (ntable : hashmap_HashMap_t t) (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : @@ -218,7 +235,8 @@ let hashmap_HashMap_move_elements hashmap_HashMap_move_elements_loop t ntable slots i (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 140:4-140:28 *) let hashmap_HashMap_try_resize (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = let* max_usize = scalar_cast U32 Usize core_u32_max in @@ -237,7 +255,8 @@ let hashmap_HashMap_try_resize else Return { self with max_load_factor = (i, i0) } (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 129:4-129:48 *) let hashmap_HashMap_insert (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (value : t) : result (hashmap_HashMap_t t) @@ -248,7 +267,8 @@ let hashmap_HashMap_insert then hashmap_HashMap_try_resize t self0 else Return self0 -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 206:4-219:5 *) let rec hashmap_HashMap_contains_key_in_list_loop (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result bool) @@ -262,12 +282,14 @@ let rec hashmap_HashMap_contains_key_in_list_loop | Hashmap_List_Nil -> Return false end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function + Source: 'src/hashmap.rs', lines 206:4-206:68 *) let hashmap_HashMap_contains_key_in_list (t : Type0) (key : usize) (ls : hashmap_List_t t) : result bool = hashmap_HashMap_contains_key_in_list_loop t key ls -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function + Source: 'src/hashmap.rs', lines 199:4-199:49 *) let hashmap_HashMap_contains_key (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result bool = let* hash = hashmap_hash_key key in @@ -279,7 +301,8 @@ let hashmap_HashMap_contains_key self.slots hash_mod in hashmap_HashMap_contains_key_in_list t key l -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 224:4-237:5 *) let rec hashmap_HashMap_get_in_list_loop (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result t) @@ -293,12 +316,14 @@ let rec hashmap_HashMap_get_in_list_loop | Hashmap_List_Nil -> Fail Failure end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function + Source: 'src/hashmap.rs', lines 224:4-224:70 *) let hashmap_HashMap_get_in_list (t : Type0) (key : usize) (ls : hashmap_List_t t) : result t = hashmap_HashMap_get_in_list_loop t key ls -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function + Source: 'src/hashmap.rs', lines 239:4-239:55 *) let hashmap_HashMap_get (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = let* hash = hashmap_hash_key key in @@ -310,7 +335,8 @@ let hashmap_HashMap_get self.slots hash_mod in hashmap_HashMap_get_in_list t key l -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 245:4-254:5 *) let rec hashmap_HashMap_get_mut_in_list_loop (t : Type0) (ls : hashmap_List_t t) (key : usize) : Tot (result t) @@ -324,12 +350,14 @@ let rec hashmap_HashMap_get_mut_in_list_loop | Hashmap_List_Nil -> Fail Failure end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function + Source: 'src/hashmap.rs', lines 245:4-245:86 *) let hashmap_HashMap_get_mut_in_list (t : Type0) (ls : hashmap_List_t t) (key : usize) : result t = hashmap_HashMap_get_mut_in_list_loop t ls key -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-254:5 *) let rec hashmap_HashMap_get_mut_in_list_loop_back (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : Tot (result (hashmap_List_t t)) @@ -345,14 +373,16 @@ let rec hashmap_HashMap_get_mut_in_list_loop_back | Hashmap_List_Nil -> Fail Failure end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-245:86 *) let hashmap_HashMap_get_mut_in_list_back (t : Type0) (ls : hashmap_List_t t) (key : usize) (ret : t) : result (hashmap_List_t t) = hashmap_HashMap_get_mut_in_list_loop_back t ls key ret -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function + Source: 'src/hashmap.rs', lines 257:4-257:67 *) let hashmap_HashMap_get_mut (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result t = let* hash = hashmap_hash_key key in @@ -364,7 +394,8 @@ let hashmap_HashMap_get_mut self.slots hash_mod in hashmap_HashMap_get_mut_in_list t l key -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 + Source: 'src/hashmap.rs', lines 257:4-257:67 *) let hashmap_HashMap_get_mut_back (t : Type0) (self : hashmap_HashMap_t t) (key : usize) (ret : t) : result (hashmap_HashMap_t t) @@ -383,7 +414,8 @@ let hashmap_HashMap_get_mut_back self.slots hash_mod l0 in Return { self with slots = v } -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 265:4-291:5 *) let rec hashmap_HashMap_remove_from_list_loop (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result (option t)) @@ -404,12 +436,14 @@ let rec hashmap_HashMap_remove_from_list_loop | Hashmap_List_Nil -> Return None end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function + Source: 'src/hashmap.rs', lines 265:4-265:69 *) let hashmap_HashMap_remove_from_list (t : Type0) (key : usize) (ls : hashmap_List_t t) : result (option t) = hashmap_HashMap_remove_from_list_loop t key ls -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-291:5 *) let rec hashmap_HashMap_remove_from_list_loop_back (t : Type0) (key : usize) (ls : hashmap_List_t t) : Tot (result (hashmap_List_t t)) @@ -432,14 +466,16 @@ let rec hashmap_HashMap_remove_from_list_loop_back | Hashmap_List_Nil -> Return Hashmap_List_Nil end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-265:69 *) let hashmap_HashMap_remove_from_list_back (t : Type0) (key : usize) (ls : hashmap_List_t t) : result (hashmap_List_t t) = hashmap_HashMap_remove_from_list_loop_back t key ls -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function + Source: 'src/hashmap.rs', lines 294:4-294:52 *) let hashmap_HashMap_remove (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result (option t) = let* hash = hashmap_hash_key key in @@ -455,7 +491,8 @@ let hashmap_HashMap_remove | Some x0 -> let* _ = usize_sub self.num_entries 1 in Return (Some x0) end -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 *) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 + Source: 'src/hashmap.rs', lines 294:4-294:52 *) let hashmap_HashMap_remove_back (t : Type0) (self : hashmap_HashMap_t t) (key : usize) : result (hashmap_HashMap_t t) @@ -486,7 +523,8 @@ let hashmap_HashMap_remove_back Return { self with num_entries = i0; slots = v } end -(** [hashmap_main::hashmap::test1]: forward function *) +(** [hashmap_main::hashmap::test1]: forward function + Source: 'src/hashmap.rs', lines 315:0-315:10 *) let hashmap_test1 : result unit = let* hm = hashmap_HashMap_new u64 in let* hm0 = hashmap_HashMap_insert u64 hm 0 42 in @@ -522,7 +560,8 @@ let hashmap_test1 : result unit = if not (i3 = 256) then Fail Failure else Return () end -(** [hashmap_main::insert_on_disk]: forward function *) +(** [hashmap_main::insert_on_disk]: forward function + Source: 'src/hashmap_main.rs', lines 7:0-7:43 *) let insert_on_disk (key : usize) (value : u64) (st : state) : result (state & unit) = let* (st0, hm) = hashmap_utils_deserialize st in @@ -530,7 +569,8 @@ let insert_on_disk let* (st1, _) = hashmap_utils_serialize hm0 st0 in Return (st1, ()) -(** [hashmap_main::main]: forward function *) +(** [hashmap_main::main]: forward function + Source: 'src/hashmap_main.rs', lines 16:0-16:13 *) let main : result unit = Return () diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti index d6cecf36..1f47eb33 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti @@ -6,11 +6,13 @@ include HashmapMain.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap_main::hashmap_utils::deserialize]: forward function *) +(** [hashmap_main::hashmap_utils::deserialize]: forward function + Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) val hashmap_utils_deserialize : state -> result (state & (hashmap_HashMap_t u64)) -(** [hashmap_main::hashmap_utils::serialize]: forward function *) +(** [hashmap_main::hashmap_utils::serialize]: forward function + Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) val hashmap_utils_serialize : hashmap_HashMap_t u64 -> state -> result (state & unit) diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti index 24b78c2a..e77954ad 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti @@ -5,12 +5,14 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [hashmap_main::hashmap::List] *) +(** [hashmap_main::hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 *) type hashmap_List_t (t : Type0) = | Hashmap_List_Cons : usize -> t -> hashmap_List_t t -> hashmap_List_t t | Hashmap_List_Nil : hashmap_List_t t -(** [hashmap_main::hashmap::HashMap] *) +(** [hashmap_main::hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 *) type hashmap_HashMap_t (t : Type0) = { num_entries : usize; diff --git a/tests/fstar/misc/Constants.fst b/tests/fstar/misc/Constants.fst index 2f2fccdb..daeefbb0 100644 --- a/tests/fstar/misc/Constants.fst +++ b/tests/fstar/misc/Constants.fst @@ -5,113 +5,141 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [constants::X0] *) +(** [constants::X0] + Source: 'src/constants.rs', lines 5:0-5:17 *) let x0_body : result u32 = Return 0 let x0_c : u32 = eval_global x0_body -(** [constants::X1] *) +(** [constants::X1] + Source: 'src/constants.rs', lines 7:0-7:17 *) let x1_body : result u32 = Return core_u32_max let x1_c : u32 = eval_global x1_body -(** [constants::X2] *) +(** [constants::X2] + Source: 'src/constants.rs', lines 10:0-10:17 *) let x2_body : result u32 = Return 3 let x2_c : u32 = eval_global x2_body -(** [constants::incr]: forward function *) +(** [constants::incr]: forward function + Source: 'src/constants.rs', lines 17:0-17:32 *) let incr (n : u32) : result u32 = u32_add n 1 -(** [constants::X3] *) +(** [constants::X3] + Source: 'src/constants.rs', lines 15:0-15:17 *) let x3_body : result u32 = incr 32 let x3_c : u32 = eval_global x3_body -(** [constants::mk_pair0]: forward function *) +(** [constants::mk_pair0]: forward function + Source: 'src/constants.rs', lines 23:0-23:51 *) let mk_pair0 (x : u32) (y : u32) : result (u32 & u32) = Return (x, y) -(** [constants::Pair] *) +(** [constants::Pair] + Source: 'src/constants.rs', lines 36:0-36:23 *) type pair_t (t1 t2 : Type0) = { x : t1; y : t2; } -(** [constants::mk_pair1]: forward function *) +(** [constants::mk_pair1]: forward function + Source: 'src/constants.rs', lines 27:0-27:55 *) let mk_pair1 (x : u32) (y : u32) : result (pair_t u32 u32) = Return { x = x; y = y } -(** [constants::P0] *) +(** [constants::P0] + Source: 'src/constants.rs', lines 31:0-31:24 *) let p0_body : result (u32 & u32) = mk_pair0 0 1 let p0_c : (u32 & u32) = eval_global p0_body -(** [constants::P1] *) +(** [constants::P1] + Source: 'src/constants.rs', lines 32:0-32:28 *) let p1_body : result (pair_t u32 u32) = mk_pair1 0 1 let p1_c : pair_t u32 u32 = eval_global p1_body -(** [constants::P2] *) +(** [constants::P2] + Source: 'src/constants.rs', lines 33:0-33:24 *) let p2_body : result (u32 & u32) = Return (0, 1) let p2_c : (u32 & u32) = eval_global p2_body -(** [constants::P3] *) +(** [constants::P3] + Source: 'src/constants.rs', lines 34:0-34:28 *) let p3_body : result (pair_t u32 u32) = Return { x = 0; y = 1 } let p3_c : pair_t u32 u32 = eval_global p3_body -(** [constants::Wrap] *) +(** [constants::Wrap] + Source: 'src/constants.rs', lines 49:0-49:18 *) type wrap_t (t : Type0) = { value : t; } -(** [constants::{constants::Wrap}::new]: forward function *) +(** [constants::{constants::Wrap}::new]: forward function + Source: 'src/constants.rs', lines 54:4-54:41 *) let wrap_new (t : Type0) (value : t) : result (wrap_t t) = Return { value = value } -(** [constants::Y] *) +(** [constants::Y] + Source: 'src/constants.rs', lines 41:0-41:22 *) let y_body : result (wrap_t i32) = wrap_new i32 2 let y_c : wrap_t i32 = eval_global y_body -(** [constants::unwrap_y]: forward function *) +(** [constants::unwrap_y]: forward function + Source: 'src/constants.rs', lines 43:0-43:30 *) let unwrap_y : result i32 = Return y_c.value -(** [constants::YVAL] *) +(** [constants::YVAL] + Source: 'src/constants.rs', lines 47:0-47:19 *) let yval_body : result i32 = unwrap_y let yval_c : i32 = eval_global yval_body -(** [constants::get_z1::Z1] *) +(** [constants::get_z1::Z1] + Source: 'src/constants.rs', lines 62:4-62:17 *) let get_z1_z1_body : result i32 = Return 3 let get_z1_z1_c : i32 = eval_global get_z1_z1_body -(** [constants::get_z1]: forward function *) +(** [constants::get_z1]: forward function + Source: 'src/constants.rs', lines 61:0-61:28 *) let get_z1 : result i32 = Return get_z1_z1_c -(** [constants::add]: forward function *) +(** [constants::add]: forward function + Source: 'src/constants.rs', lines 66:0-66:39 *) let add (a : i32) (b : i32) : result i32 = i32_add a b -(** [constants::Q1] *) +(** [constants::Q1] + Source: 'src/constants.rs', lines 74:0-74:17 *) let q1_body : result i32 = Return 5 let q1_c : i32 = eval_global q1_body -(** [constants::Q2] *) +(** [constants::Q2] + Source: 'src/constants.rs', lines 75:0-75:17 *) let q2_body : result i32 = Return q1_c let q2_c : i32 = eval_global q2_body -(** [constants::Q3] *) +(** [constants::Q3] + Source: 'src/constants.rs', lines 76:0-76:17 *) let q3_body : result i32 = add q2_c 3 let q3_c : i32 = eval_global q3_body -(** [constants::get_z2]: forward function *) +(** [constants::get_z2]: forward function + Source: 'src/constants.rs', lines 70:0-70:28 *) let get_z2 : result i32 = let* i = get_z1 in let* i0 = add i q3_c in add q1_c i0 -(** [constants::S1] *) +(** [constants::S1] + Source: 'src/constants.rs', lines 80:0-80:18 *) let s1_body : result u32 = Return 6 let s1_c : u32 = eval_global s1_body -(** [constants::S2] *) +(** [constants::S2] + Source: 'src/constants.rs', lines 81:0-81:18 *) let s2_body : result u32 = incr s1_c let s2_c : u32 = eval_global s2_body -(** [constants::S3] *) +(** [constants::S3] + Source: 'src/constants.rs', lines 82:0-82:29 *) let s3_body : result (pair_t u32 u32) = Return p3_c let s3_c : pair_t u32 u32 = eval_global s3_body -(** [constants::S4] *) +(** [constants::S4] + Source: 'src/constants.rs', lines 83:0-83:29 *) let s4_body : result (pair_t u32 u32) = mk_pair1 7 8 let s4_c : pair_t u32 u32 = eval_global s4_body diff --git a/tests/fstar/misc/External.Funs.fst b/tests/fstar/misc/External.Funs.fst index e26014ac..4d13fb71 100644 --- a/tests/fstar/misc/External.Funs.fst +++ b/tests/fstar/misc/External.Funs.fst @@ -7,14 +7,16 @@ include External.Opaque #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [external::swap]: forward function *) +(** [external::swap]: forward function + Source: 'src/external.rs', lines 6:0-6:46 *) let swap (t : Type0) (x : t) (y : t) (st : state) : result (state & unit) = let* (st0, _) = core_mem_swap t x y st in let* (st1, _) = core_mem_swap_back0 t x y st st0 in let* (st2, _) = core_mem_swap_back1 t x y st st1 in Return (st2, ()) -(** [external::swap]: backward function 0 *) +(** [external::swap]: backward function 0 + Source: 'src/external.rs', lines 6:0-6:46 *) let swap_back (t : Type0) (x : t) (y : t) (st : state) (st0 : state) : result (state & (t & t)) @@ -24,13 +26,15 @@ let swap_back let* (_, y0) = core_mem_swap_back1 t x y st st2 in Return (st0, (x0, y0)) -(** [external::test_new_non_zero_u32]: forward function *) +(** [external::test_new_non_zero_u32]: forward function + Source: 'src/external.rs', lines 11:0-11:60 *) let test_new_non_zero_u32 (x : u32) (st : state) : result (state & core_num_nonzero_NonZeroU32_t) = let* (st0, o) = core_num_nonzero_NonZeroU32_new x st in core_option_Option_unwrap core_num_nonzero_NonZeroU32_t o st0 -(** [external::test_vec]: forward function *) +(** [external::test_vec]: forward function + Source: 'src/external.rs', lines 17:0-17:17 *) let test_vec : result unit = let v = alloc_vec_Vec_new u32 in let* _ = alloc_vec_Vec_push u32 v 0 in @@ -39,14 +43,16 @@ let test_vec : result unit = (** Unit test for [external::test_vec] *) let _ = assert_norm (test_vec = Return ()) -(** [external::custom_swap]: forward function *) +(** [external::custom_swap]: forward function + Source: 'src/external.rs', lines 24:0-24:66 *) let custom_swap (t : Type0) (x : t) (y : t) (st : state) : result (state & t) = let* (st0, _) = core_mem_swap t x y st in let* (st1, x0) = core_mem_swap_back0 t x y st st0 in let* (st2, _) = core_mem_swap_back1 t x y st st1 in Return (st2, x0) -(** [external::custom_swap]: backward function 0 *) +(** [external::custom_swap]: backward function 0 + Source: 'src/external.rs', lines 24:0-24:66 *) let custom_swap_back (t : Type0) (x : t) (y : t) (st : state) (ret : t) (st0 : state) : result (state & (t & t)) @@ -56,18 +62,21 @@ let custom_swap_back let* (_, y0) = core_mem_swap_back1 t x y st st2 in Return (st0, (ret, y0)) -(** [external::test_custom_swap]: forward function *) +(** [external::test_custom_swap]: forward function + Source: 'src/external.rs', lines 29:0-29:59 *) let test_custom_swap (x : u32) (y : u32) (st : state) : result (state & unit) = let* (st0, _) = custom_swap u32 x y st in Return (st0, ()) -(** [external::test_custom_swap]: backward function 0 *) +(** [external::test_custom_swap]: backward function 0 + Source: 'src/external.rs', lines 29:0-29:59 *) let test_custom_swap_back (x : u32) (y : u32) (st : state) (st0 : state) : result (state & (u32 & u32)) = custom_swap_back u32 x y st 1 st0 -(** [external::test_swap_non_zero]: forward function *) +(** [external::test_swap_non_zero]: forward function + Source: 'src/external.rs', lines 35:0-35:44 *) let test_swap_non_zero (x : u32) (st : state) : result (state & u32) = let* (st0, _) = swap u32 x 0 st in let* (st1, (x0, _)) = swap_back u32 x 0 st st0 in diff --git a/tests/fstar/misc/External.Opaque.fsti b/tests/fstar/misc/External.Opaque.fsti index 3914a8eb..ea1a70c2 100644 --- a/tests/fstar/misc/External.Opaque.fsti +++ b/tests/fstar/misc/External.Opaque.fsti @@ -6,22 +6,27 @@ include External.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [core::mem::swap]: forward function *) +(** [core::mem::swap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) val core_mem_swap (t : Type0) : t -> t -> state -> result (state & unit) -(** [core::mem::swap]: backward function 0 *) +(** [core::mem::swap]: backward function 0 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) val core_mem_swap_back0 (t : Type0) : t -> t -> state -> state -> result (state & t) -(** [core::mem::swap]: backward function 1 *) +(** [core::mem::swap]: backward function 1 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) val core_mem_swap_back1 (t : Type0) : t -> t -> state -> state -> result (state & t) -(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function *) +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) val core_num_nonzero_NonZeroU32_new : u32 -> state -> result (state & (option core_num_nonzero_NonZeroU32_t)) -(** [core::option::{core::option::Option}::unwrap]: forward function *) +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) val core_option_Option_unwrap (t : Type0) : option t -> state -> result (state & t) diff --git a/tests/fstar/misc/External.Types.fsti b/tests/fstar/misc/External.Types.fsti index 78b5228d..0cb9fd0e 100644 --- a/tests/fstar/misc/External.Types.fsti +++ b/tests/fstar/misc/External.Types.fsti @@ -5,7 +5,8 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [core::num::nonzero::NonZeroU32] *) +(** [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) val core_num_nonzero_NonZeroU32_t : Type0 (** The state type used in the state-error monad *) diff --git a/tests/fstar/misc/Loops.Clauses.Template.fst b/tests/fstar/misc/Loops.Clauses.Template.fst index 9920bdc1..6be351c6 100644 --- a/tests/fstar/misc/Loops.Clauses.Template.fst +++ b/tests/fstar/misc/Loops.Clauses.Template.fst @@ -6,105 +6,124 @@ open Loops.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [loops::sum]: decreases clause *) +(** [loops::sum]: decreases clause + Source: 'src/loops.rs', lines 4:0-14:1 *) unfold let sum_loop_decreases (max : u32) (i : u32) (s : u32) : nat = admit () -(** [loops::sum_with_mut_borrows]: decreases clause *) +(** [loops::sum_with_mut_borrows]: decreases clause + Source: 'src/loops.rs', lines 19:0-31:1 *) unfold let sum_with_mut_borrows_loop_decreases (max : u32) (mi : u32) (ms : u32) : nat = admit () -(** [loops::sum_with_shared_borrows]: decreases clause *) +(** [loops::sum_with_shared_borrows]: decreases clause + Source: 'src/loops.rs', lines 34:0-48:1 *) unfold let sum_with_shared_borrows_loop_decreases (max : u32) (i : u32) (s : u32) : nat = admit () -(** [loops::clear]: decreases clause *) +(** [loops::clear]: decreases clause + Source: 'src/loops.rs', lines 52:0-58:1 *) unfold let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () -(** [loops::list_mem]: decreases clause *) +(** [loops::list_mem]: decreases clause + Source: 'src/loops.rs', lines 66:0-75:1 *) unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () -(** [loops::list_nth_mut_loop]: decreases clause *) +(** [loops::list_nth_mut_loop]: decreases clause + Source: 'src/loops.rs', lines 78:0-88:1 *) unfold let list_nth_mut_loop_loop_decreases (t : Type0) (ls : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_shared_loop]: decreases clause *) +(** [loops::list_nth_shared_loop]: decreases clause + Source: 'src/loops.rs', lines 91:0-101:1 *) unfold let list_nth_shared_loop_loop_decreases (t : Type0) (ls : list_t t) (i : u32) : nat = admit () -(** [loops::get_elem_mut]: decreases clause *) +(** [loops::get_elem_mut]: decreases clause + Source: 'src/loops.rs', lines 103:0-117:1 *) unfold let get_elem_mut_loop_decreases (x : usize) (ls : list_t usize) : nat = admit () -(** [loops::get_elem_shared]: decreases clause *) +(** [loops::get_elem_shared]: decreases clause + Source: 'src/loops.rs', lines 119:0-133:1 *) unfold let get_elem_shared_loop_decreases (x : usize) (ls : list_t usize) : nat = admit () -(** [loops::list_nth_mut_loop_with_id]: decreases clause *) +(** [loops::list_nth_mut_loop_with_id]: decreases clause + Source: 'src/loops.rs', lines 144:0-155:1 *) unfold let list_nth_mut_loop_with_id_loop_decreases (t : Type0) (i : u32) (ls : list_t t) : nat = admit () -(** [loops::list_nth_shared_loop_with_id]: decreases clause *) +(** [loops::list_nth_shared_loop_with_id]: decreases clause + Source: 'src/loops.rs', lines 158:0-169:1 *) unfold let list_nth_shared_loop_with_id_loop_decreases (t : Type0) (i : u32) (ls : list_t t) : nat = admit () -(** [loops::list_nth_mut_loop_pair]: decreases clause *) +(** [loops::list_nth_mut_loop_pair]: decreases clause + Source: 'src/loops.rs', lines 174:0-195:1 *) unfold let list_nth_mut_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_shared_loop_pair]: decreases clause *) +(** [loops::list_nth_shared_loop_pair]: decreases clause + Source: 'src/loops.rs', lines 198:0-219:1 *) unfold let list_nth_shared_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_mut_loop_pair_merge]: decreases clause *) +(** [loops::list_nth_mut_loop_pair_merge]: decreases clause + Source: 'src/loops.rs', lines 223:0-238:1 *) unfold let list_nth_mut_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_shared_loop_pair_merge]: decreases clause *) +(** [loops::list_nth_shared_loop_pair_merge]: decreases clause + Source: 'src/loops.rs', lines 241:0-256:1 *) unfold let list_nth_shared_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_mut_shared_loop_pair]: decreases clause *) +(** [loops::list_nth_mut_shared_loop_pair]: decreases clause + Source: 'src/loops.rs', lines 259:0-274:1 *) unfold let list_nth_mut_shared_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_mut_shared_loop_pair_merge]: decreases clause *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: decreases clause + Source: 'src/loops.rs', lines 278:0-293:1 *) unfold let list_nth_mut_shared_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_shared_mut_loop_pair]: decreases clause *) +(** [loops::list_nth_shared_mut_loop_pair]: decreases clause + Source: 'src/loops.rs', lines 297:0-312:1 *) unfold let list_nth_shared_mut_loop_pair_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = admit () -(** [loops::list_nth_shared_mut_loop_pair_merge]: decreases clause *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: decreases clause + Source: 'src/loops.rs', lines 316:0-331:1 *) unfold let list_nth_shared_mut_loop_pair_merge_loop_decreases (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : nat = diff --git a/tests/fstar/misc/Loops.Funs.fst b/tests/fstar/misc/Loops.Funs.fst index 4dd3a5dd..d2ac5561 100644 --- a/tests/fstar/misc/Loops.Funs.fst +++ b/tests/fstar/misc/Loops.Funs.fst @@ -7,7 +7,8 @@ include Loops.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [loops::sum]: loop 0: forward function *) +(** [loops::sum]: loop 0: forward function + Source: 'src/loops.rs', lines 4:0-14:1 *) let rec sum_loop (max : u32) (i : u32) (s : u32) : Tot (result u32) (decreases (sum_loop_decreases max i s)) @@ -16,11 +17,13 @@ let rec sum_loop then let* s0 = u32_add s i in let* i0 = u32_add i 1 in sum_loop max i0 s0 else u32_mul s 2 -(** [loops::sum]: forward function *) +(** [loops::sum]: forward function + Source: 'src/loops.rs', lines 4:0-4:27 *) let sum (max : u32) : result u32 = sum_loop max 0 0 -(** [loops::sum_with_mut_borrows]: loop 0: forward function *) +(** [loops::sum_with_mut_borrows]: loop 0: forward function + Source: 'src/loops.rs', lines 19:0-31:1 *) let rec sum_with_mut_borrows_loop (max : u32) (mi : u32) (ms : u32) : Tot (result u32) (decreases (sum_with_mut_borrows_loop_decreases max mi ms)) @@ -32,11 +35,13 @@ let rec sum_with_mut_borrows_loop sum_with_mut_borrows_loop max mi0 ms0 else u32_mul ms 2 -(** [loops::sum_with_mut_borrows]: forward function *) +(** [loops::sum_with_mut_borrows]: forward function + Source: 'src/loops.rs', lines 19:0-19:44 *) let sum_with_mut_borrows (max : u32) : result u32 = sum_with_mut_borrows_loop max 0 0 -(** [loops::sum_with_shared_borrows]: loop 0: forward function *) +(** [loops::sum_with_shared_borrows]: loop 0: forward function + Source: 'src/loops.rs', lines 34:0-48:1 *) let rec sum_with_shared_borrows_loop (max : u32) (i : u32) (s : u32) : Tot (result u32) (decreases (sum_with_shared_borrows_loop_decreases max i s)) @@ -48,12 +53,14 @@ let rec sum_with_shared_borrows_loop sum_with_shared_borrows_loop max i0 s0 else u32_mul s 2 -(** [loops::sum_with_shared_borrows]: forward function *) +(** [loops::sum_with_shared_borrows]: forward function + Source: 'src/loops.rs', lines 34:0-34:47 *) let sum_with_shared_borrows (max : u32) : result u32 = sum_with_shared_borrows_loop max 0 0 (** [loops::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/loops.rs', lines 52:0-58:1 *) let rec clear_loop (v : alloc_vec_Vec u32) (i : usize) : Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) @@ -69,11 +76,13 @@ let rec clear_loop else Return v (** [loops::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/loops.rs', lines 52:0-52:30 *) let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = clear_loop v 0 -(** [loops::list_mem]: loop 0: forward function *) +(** [loops::list_mem]: loop 0: forward function + Source: 'src/loops.rs', lines 66:0-75:1 *) let rec list_mem_loop (x : u32) (ls : list_t u32) : Tot (result bool) (decreases (list_mem_loop_decreases x ls)) @@ -83,11 +92,13 @@ let rec list_mem_loop | List_Nil -> Return false end -(** [loops::list_mem]: forward function *) +(** [loops::list_mem]: forward function + Source: 'src/loops.rs', lines 66:0-66:52 *) let list_mem (x : u32) (ls : list_t u32) : result bool = list_mem_loop x ls -(** [loops::list_nth_mut_loop]: loop 0: forward function *) +(** [loops::list_nth_mut_loop]: loop 0: forward function + Source: 'src/loops.rs', lines 78:0-88:1 *) let rec list_nth_mut_loop_loop (t : Type0) (ls : list_t t) (i : u32) : Tot (result t) (decreases (list_nth_mut_loop_loop_decreases t ls i)) @@ -100,11 +111,13 @@ let rec list_nth_mut_loop_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop]: forward function *) +(** [loops::list_nth_mut_loop]: forward function + Source: 'src/loops.rs', lines 78:0-78:71 *) let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result t = list_nth_mut_loop_loop t ls i -(** [loops::list_nth_mut_loop]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 78:0-88:1 *) let rec list_nth_mut_loop_loop_back (t : Type0) (ls : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) (decreases (list_nth_mut_loop_loop_decreases t ls i)) @@ -120,12 +133,14 @@ let rec list_nth_mut_loop_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop]: backward function 0 *) +(** [loops::list_nth_mut_loop]: backward function 0 + Source: 'src/loops.rs', lines 78:0-78:71 *) let list_nth_mut_loop_back (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = list_nth_mut_loop_loop_back t ls i ret -(** [loops::list_nth_shared_loop]: loop 0: forward function *) +(** [loops::list_nth_shared_loop]: loop 0: forward function + Source: 'src/loops.rs', lines 91:0-101:1 *) let rec list_nth_shared_loop_loop (t : Type0) (ls : list_t t) (i : u32) : Tot (result t) (decreases (list_nth_shared_loop_loop_decreases t ls i)) @@ -138,11 +153,13 @@ let rec list_nth_shared_loop_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_loop]: forward function *) +(** [loops::list_nth_shared_loop]: forward function + Source: 'src/loops.rs', lines 91:0-91:66 *) let list_nth_shared_loop (t : Type0) (ls : list_t t) (i : u32) : result t = list_nth_shared_loop_loop t ls i -(** [loops::get_elem_mut]: loop 0: forward function *) +(** [loops::get_elem_mut]: loop 0: forward function + Source: 'src/loops.rs', lines 103:0-117:1 *) let rec get_elem_mut_loop (x : usize) (ls : list_t usize) : Tot (result usize) (decreases (get_elem_mut_loop_decreases x ls)) @@ -152,7 +169,8 @@ let rec get_elem_mut_loop | List_Nil -> Fail Failure end -(** [loops::get_elem_mut]: forward function *) +(** [loops::get_elem_mut]: forward function + Source: 'src/loops.rs', lines 103:0-103:73 *) let get_elem_mut (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = let* l = @@ -160,7 +178,8 @@ let get_elem_mut (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in get_elem_mut_loop x l -(** [loops::get_elem_mut]: loop 0: backward function 0 *) +(** [loops::get_elem_mut]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 103:0-117:1 *) let rec get_elem_mut_loop_back (x : usize) (ls : list_t usize) (ret : usize) : Tot (result (list_t usize)) (decreases (get_elem_mut_loop_decreases x ls)) @@ -173,7 +192,8 @@ let rec get_elem_mut_loop_back | List_Nil -> Fail Failure end -(** [loops::get_elem_mut]: backward function 0 *) +(** [loops::get_elem_mut]: backward function 0 + Source: 'src/loops.rs', lines 103:0-103:73 *) let get_elem_mut_back (slots : alloc_vec_Vec (list_t usize)) (x : usize) (ret : usize) : result (alloc_vec_Vec (list_t usize)) @@ -185,7 +205,8 @@ let get_elem_mut_back alloc_vec_Vec_index_mut_back (list_t usize) usize (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 l0 -(** [loops::get_elem_shared]: loop 0: forward function *) +(** [loops::get_elem_shared]: loop 0: forward function + Source: 'src/loops.rs', lines 119:0-133:1 *) let rec get_elem_shared_loop (x : usize) (ls : list_t usize) : Tot (result usize) (decreases (get_elem_shared_loop_decreases x ls)) @@ -195,7 +216,8 @@ let rec get_elem_shared_loop | List_Nil -> Fail Failure end -(** [loops::get_elem_shared]: forward function *) +(** [loops::get_elem_shared]: forward function + Source: 'src/loops.rs', lines 119:0-119:68 *) let get_elem_shared (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = let* l = @@ -203,20 +225,24 @@ let get_elem_shared (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in get_elem_shared_loop x l -(** [loops::id_mut]: forward function *) +(** [loops::id_mut]: forward function + Source: 'src/loops.rs', lines 135:0-135:50 *) let id_mut (t : Type0) (ls : list_t t) : result (list_t t) = Return ls -(** [loops::id_mut]: backward function 0 *) +(** [loops::id_mut]: backward function 0 + Source: 'src/loops.rs', lines 135:0-135:50 *) let id_mut_back (t : Type0) (ls : list_t t) (ret : list_t t) : result (list_t t) = Return ret -(** [loops::id_shared]: forward function *) +(** [loops::id_shared]: forward function + Source: 'src/loops.rs', lines 139:0-139:45 *) let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = Return ls -(** [loops::list_nth_mut_loop_with_id]: loop 0: forward function *) +(** [loops::list_nth_mut_loop_with_id]: loop 0: forward function + Source: 'src/loops.rs', lines 144:0-155:1 *) let rec list_nth_mut_loop_with_id_loop (t : Type0) (i : u32) (ls : list_t t) : Tot (result t) (decreases (list_nth_mut_loop_with_id_loop_decreases t i ls)) @@ -229,12 +255,14 @@ let rec list_nth_mut_loop_with_id_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_with_id]: forward function *) +(** [loops::list_nth_mut_loop_with_id]: forward function + Source: 'src/loops.rs', lines 144:0-144:75 *) let list_nth_mut_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = let* ls0 = id_mut t ls in list_nth_mut_loop_with_id_loop t i ls0 -(** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 144:0-155:1 *) let rec list_nth_mut_loop_with_id_loop_back (t : Type0) (i : u32) (ls : list_t t) (ret : t) : Tot (result (list_t t)) @@ -251,14 +279,16 @@ let rec list_nth_mut_loop_with_id_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_with_id]: backward function 0 *) +(** [loops::list_nth_mut_loop_with_id]: backward function 0 + Source: 'src/loops.rs', lines 144:0-144:75 *) let list_nth_mut_loop_with_id_back (t : Type0) (ls : list_t t) (i : u32) (ret : t) : result (list_t t) = let* ls0 = id_mut t ls in let* l = list_nth_mut_loop_with_id_loop_back t i ls0 ret in id_mut_back t ls l -(** [loops::list_nth_shared_loop_with_id]: loop 0: forward function *) +(** [loops::list_nth_shared_loop_with_id]: loop 0: forward function + Source: 'src/loops.rs', lines 158:0-169:1 *) let rec list_nth_shared_loop_with_id_loop (t : Type0) (i : u32) (ls : list_t t) : Tot (result t) @@ -272,12 +302,14 @@ let rec list_nth_shared_loop_with_id_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_loop_with_id]: forward function *) +(** [loops::list_nth_shared_loop_with_id]: forward function + Source: 'src/loops.rs', lines 158:0-158:70 *) let list_nth_shared_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = let* ls0 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls0 -(** [loops::list_nth_mut_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_mut_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 174:0-195:1 *) let rec list_nth_mut_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -295,12 +327,14 @@ let rec list_nth_mut_loop_pair_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_pair]: forward function *) +(** [loops::list_nth_mut_loop_pair]: forward function + Source: 'src/loops.rs', lines 174:0-178:27 *) let list_nth_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_mut_loop_pair_loop t ls0 ls1 i -(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 174:0-195:1 *) let rec list_nth_mut_loop_pair_loop_back'a (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) @@ -321,14 +355,16 @@ let rec list_nth_mut_loop_pair_loop_back'a | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_pair]: backward function 0 *) +(** [loops::list_nth_mut_loop_pair]: backward function 0 + Source: 'src/loops.rs', lines 174:0-178:27 *) let list_nth_mut_loop_pair_back'a (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : result (list_t t) = list_nth_mut_loop_pair_loop_back'a t ls0 ls1 i ret -(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 *) +(** [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 + Source: 'src/loops.rs', lines 174:0-195:1 *) let rec list_nth_mut_loop_pair_loop_back'b (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) @@ -349,14 +385,16 @@ let rec list_nth_mut_loop_pair_loop_back'b | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_pair]: backward function 1 *) +(** [loops::list_nth_mut_loop_pair]: backward function 1 + Source: 'src/loops.rs', lines 174:0-178:27 *) let list_nth_mut_loop_pair_back'b (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : result (list_t t) = list_nth_mut_loop_pair_loop_back'b t ls0 ls1 i ret -(** [loops::list_nth_shared_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_shared_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 198:0-219:1 *) let rec list_nth_shared_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -374,12 +412,14 @@ let rec list_nth_shared_loop_pair_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_loop_pair]: forward function *) +(** [loops::list_nth_shared_loop_pair]: forward function + Source: 'src/loops.rs', lines 198:0-202:19 *) let list_nth_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_shared_loop_pair_loop t ls0 ls1 i -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 223:0-238:1 *) let rec list_nth_mut_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -398,12 +438,14 @@ let rec list_nth_mut_loop_pair_merge_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_pair_merge]: forward function *) +(** [loops::list_nth_mut_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 223:0-227:27 *) let list_nth_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_mut_loop_pair_merge_loop t ls0 ls1 i -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 223:0-238:1 *) let rec list_nth_mut_loop_pair_merge_loop_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : (t & t)) : Tot (result ((list_t t) & (list_t t))) @@ -425,14 +467,16 @@ let rec list_nth_mut_loop_pair_merge_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_loop_pair_merge]: backward function 0 *) +(** [loops::list_nth_mut_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 223:0-227:27 *) let list_nth_mut_loop_pair_merge_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : (t & t)) : result ((list_t t) & (list_t t)) = list_nth_mut_loop_pair_merge_loop_back t ls0 ls1 i ret -(** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 241:0-256:1 *) let rec list_nth_shared_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -452,12 +496,14 @@ let rec list_nth_shared_loop_pair_merge_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_loop_pair_merge]: forward function *) +(** [loops::list_nth_shared_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 241:0-245:19 *) let list_nth_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_shared_loop_pair_merge_loop t ls0 ls1 i -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 259:0-274:1 *) let rec list_nth_mut_shared_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -477,12 +523,14 @@ let rec list_nth_mut_shared_loop_pair_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_shared_loop_pair]: forward function *) +(** [loops::list_nth_mut_shared_loop_pair]: forward function + Source: 'src/loops.rs', lines 259:0-263:23 *) let list_nth_mut_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_mut_shared_loop_pair_loop t ls0 ls1 i -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 259:0-274:1 *) let rec list_nth_mut_shared_loop_pair_loop_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) @@ -503,14 +551,16 @@ let rec list_nth_mut_shared_loop_pair_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_shared_loop_pair]: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair]: backward function 0 + Source: 'src/loops.rs', lines 259:0-263:23 *) let list_nth_mut_shared_loop_pair_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : result (list_t t) = list_nth_mut_shared_loop_pair_loop_back t ls0 ls1 i ret -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 278:0-293:1 *) let rec list_nth_mut_shared_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -530,12 +580,14 @@ let rec list_nth_mut_shared_loop_pair_merge_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_shared_loop_pair_merge]: forward function *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 278:0-282:23 *) let list_nth_mut_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 278:0-293:1 *) let rec list_nth_mut_shared_loop_pair_merge_loop_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) @@ -557,14 +609,16 @@ let rec list_nth_mut_shared_loop_pair_merge_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 *) +(** [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 278:0-282:23 *) let list_nth_mut_shared_loop_pair_merge_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : result (list_t t) = list_nth_mut_shared_loop_pair_merge_loop_back t ls0 ls1 i ret -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function *) +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 297:0-312:1 *) let rec list_nth_shared_mut_loop_pair_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -584,12 +638,14 @@ let rec list_nth_shared_mut_loop_pair_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_mut_loop_pair]: forward function *) +(** [loops::list_nth_shared_mut_loop_pair]: forward function + Source: 'src/loops.rs', lines 297:0-301:23 *) let list_nth_shared_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_shared_mut_loop_pair_loop t ls0 ls1 i -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 *) +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 + Source: 'src/loops.rs', lines 297:0-312:1 *) let rec list_nth_shared_mut_loop_pair_loop_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) @@ -610,14 +666,16 @@ let rec list_nth_shared_mut_loop_pair_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_mut_loop_pair]: backward function 1 *) +(** [loops::list_nth_shared_mut_loop_pair]: backward function 1 + Source: 'src/loops.rs', lines 297:0-301:23 *) let list_nth_shared_mut_loop_pair_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : result (list_t t) = list_nth_shared_mut_loop_pair_loop_back t ls0 ls1 i ret -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 316:0-331:1 *) let rec list_nth_shared_mut_loop_pair_merge_loop (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : Tot (result (t & t)) @@ -637,12 +695,14 @@ let rec list_nth_shared_mut_loop_pair_merge_loop | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_mut_loop_pair_merge]: forward function *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 316:0-320:23 *) let list_nth_shared_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 316:0-331:1 *) let rec list_nth_shared_mut_loop_pair_merge_loop_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : Tot (result (list_t t)) @@ -664,7 +724,8 @@ let rec list_nth_shared_mut_loop_pair_merge_loop_back | List_Nil -> Fail Failure end -(** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 *) +(** [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 316:0-320:23 *) let list_nth_shared_mut_loop_pair_merge_back (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) (ret : t) : result (list_t t) diff --git a/tests/fstar/misc/Loops.Types.fst b/tests/fstar/misc/Loops.Types.fst index c622c548..8aa38290 100644 --- a/tests/fstar/misc/Loops.Types.fst +++ b/tests/fstar/misc/Loops.Types.fst @@ -5,7 +5,8 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [loops::List] *) +(** [loops::List] + Source: 'src/loops.rs', lines 60:0-60:16 *) type list_t (t : Type0) = | List_Cons : t -> list_t t -> list_t t | List_Nil : list_t t diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index a6269f60..2e14d67d 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -5,83 +5,103 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [no_nested_borrows::Pair] *) +(** [no_nested_borrows::Pair] + Source: 'src/no_nested_borrows.rs', lines 4:0-4:23 *) type pair_t (t1 t2 : Type0) = { x : t1; y : t2; } -(** [no_nested_borrows::List] *) +(** [no_nested_borrows::List] + Source: 'src/no_nested_borrows.rs', lines 9:0-9:16 *) type list_t (t : Type0) = | List_Cons : t -> list_t t -> list_t t | List_Nil : list_t t -(** [no_nested_borrows::One] *) +(** [no_nested_borrows::One] + Source: 'src/no_nested_borrows.rs', lines 20:0-20:16 *) type one_t (t1 : Type0) = | One_One : t1 -> one_t t1 -(** [no_nested_borrows::EmptyEnum] *) +(** [no_nested_borrows::EmptyEnum] + Source: 'src/no_nested_borrows.rs', lines 26:0-26:18 *) type emptyEnum_t = | EmptyEnum_Empty : emptyEnum_t -(** [no_nested_borrows::Enum] *) +(** [no_nested_borrows::Enum] + Source: 'src/no_nested_borrows.rs', lines 32:0-32:13 *) type enum_t = | Enum_Variant1 : enum_t | Enum_Variant2 : enum_t -(** [no_nested_borrows::EmptyStruct] *) +(** [no_nested_borrows::EmptyStruct] + Source: 'src/no_nested_borrows.rs', lines 39:0-39:22 *) type emptyStruct_t = unit -(** [no_nested_borrows::Sum] *) +(** [no_nested_borrows::Sum] + Source: 'src/no_nested_borrows.rs', lines 41:0-41:20 *) type sum_t (t1 t2 : Type0) = | Sum_Left : t1 -> sum_t t1 t2 | Sum_Right : t2 -> sum_t t1 t2 -(** [no_nested_borrows::neg_test]: forward function *) +(** [no_nested_borrows::neg_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 48:0-48:30 *) let neg_test (x : i32) : result i32 = i32_neg x -(** [no_nested_borrows::add_test]: forward function *) +(** [no_nested_borrows::add_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 54:0-54:38 *) let add_test (x : u32) (y : u32) : result u32 = u32_add x y -(** [no_nested_borrows::subs_test]: forward function *) +(** [no_nested_borrows::subs_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 60:0-60:39 *) let subs_test (x : u32) (y : u32) : result u32 = u32_sub x y -(** [no_nested_borrows::div_test]: forward function *) +(** [no_nested_borrows::div_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 66:0-66:38 *) let div_test (x : u32) (y : u32) : result u32 = u32_div x y -(** [no_nested_borrows::div_test1]: forward function *) +(** [no_nested_borrows::div_test1]: forward function + Source: 'src/no_nested_borrows.rs', lines 73:0-73:31 *) let div_test1 (x : u32) : result u32 = u32_div x 2 -(** [no_nested_borrows::rem_test]: forward function *) +(** [no_nested_borrows::rem_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 78:0-78:38 *) let rem_test (x : u32) (y : u32) : result u32 = u32_rem x y -(** [no_nested_borrows::mul_test]: forward function *) +(** [no_nested_borrows::mul_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 82:0-82:38 *) let mul_test (x : u32) (y : u32) : result u32 = u32_mul x y -(** [no_nested_borrows::CONST0] *) +(** [no_nested_borrows::CONST0] + Source: 'src/no_nested_borrows.rs', lines 91:0-91:23 *) let const0_body : result usize = usize_add 1 1 let const0_c : usize = eval_global const0_body -(** [no_nested_borrows::CONST1] *) +(** [no_nested_borrows::CONST1] + Source: 'src/no_nested_borrows.rs', lines 92:0-92:23 *) let const1_body : result usize = usize_mul 2 2 let const1_c : usize = eval_global const1_body -(** [no_nested_borrows::cast_test]: forward function *) +(** [no_nested_borrows::cast_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 94:0-94:31 *) let cast_test (x : u32) : result i32 = scalar_cast U32 I32 x -(** [no_nested_borrows::test2]: forward function *) +(** [no_nested_borrows::test2]: forward function + Source: 'src/no_nested_borrows.rs', lines 99:0-99:14 *) let test2 : result unit = let* _ = u32_add 23 44 in Return () (** Unit test for [no_nested_borrows::test2] *) let _ = assert_norm (test2 = Return ()) -(** [no_nested_borrows::get_max]: forward function *) +(** [no_nested_borrows::get_max]: forward function + Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 *) let get_max (x : u32) (y : u32) : result u32 = if x >= y then Return x else Return y -(** [no_nested_borrows::test3]: forward function *) +(** [no_nested_borrows::test3]: forward function + Source: 'src/no_nested_borrows.rs', lines 119:0-119:14 *) let test3 : result unit = let* x = get_max 4 3 in let* y = get_max 10 11 in @@ -91,21 +111,24 @@ let test3 : result unit = (** Unit test for [no_nested_borrows::test3] *) let _ = assert_norm (test3 = Return ()) -(** [no_nested_borrows::test_neg1]: forward function *) +(** [no_nested_borrows::test_neg1]: forward function + Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 *) let test_neg1 : result unit = let* y = i32_neg 3 in if not (y = -3) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_neg1] *) let _ = assert_norm (test_neg1 = Return ()) -(** [no_nested_borrows::refs_test1]: forward function *) +(** [no_nested_borrows::refs_test1]: forward function + Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 *) let refs_test1 : result unit = if not (1 = 1) then Fail Failure else Return () (** Unit test for [no_nested_borrows::refs_test1] *) let _ = assert_norm (refs_test1 = Return ()) -(** [no_nested_borrows::refs_test2]: forward function *) +(** [no_nested_borrows::refs_test2]: forward function + Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 *) let refs_test2 : result unit = if not (2 = 2) then Fail Failure @@ -120,14 +143,16 @@ let refs_test2 : result unit = (** Unit test for [no_nested_borrows::refs_test2] *) let _ = assert_norm (refs_test2 = Return ()) -(** [no_nested_borrows::test_list1]: forward function *) +(** [no_nested_borrows::test_list1]: forward function + Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 *) let test_list1 : result unit = Return () (** Unit test for [no_nested_borrows::test_list1] *) let _ = assert_norm (test_list1 = Return ()) -(** [no_nested_borrows::test_box1]: forward function *) +(** [no_nested_borrows::test_box1]: forward function + Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 *) let test_box1 : result unit = let b = 0 in let* b0 = alloc_boxed_Box_deref_mut_back i32 b 1 in @@ -137,33 +162,39 @@ let test_box1 : result unit = (** Unit test for [no_nested_borrows::test_box1] *) let _ = assert_norm (test_box1 = Return ()) -(** [no_nested_borrows::copy_int]: forward function *) +(** [no_nested_borrows::copy_int]: forward function + Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 *) let copy_int (x : i32) : result i32 = Return x -(** [no_nested_borrows::test_unreachable]: forward function *) +(** [no_nested_borrows::test_unreachable]: forward function + Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 *) let test_unreachable (b : bool) : result unit = if b then Fail Failure else Return () -(** [no_nested_borrows::test_panic]: forward function *) +(** [no_nested_borrows::test_panic]: forward function + Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 *) let test_panic (b : bool) : result unit = if b then Fail Failure else Return () -(** [no_nested_borrows::test_copy_int]: forward function *) +(** [no_nested_borrows::test_copy_int]: forward function + Source: 'src/no_nested_borrows.rs', lines 196:0-196:22 *) let test_copy_int : result unit = let* y = copy_int 0 in if not (0 = y) then Fail Failure else Return () (** Unit test for [no_nested_borrows::test_copy_int] *) let _ = assert_norm (test_copy_int = Return ()) -(** [no_nested_borrows::is_cons]: forward function *) +(** [no_nested_borrows::is_cons]: forward function + Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 *) let is_cons (t : Type0) (l : list_t t) : result bool = begin match l with | List_Cons x l0 -> Return true | List_Nil -> Return false end -(** [no_nested_borrows::test_is_cons]: forward function *) +(** [no_nested_borrows::test_is_cons]: forward function + Source: 'src/no_nested_borrows.rs', lines 210:0-210:21 *) let test_is_cons : result unit = let l = List_Nil in let* b = is_cons i32 (List_Cons 0 l) in @@ -172,14 +203,16 @@ let test_is_cons : result unit = (** Unit test for [no_nested_borrows::test_is_cons] *) let _ = assert_norm (test_is_cons = Return ()) -(** [no_nested_borrows::split_list]: forward function *) +(** [no_nested_borrows::split_list]: forward function + Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 *) let split_list (t : Type0) (l : list_t t) : result (t & (list_t t)) = begin match l with | List_Cons hd tl -> Return (hd, tl) | List_Nil -> Fail Failure end -(** [no_nested_borrows::test_split_list]: forward function *) +(** [no_nested_borrows::test_split_list]: forward function + Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 *) let test_split_list : result unit = let l = List_Nil in let* p = split_list i32 (List_Cons 0 l) in @@ -189,16 +222,19 @@ let test_split_list : result unit = (** Unit test for [no_nested_borrows::test_split_list] *) let _ = assert_norm (test_split_list = Return ()) -(** [no_nested_borrows::choose]: forward function *) +(** [no_nested_borrows::choose]: forward function + Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y -(** [no_nested_borrows::choose]: backward function 0 *) +(** [no_nested_borrows::choose]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) let choose_back (t : Type0) (b : bool) (x : t) (y : t) (ret : t) : result (t & t) = if b then Return (ret, y) else Return (x, ret) -(** [no_nested_borrows::choose_test]: forward function *) +(** [no_nested_borrows::choose_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 *) let choose_test : result unit = let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in @@ -213,28 +249,33 @@ let choose_test : result unit = (** Unit test for [no_nested_borrows::choose_test] *) let _ = assert_norm (choose_test = Return ()) -(** [no_nested_borrows::test_char]: forward function *) +(** [no_nested_borrows::test_char]: forward function + Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 *) let test_char : result char = Return 'a' -(** [no_nested_borrows::Tree] *) +(** [no_nested_borrows::Tree] + Source: 'src/no_nested_borrows.rs', lines 256:0-256:16 *) type tree_t (t : Type0) = | Tree_Leaf : t -> tree_t t | Tree_Node : t -> nodeElem_t t -> tree_t t -> tree_t t -(** [no_nested_borrows::NodeElem] *) +(** [no_nested_borrows::NodeElem] + Source: 'src/no_nested_borrows.rs', lines 261:0-261:20 *) and nodeElem_t (t : Type0) = | NodeElem_Cons : tree_t t -> nodeElem_t t -> nodeElem_t t | NodeElem_Nil : nodeElem_t t -(** [no_nested_borrows::list_length]: forward function *) +(** [no_nested_borrows::list_length]: forward function + Source: 'src/no_nested_borrows.rs', lines 296:0-296:48 *) let rec list_length (t : Type0) (l : list_t t) : result u32 = begin match l with | List_Cons x l1 -> let* i = list_length t l1 in u32_add 1 i | List_Nil -> Return 0 end -(** [no_nested_borrows::list_nth_shared]: forward function *) +(** [no_nested_borrows::list_nth_shared]: forward function + Source: 'src/no_nested_borrows.rs', lines 304:0-304:62 *) let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with | List_Cons x tl -> @@ -244,7 +285,8 @@ let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = | List_Nil -> Fail Failure end -(** [no_nested_borrows::list_nth_mut]: forward function *) +(** [no_nested_borrows::list_nth_mut]: forward function + Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with | List_Cons x tl -> @@ -252,7 +294,8 @@ let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = | List_Nil -> Fail Failure end -(** [no_nested_borrows::list_nth_mut]: backward function 0 *) +(** [no_nested_borrows::list_nth_mut]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with @@ -266,7 +309,8 @@ let rec list_nth_mut_back | List_Nil -> Fail Failure end -(** [no_nested_borrows::list_rev_aux]: forward function *) +(** [no_nested_borrows::list_rev_aux]: forward function + Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 *) let rec list_rev_aux (t : Type0) (li : list_t t) (lo : list_t t) : result (list_t t) = begin match li with @@ -275,11 +319,13 @@ let rec list_rev_aux end (** [no_nested_borrows::list_rev]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/no_nested_borrows.rs', lines 350:0-350:42 *) let list_rev (t : Type0) (l : list_t t) : result (list_t t) = let li = core_mem_replace (list_t t) l List_Nil in list_rev_aux t li List_Nil -(** [no_nested_borrows::test_list_functions]: forward function *) +(** [no_nested_borrows::test_list_functions]: forward function + Source: 'src/no_nested_borrows.rs', lines 355:0-355:28 *) let test_list_functions : result unit = let l = List_Nil in let l0 = List_Cons 2 l in @@ -315,75 +361,92 @@ let test_list_functions : result unit = (** Unit test for [no_nested_borrows::test_list_functions] *) let _ = assert_norm (test_list_functions = Return ()) -(** [no_nested_borrows::id_mut_pair1]: forward function *) +(** [no_nested_borrows::id_mut_pair1]: forward function + Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) let id_mut_pair1 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) -(** [no_nested_borrows::id_mut_pair1]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair1]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) let id_mut_pair1_back (t1 t2 : Type0) (x : t1) (y : t2) (ret : (t1 & t2)) : result (t1 & t2) = let (x0, x1) = ret in Return (x0, x1) -(** [no_nested_borrows::id_mut_pair2]: forward function *) +(** [no_nested_borrows::id_mut_pair2]: forward function + Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) let id_mut_pair2 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) -(** [no_nested_borrows::id_mut_pair2]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair2]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) let id_mut_pair2_back (t1 t2 : Type0) (p : (t1 & t2)) (ret : (t1 & t2)) : result (t1 & t2) = let (x, x0) = ret in Return (x, x0) -(** [no_nested_borrows::id_mut_pair3]: forward function *) +(** [no_nested_borrows::id_mut_pair3]: forward function + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) let id_mut_pair3 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) -(** [no_nested_borrows::id_mut_pair3]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair3]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) let id_mut_pair3_back'a (t1 t2 : Type0) (x : t1) (y : t2) (ret : t1) : result t1 = Return ret -(** [no_nested_borrows::id_mut_pair3]: backward function 1 *) +(** [no_nested_borrows::id_mut_pair3]: backward function 1 + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) let id_mut_pair3_back'b (t1 t2 : Type0) (x : t1) (y : t2) (ret : t2) : result t2 = Return ret -(** [no_nested_borrows::id_mut_pair4]: forward function *) +(** [no_nested_borrows::id_mut_pair4]: forward function + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) let id_mut_pair4 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) -(** [no_nested_borrows::id_mut_pair4]: backward function 0 *) +(** [no_nested_borrows::id_mut_pair4]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) let id_mut_pair4_back'a (t1 t2 : Type0) (p : (t1 & t2)) (ret : t1) : result t1 = Return ret -(** [no_nested_borrows::id_mut_pair4]: backward function 1 *) +(** [no_nested_borrows::id_mut_pair4]: backward function 1 + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) let id_mut_pair4_back'b (t1 t2 : Type0) (p : (t1 & t2)) (ret : t2) : result t2 = Return ret -(** [no_nested_borrows::StructWithTuple] *) +(** [no_nested_borrows::StructWithTuple] + Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 *) type structWithTuple_t (t1 t2 : Type0) = { p : (t1 & t2); } -(** [no_nested_borrows::new_tuple1]: forward function *) +(** [no_nested_borrows::new_tuple1]: forward function + Source: 'src/no_nested_borrows.rs', lines 394:0-394:48 *) let new_tuple1 : result (structWithTuple_t u32 u32) = Return { p = (1, 2) } -(** [no_nested_borrows::new_tuple2]: forward function *) +(** [no_nested_borrows::new_tuple2]: forward function + Source: 'src/no_nested_borrows.rs', lines 398:0-398:48 *) let new_tuple2 : result (structWithTuple_t i16 i16) = Return { p = (1, 2) } -(** [no_nested_borrows::new_tuple3]: forward function *) +(** [no_nested_borrows::new_tuple3]: forward function + Source: 'src/no_nested_borrows.rs', lines 402:0-402:48 *) let new_tuple3 : result (structWithTuple_t u64 i64) = Return { p = (1, 2) } -(** [no_nested_borrows::StructWithPair] *) +(** [no_nested_borrows::StructWithPair] + Source: 'src/no_nested_borrows.rs', lines 407:0-407:33 *) type structWithPair_t (t1 t2 : Type0) = { p : pair_t t1 t2; } -(** [no_nested_borrows::new_pair1]: forward function *) +(** [no_nested_borrows::new_pair1]: forward function + Source: 'src/no_nested_borrows.rs', lines 411:0-411:46 *) let new_pair1 : result (structWithPair_t u32 u32) = Return { p = { x = 1; y = 2 } } -(** [no_nested_borrows::test_constants]: forward function *) +(** [no_nested_borrows::test_constants]: forward function + Source: 'src/no_nested_borrows.rs', lines 419:0-419:23 *) let test_constants : result unit = let* swt = new_tuple1 in let (i, _) = swt.p in @@ -406,7 +469,8 @@ let test_constants : result unit = (** Unit test for [no_nested_borrows::test_constants] *) let _ = assert_norm (test_constants = Return ()) -(** [no_nested_borrows::test_weird_borrows1]: forward function *) +(** [no_nested_borrows::test_weird_borrows1]: forward function + Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 *) let test_weird_borrows1 : result unit = Return () @@ -414,24 +478,29 @@ let test_weird_borrows1 : result unit = let _ = assert_norm (test_weird_borrows1 = Return ()) (** [no_nested_borrows::test_mem_replace]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/no_nested_borrows.rs', lines 438:0-438:37 *) let test_mem_replace (px : u32) : result u32 = let y = core_mem_replace u32 px 1 in if not (y = 0) then Fail Failure else Return 2 -(** [no_nested_borrows::test_shared_borrow_bool1]: forward function *) +(** [no_nested_borrows::test_shared_borrow_bool1]: forward function + Source: 'src/no_nested_borrows.rs', lines 445:0-445:47 *) let test_shared_borrow_bool1 (b : bool) : result u32 = if b then Return 0 else Return 1 -(** [no_nested_borrows::test_shared_borrow_bool2]: forward function *) +(** [no_nested_borrows::test_shared_borrow_bool2]: forward function + Source: 'src/no_nested_borrows.rs', lines 458:0-458:40 *) let test_shared_borrow_bool2 : result u32 = Return 0 -(** [no_nested_borrows::test_shared_borrow_enum1]: forward function *) +(** [no_nested_borrows::test_shared_borrow_enum1]: forward function + Source: 'src/no_nested_borrows.rs', lines 473:0-473:52 *) let test_shared_borrow_enum1 (l : list_t u32) : result u32 = begin match l with | List_Cons i l0 -> Return 1 | List_Nil -> Return 0 end -(** [no_nested_borrows::test_shared_borrow_enum2]: forward function *) +(** [no_nested_borrows::test_shared_borrow_enum2]: forward function + Source: 'src/no_nested_borrows.rs', lines 485:0-485:40 *) let test_shared_borrow_enum2 : result u32 = Return 0 diff --git a/tests/fstar/misc/Paper.fst b/tests/fstar/misc/Paper.fst index bfb710dc..14bc59e8 100644 --- a/tests/fstar/misc/Paper.fst +++ b/tests/fstar/misc/Paper.fst @@ -6,27 +6,32 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [paper::ref_incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/paper.rs', lines 4:0-4:28 *) let ref_incr (x : i32) : result i32 = i32_add x 1 -(** [paper::test_incr]: forward function *) +(** [paper::test_incr]: forward function + Source: 'src/paper.rs', lines 8:0-8:18 *) let test_incr : result unit = let* x = ref_incr 0 in if not (x = 1) then Fail Failure else Return () (** Unit test for [paper::test_incr] *) let _ = assert_norm (test_incr = Return ()) -(** [paper::choose]: forward function *) +(** [paper::choose]: forward function + Source: 'src/paper.rs', lines 15:0-15:70 *) let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y -(** [paper::choose]: backward function 0 *) +(** [paper::choose]: backward function 0 + Source: 'src/paper.rs', lines 15:0-15:70 *) let choose_back (t : Type0) (b : bool) (x : t) (y : t) (ret : t) : result (t & t) = if b then Return (ret, y) else Return (x, ret) -(** [paper::test_choose]: forward function *) +(** [paper::test_choose]: forward function + Source: 'src/paper.rs', lines 23:0-23:20 *) let test_choose : result unit = let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in @@ -41,12 +46,14 @@ let test_choose : result unit = (** Unit test for [paper::test_choose] *) let _ = assert_norm (test_choose = Return ()) -(** [paper::List] *) +(** [paper::List] + Source: 'src/paper.rs', lines 35:0-35:16 *) type list_t (t : Type0) = | List_Cons : t -> list_t t -> list_t t | List_Nil : list_t t -(** [paper::list_nth_mut]: forward function *) +(** [paper::list_nth_mut]: forward function + Source: 'src/paper.rs', lines 42:0-42:67 *) let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with | List_Cons x tl -> @@ -54,7 +61,8 @@ let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = | List_Nil -> Fail Failure end -(** [paper::list_nth_mut]: backward function 0 *) +(** [paper::list_nth_mut]: backward function 0 + Source: 'src/paper.rs', lines 42:0-42:67 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with @@ -68,14 +76,16 @@ let rec list_nth_mut_back | List_Nil -> Fail Failure end -(** [paper::sum]: forward function *) +(** [paper::sum]: forward function + Source: 'src/paper.rs', lines 57:0-57:32 *) let rec sum (l : list_t i32) : result i32 = begin match l with | List_Cons x tl -> let* i = sum tl in i32_add x i | List_Nil -> Return 0 end -(** [paper::test_nth]: forward function *) +(** [paper::test_nth]: forward function + Source: 'src/paper.rs', lines 68:0-68:17 *) let test_nth : result unit = let l = List_Nil in let l0 = List_Cons 3 l in @@ -89,7 +99,8 @@ let test_nth : result unit = (** Unit test for [paper::test_nth] *) let _ = assert_norm (test_nth = Return ()) -(** [paper::call_choose]: forward function *) +(** [paper::call_choose]: forward function + Source: 'src/paper.rs', lines 76:0-76:44 *) let call_choose (p : (u32 & u32)) : result u32 = let (px, py) = p in let* pz = choose u32 true px py in diff --git a/tests/fstar/misc/PoloniusList.fst b/tests/fstar/misc/PoloniusList.fst index 428c4210..188b22d8 100644 --- a/tests/fstar/misc/PoloniusList.fst +++ b/tests/fstar/misc/PoloniusList.fst @@ -5,12 +5,14 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [polonius_list::List] *) +(** [polonius_list::List] + Source: 'src/polonius_list.rs', lines 3:0-3:16 *) type list_t (t : Type0) = | List_Cons : t -> list_t t -> list_t t | List_Nil : list_t t -(** [polonius_list::get_list_at_x]: forward function *) +(** [polonius_list::get_list_at_x]: forward function + Source: 'src/polonius_list.rs', lines 13:0-13:76 *) let rec get_list_at_x (ls : list_t u32) (x : u32) : result (list_t u32) = begin match ls with | List_Cons hd tl -> @@ -18,7 +20,8 @@ let rec get_list_at_x (ls : list_t u32) (x : u32) : result (list_t u32) = | List_Nil -> Return List_Nil end -(** [polonius_list::get_list_at_x]: backward function 0 *) +(** [polonius_list::get_list_at_x]: backward function 0 + Source: 'src/polonius_list.rs', lines 13:0-13:76 *) let rec get_list_at_x_back (ls : list_t u32) (x : u32) (ret : list_t u32) : result (list_t u32) = begin match ls with diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 7edb27c1..669c1dff 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -5,135 +5,164 @@ open Primitives #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** Trait declaration: [traits::BoolTrait] *) +(** Trait declaration: [traits::BoolTrait] + Source: 'src/traits.rs', lines 1:0-1:19 *) noeq type boolTrait_t (self : Type0) = { get_bool : self -> result bool; } -(** [traits::{bool}::get_bool]: forward function *) +(** [traits::{bool}::get_bool]: forward function + Source: 'src/traits.rs', lines 12:4-12:30 *) let bool_get_bool (self : bool) : result bool = Return self -(** Trait implementation: [traits::{bool}] *) +(** Trait implementation: [traits::{bool}] + Source: 'src/traits.rs', lines 11:0-11:23 *) let traits_BoolTraitBoolInst : boolTrait_t bool = { get_bool = bool_get_bool; } -(** [traits::BoolTrait::ret_true]: forward function *) +(** [traits::BoolTrait::ret_true]: forward function + Source: 'src/traits.rs', lines 6:4-6:30 *) let boolTrait_ret_true (#self : Type0) (self_clause : boolTrait_t self) (self0 : self) : result bool = Return true -(** [traits::test_bool_trait_bool]: forward function *) +(** [traits::test_bool_trait_bool]: forward function + Source: 'src/traits.rs', lines 17:0-17:44 *) let test_bool_trait_bool (x : bool) : result bool = let* b = bool_get_bool x in if b then boolTrait_ret_true traits_BoolTraitBoolInst x else Return false -(** [traits::{core::option::Option#1}::get_bool]: forward function *) +(** [traits::{core::option::Option#1}::get_bool]: forward function + Source: 'src/traits.rs', lines 23:4-23:30 *) let option_get_bool (t : Type0) (self : option t) : result bool = begin match self with | None -> Return false | Some x -> Return true end -(** Trait implementation: [traits::{core::option::Option#1}] *) +(** Trait implementation: [traits::{core::option::Option#1}] + Source: 'src/traits.rs', lines 22:0-22:31 *) let traits_BoolTraitcoreoptionOptionTInst (t : Type0) : boolTrait_t (option t) = { get_bool = option_get_bool t; } -(** [traits::test_bool_trait_option]: forward function *) +(** [traits::test_bool_trait_option]: forward function + Source: 'src/traits.rs', lines 31:0-31:54 *) let test_bool_trait_option (t : Type0) (x : option t) : result bool = let* b = option_get_bool t x in if b then boolTrait_ret_true (traits_BoolTraitcoreoptionOptionTInst t) x else Return false -(** [traits::test_bool_trait]: forward function *) +(** [traits::test_bool_trait]: forward function + Source: 'src/traits.rs', lines 35:0-35:50 *) let test_bool_trait (t : Type0) (inst : boolTrait_t t) (x : t) : result bool = inst.get_bool x -(** Trait declaration: [traits::ToU64] *) +(** Trait declaration: [traits::ToU64] + Source: 'src/traits.rs', lines 39:0-39:15 *) noeq type toU64_t (self : Type0) = { to_u64 : self -> result u64; } -(** [traits::{u64#2}::to_u64]: forward function *) +(** [traits::{u64#2}::to_u64]: forward function + Source: 'src/traits.rs', lines 44:4-44:26 *) let u64_to_u64 (self : u64) : result u64 = Return self -(** Trait implementation: [traits::{u64#2}] *) +(** Trait implementation: [traits::{u64#2}] + Source: 'src/traits.rs', lines 43:0-43:18 *) let traits_ToU64U64Inst : toU64_t u64 = { to_u64 = u64_to_u64; } -(** [traits::{(A, A)#3}::to_u64]: forward function *) +(** [traits::{(A, A)#3}::to_u64]: forward function + Source: 'src/traits.rs', lines 50:4-50:26 *) let pair_to_u64 (a : Type0) (inst : toU64_t a) (self : (a & a)) : result u64 = let (x, x0) = self in let* i = inst.to_u64 x in let* i0 = inst.to_u64 x0 in u64_add i i0 -(** Trait implementation: [traits::{(A, A)#3}] *) +(** Trait implementation: [traits::{(A, A)#3}] + Source: 'src/traits.rs', lines 49:0-49:31 *) let traits_ToU64TupleAAInst (a : Type0) (inst : toU64_t a) : toU64_t (a & a) = { to_u64 = pair_to_u64 a inst; } -(** [traits::f]: forward function *) +(** [traits::f]: forward function + Source: 'src/traits.rs', lines 55:0-55:36 *) let f (t : Type0) (inst : toU64_t t) (x : (t & t)) : result u64 = pair_to_u64 t inst x -(** [traits::g]: forward function *) +(** [traits::g]: forward function + Source: 'src/traits.rs', lines 59:0-61:18 *) let g (t : Type0) (inst : toU64_t (t & t)) (x : (t & t)) : result u64 = inst.to_u64 x -(** [traits::h0]: forward function *) +(** [traits::h0]: forward function + Source: 'src/traits.rs', lines 66:0-66:24 *) let h0 (x : u64) : result u64 = u64_to_u64 x -(** [traits::Wrapper] *) +(** [traits::Wrapper] + Source: 'src/traits.rs', lines 70:0-70:21 *) type wrapper_t (t : Type0) = { x : t; } -(** [traits::{traits::Wrapper#4}::to_u64]: forward function *) +(** [traits::{traits::Wrapper#4}::to_u64]: forward function + Source: 'src/traits.rs', lines 75:4-75:26 *) let wrapper_to_u64 (t : Type0) (inst : toU64_t t) (self : wrapper_t t) : result u64 = inst.to_u64 self.x -(** Trait implementation: [traits::{traits::Wrapper#4}] *) +(** Trait implementation: [traits::{traits::Wrapper#4}] + Source: 'src/traits.rs', lines 74:0-74:35 *) let traits_ToU64traitsWrapperTInst (t : Type0) (inst : toU64_t t) : toU64_t (wrapper_t t) = { to_u64 = wrapper_to_u64 t inst; } -(** [traits::h1]: forward function *) +(** [traits::h1]: forward function + Source: 'src/traits.rs', lines 80:0-80:33 *) let h1 (x : wrapper_t u64) : result u64 = wrapper_to_u64 u64 traits_ToU64U64Inst x -(** [traits::h2]: forward function *) +(** [traits::h2]: forward function + Source: 'src/traits.rs', lines 84:0-84:41 *) let h2 (t : Type0) (inst : toU64_t t) (x : wrapper_t t) : result u64 = wrapper_to_u64 t inst x -(** Trait declaration: [traits::ToType] *) +(** Trait declaration: [traits::ToType] + Source: 'src/traits.rs', lines 88:0-88:19 *) noeq type toType_t (self t : Type0) = { to_type : self -> result t; } -(** [traits::{u64#5}::to_type]: forward function *) +(** [traits::{u64#5}::to_type]: forward function + Source: 'src/traits.rs', lines 93:4-93:28 *) let u64_to_type (self : u64) : result bool = Return (self > 0) -(** Trait implementation: [traits::{u64#5}] *) +(** Trait implementation: [traits::{u64#5}] + Source: 'src/traits.rs', lines 92:0-92:25 *) let traits_ToTypeU64BoolInst : toType_t u64 bool = { to_type = u64_to_type; } -(** Trait declaration: [traits::OfType] *) +(** Trait declaration: [traits::OfType] + Source: 'src/traits.rs', lines 98:0-98:16 *) noeq type ofType_t (self : Type0) = { of_type : (t : Type0) -> (inst : toType_t t self) -> t -> result self; } -(** [traits::h3]: forward function *) +(** [traits::h3]: forward function + Source: 'src/traits.rs', lines 104:0-104:50 *) let h3 (t1 t2 : Type0) (inst : ofType_t t1) (inst0 : toType_t t2 t1) (y : t2) : result t1 = inst.of_type t2 inst0 y -(** Trait declaration: [traits::OfTypeBis] *) +(** Trait declaration: [traits::OfTypeBis] + Source: 'src/traits.rs', lines 109:0-109:36 *) noeq type ofTypeBis_t (self t : Type0) = { parent_clause_0 : toType_t t self; of_type : t -> result self; } -(** [traits::h4]: forward function *) +(** [traits::h4]: forward function + Source: 'src/traits.rs', lines 118:0-118:57 *) let h4 (t1 t2 : Type0) (inst : ofTypeBis_t t1 t2) (inst0 : toType_t t2 t1) (y : t2) : @@ -141,53 +170,64 @@ let h4 = inst.of_type y -(** [traits::TestType] *) +(** [traits::TestType] + Source: 'src/traits.rs', lines 122:0-122:22 *) type testType_t (t : Type0) = { _0 : t; } -(** [traits::{traits::TestType#6}::test::TestType1] *) +(** [traits::{traits::TestType#6}::test::TestType1] + Source: 'src/traits.rs', lines 127:8-127:24 *) type testType_test_TestType1_t = { _0 : u64; } -(** Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] *) +(** Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] + Source: 'src/traits.rs', lines 128:8-128:23 *) noeq type testType_test_TestTrait_t (self : Type0) = { test : self -> result bool; } -(** [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function *) +(** [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function + Source: 'src/traits.rs', lines 139:12-139:34 *) let testType_test_TestType1_test (self : testType_test_TestType1_t) : result bool = Return (self._0 > 1) -(** Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] *) +(** Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] + Source: 'src/traits.rs', lines 138:8-138:36 *) let traits_TestType_test_TestTraittraitstraitsTestTypeTtestTestType1Inst : testType_test_TestTrait_t testType_test_TestType1_t = { test = testType_test_TestType1_test; } -(** [traits::{traits::TestType#6}::test]: forward function *) +(** [traits::{traits::TestType#6}::test]: forward function + Source: 'src/traits.rs', lines 126:4-126:36 *) let testType_test (t : Type0) (inst : toU64_t t) (self : testType_t t) (x : t) : result bool = let* x0 = inst.to_u64 x in if x0 > 0 then testType_test_TestType1_test { _0 = 0 } else Return false -(** [traits::BoolWrapper] *) +(** [traits::BoolWrapper] + Source: 'src/traits.rs', lines 150:0-150:22 *) type boolWrapper_t = { _0 : bool; } -(** [traits::{traits::BoolWrapper#7}::to_type]: forward function *) +(** [traits::{traits::BoolWrapper#7}::to_type]: forward function + Source: 'src/traits.rs', lines 156:4-156:25 *) let boolWrapper_to_type (t : Type0) (inst : toType_t bool t) (self : boolWrapper_t) : result t = inst.to_type self._0 -(** Trait implementation: [traits::{traits::BoolWrapper#7}] *) +(** Trait implementation: [traits::{traits::BoolWrapper#7}] + Source: 'src/traits.rs', lines 152:0-152:33 *) let traits_ToTypetraitsBoolWrapperTInst (t : Type0) (inst : toType_t bool t) : toType_t boolWrapper_t t = { to_type = boolWrapper_to_type t inst; } -(** [traits::WithConstTy::LEN2] *) +(** [traits::WithConstTy::LEN2] + Source: 'src/traits.rs', lines 164:4-164:21 *) let with_const_ty_len2_body : result usize = Return 32 let with_const_ty_len2_c : usize = eval_global with_const_ty_len2_body -(** Trait declaration: [traits::WithConstTy] *) +(** Trait declaration: [traits::WithConstTy] + Source: 'src/traits.rs', lines 161:0-161:39 *) noeq type withConstTy_t (self : Type0) (len : usize) = { cLEN1 : usize; cLEN2 : usize; @@ -197,16 +237,19 @@ noeq type withConstTy_t (self : Type0) (len : usize) = { f : tW -> array u8 len -> result tW; } -(** [traits::{bool#8}::LEN1] *) +(** [traits::{bool#8}::LEN1] + Source: 'src/traits.rs', lines 175:4-175:21 *) let bool_len1_body : result usize = Return 12 let bool_len1_c : usize = eval_global bool_len1_body (** [traits::{bool#8}::f]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) *) + (there is a single backward function, and the forward function returns ()) + Source: 'src/traits.rs', lines 180:4-180:39 *) let bool_f (i : u64) (a : array u8 32) : result u64 = Return i -(** Trait implementation: [traits::{bool#8}] *) +(** Trait implementation: [traits::{bool#8}] + Source: 'src/traits.rs', lines 174:0-174:29 *) let traits_WithConstTyBool32Inst : withConstTy_t bool 32 = { cLEN1 = bool_len1_c; cLEN2 = with_const_ty_len2_c; @@ -216,89 +259,106 @@ let traits_WithConstTyBool32Inst : withConstTy_t bool 32 = { f = bool_f; } -(** [traits::use_with_const_ty1]: forward function *) +(** [traits::use_with_const_ty1]: forward function + Source: 'src/traits.rs', lines 183:0-183:75 *) let use_with_const_ty1 (h : Type0) (len : usize) (inst : withConstTy_t h len) : result usize = let i = inst.cLEN1 in Return i -(** [traits::use_with_const_ty2]: forward function *) +(** [traits::use_with_const_ty2]: forward function + Source: 'src/traits.rs', lines 187:0-187:73 *) let use_with_const_ty2 (h : Type0) (len : usize) (inst : withConstTy_t h len) (w : inst.tW) : result unit = Return () -(** [traits::use_with_const_ty3]: forward function *) +(** [traits::use_with_const_ty3]: forward function + Source: 'src/traits.rs', lines 189:0-189:80 *) let use_with_const_ty3 (h : Type0) (len : usize) (inst : withConstTy_t h len) (x : inst.tW) : result u64 = inst.tW_clause_0.to_u64 x -(** [traits::test_where1]: forward function *) +(** [traits::test_where1]: forward function + Source: 'src/traits.rs', lines 193:0-193:40 *) let test_where1 (t : Type0) (_x : t) : result unit = Return () -(** [traits::test_where2]: forward function *) +(** [traits::test_where2]: forward function + Source: 'src/traits.rs', lines 194:0-194:57 *) let test_where2 (t : Type0) (inst : withConstTy_t t 32) (_x : u32) : result unit = Return () -(** [alloc::string::String] *) +(** [alloc::string::String] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/alloc/src/string.rs', lines 365:0-365:17 *) assume type alloc_string_String_t : Type0 -(** Trait declaration: [traits::ParentTrait0] *) +(** Trait declaration: [traits::ParentTrait0] + Source: 'src/traits.rs', lines 200:0-200:22 *) noeq type parentTrait0_t (self : Type0) = { tW : Type0; get_name : self -> result alloc_string_String_t; get_w : self -> result tW; } -(** Trait declaration: [traits::ParentTrait1] *) +(** Trait declaration: [traits::ParentTrait1] + Source: 'src/traits.rs', lines 205:0-205:22 *) type parentTrait1_t (self : Type0) = unit -(** Trait declaration: [traits::ChildTrait] *) +(** Trait declaration: [traits::ChildTrait] + Source: 'src/traits.rs', lines 206:0-206:49 *) noeq type childTrait_t (self : Type0) = { parent_clause_0 : parentTrait0_t self; parent_clause_1 : parentTrait1_t self; } -(** [traits::test_child_trait1]: forward function *) +(** [traits::test_child_trait1]: forward function + Source: 'src/traits.rs', lines 209:0-209:56 *) let test_child_trait1 (t : Type0) (inst : childTrait_t t) (x : t) : result alloc_string_String_t = inst.parent_clause_0.get_name x -(** [traits::test_child_trait2]: forward function *) +(** [traits::test_child_trait2]: forward function + Source: 'src/traits.rs', lines 213:0-213:54 *) let test_child_trait2 (t : Type0) (inst : childTrait_t t) (x : t) : result inst.parent_clause_0.tW = inst.parent_clause_0.get_w x -(** [traits::order1]: forward function *) +(** [traits::order1]: forward function + Source: 'src/traits.rs', lines 219:0-219:59 *) let order1 (t u : Type0) (inst : parentTrait0_t t) (inst0 : parentTrait0_t u) : result unit = Return () -(** Trait declaration: [traits::ChildTrait1] *) +(** Trait declaration: [traits::ChildTrait1] + Source: 'src/traits.rs', lines 222:0-222:35 *) noeq type childTrait1_t (self : Type0) = { parent_clause_0 : parentTrait1_t self; } -(** Trait implementation: [traits::{usize#9}] *) +(** Trait implementation: [traits::{usize#9}] + Source: 'src/traits.rs', lines 224:0-224:27 *) let traits_ParentTrait1UsizeInst : parentTrait1_t usize = () -(** Trait implementation: [traits::{usize#10}] *) +(** Trait implementation: [traits::{usize#10}] + Source: 'src/traits.rs', lines 225:0-225:26 *) let traits_ChildTrait1UsizeInst : childTrait1_t usize = { parent_clause_0 = traits_ParentTrait1UsizeInst; } -(** Trait declaration: [traits::Iterator] *) +(** Trait declaration: [traits::Iterator] + Source: 'src/traits.rs', lines 229:0-229:18 *) noeq type iterator_t (self : Type0) = { tItem : Type0; } -(** Trait declaration: [traits::IntoIterator] *) +(** Trait declaration: [traits::IntoIterator] + Source: 'src/traits.rs', lines 233:0-233:22 *) noeq type intoIterator_t (self : Type0) = { tItem : Type0; tIntoIter : Type0; @@ -306,69 +366,82 @@ noeq type intoIterator_t (self : Type0) = { into_iter : self -> result tIntoIter; } -(** Trait declaration: [traits::FromResidual] *) +(** Trait declaration: [traits::FromResidual] + Source: 'src/traits.rs', lines 250:0-250:21 *) type fromResidual_t (self t : Type0) = unit -(** Trait declaration: [traits::Try] *) +(** Trait declaration: [traits::Try] + Source: 'src/traits.rs', lines 246:0-246:48 *) noeq type try_t (self : Type0) = { tResidual : Type0; parent_clause_0 : fromResidual_t self tResidual; } -(** Trait declaration: [traits::WithTarget] *) +(** Trait declaration: [traits::WithTarget] + Source: 'src/traits.rs', lines 252:0-252:20 *) noeq type withTarget_t (self : Type0) = { tTarget : Type0; } -(** Trait declaration: [traits::ParentTrait2] *) +(** Trait declaration: [traits::ParentTrait2] + Source: 'src/traits.rs', lines 256:0-256:22 *) noeq type parentTrait2_t (self : Type0) = { tU : Type0; tU_clause_0 : withTarget_t tU; } -(** Trait declaration: [traits::ChildTrait2] *) +(** Trait declaration: [traits::ChildTrait2] + Source: 'src/traits.rs', lines 260:0-260:35 *) noeq type childTrait2_t (self : Type0) = { parent_clause_0 : parentTrait2_t self; convert : parent_clause_0.tU -> result parent_clause_0.tU_clause_0.tTarget; } -(** Trait implementation: [traits::{u32#11}] *) +(** Trait implementation: [traits::{u32#11}] + Source: 'src/traits.rs', lines 264:0-264:23 *) let traits_WithTargetU32Inst : withTarget_t u32 = { tTarget = u32; } -(** Trait implementation: [traits::{u32#12}] *) +(** Trait implementation: [traits::{u32#12}] + Source: 'src/traits.rs', lines 268:0-268:25 *) let traits_ParentTrait2U32Inst : parentTrait2_t u32 = { tU = u32; tU_clause_0 = traits_WithTargetU32Inst; } -(** [traits::{u32#13}::convert]: forward function *) +(** [traits::{u32#13}::convert]: forward function + Source: 'src/traits.rs', lines 273:4-273:29 *) let u32_convert (x : u32) : result u32 = Return x -(** Trait implementation: [traits::{u32#13}] *) +(** Trait implementation: [traits::{u32#13}] + Source: 'src/traits.rs', lines 272:0-272:24 *) let traits_ChildTrait2U32Inst : childTrait2_t u32 = { parent_clause_0 = traits_ParentTrait2U32Inst; convert = u32_convert; } -(** Trait declaration: [traits::CFnOnce] *) +(** Trait declaration: [traits::CFnOnce] + Source: 'src/traits.rs', lines 286:0-286:23 *) noeq type cFnOnce_t (self args : Type0) = { tOutput : Type0; call_once : self -> args -> result tOutput; } -(** Trait declaration: [traits::CFnMut] *) +(** Trait declaration: [traits::CFnMut] + Source: 'src/traits.rs', lines 292:0-292:37 *) noeq type cFnMut_t (self args : Type0) = { parent_clause_0 : cFnOnce_t self args; call_mut : self -> args -> result parent_clause_0.tOutput; call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; } -(** Trait declaration: [traits::CFn] *) +(** Trait declaration: [traits::CFn] + Source: 'src/traits.rs', lines 296:0-296:33 *) noeq type cFn_t (self args : Type0) = { parent_clause_0 : cFnMut_t self args; call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; } -(** [traits::incr_u32]: forward function *) +(** [traits::incr_u32]: forward function + Source: 'src/traits.rs', lines 300:0-300:30 *) let incr_u32 (x : u32) : result u32 = u32_add x 1 diff --git a/tests/lean/Array.lean b/tests/lean/Array.lean index 5a4e09ab..4832f469 100644 --- a/tests/lean/Array.lean +++ b/tests/lean/Array.lean @@ -5,103 +5,122 @@ open Primitives namespace array -/- [array::AB] -/ +/- [array::AB] + Source: 'src/array.rs', lines 3:0-3:11 -/ inductive AB := | A : AB | B : AB /- [array::incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 8:0-8:24 -/ def incr (x : U32) : Result U32 := x + 1#u32 -/- [array::array_to_shared_slice_]: forward function -/ +/- [array::array_to_shared_slice_]: forward function + Source: 'src/array.rs', lines 16:0-16:53 -/ def array_to_shared_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := Array.to_slice T 32#usize s -/- [array::array_to_mut_slice_]: forward function -/ +/- [array::array_to_mut_slice_]: forward function + Source: 'src/array.rs', lines 21:0-21:58 -/ def array_to_mut_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := Array.to_slice T 32#usize s -/- [array::array_to_mut_slice_]: backward function 0 -/ +/- [array::array_to_mut_slice_]: backward function 0 + Source: 'src/array.rs', lines 21:0-21:58 -/ def array_to_mut_slice__back (T : Type) (s : Array T 32#usize) (ret0 : Slice T) : Result (Array T 32#usize) := Array.from_slice T 32#usize s ret0 -/- [array::array_len]: forward function -/ +/- [array::array_len]: forward function + Source: 'src/array.rs', lines 25:0-25:40 -/ def array_len (T : Type) (s : Array T 32#usize) : Result Usize := do let s0 ← Array.to_slice T 32#usize s let i := Slice.len T s0 Result.ret i -/- [array::shared_array_len]: forward function -/ +/- [array::shared_array_len]: forward function + Source: 'src/array.rs', lines 29:0-29:48 -/ def shared_array_len (T : Type) (s : Array T 32#usize) : Result Usize := do let s0 ← Array.to_slice T 32#usize s let i := Slice.len T s0 Result.ret i -/- [array::shared_slice_len]: forward function -/ +/- [array::shared_slice_len]: forward function + Source: 'src/array.rs', lines 33:0-33:44 -/ def shared_slice_len (T : Type) (s : Slice T) : Result Usize := let i := Slice.len T s Result.ret i -/- [array::index_array_shared]: forward function -/ +/- [array::index_array_shared]: forward function + Source: 'src/array.rs', lines 37:0-37:57 -/ def index_array_shared (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := Array.index_usize T 32#usize s i -/- [array::index_array_u32]: forward function -/ +/- [array::index_array_u32]: forward function + Source: 'src/array.rs', lines 44:0-44:53 -/ def index_array_u32 (s : Array U32 32#usize) (i : Usize) : Result U32 := Array.index_usize U32 32#usize s i -/- [array::index_array_copy]: forward function -/ +/- [array::index_array_copy]: forward function + Source: 'src/array.rs', lines 48:0-48:45 -/ def index_array_copy (x : Array U32 32#usize) : Result U32 := Array.index_usize U32 32#usize x 0#usize -/- [array::index_mut_array]: forward function -/ +/- [array::index_mut_array]: forward function + Source: 'src/array.rs', lines 52:0-52:62 -/ def index_mut_array (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := Array.index_usize T 32#usize s i -/- [array::index_mut_array]: backward function 0 -/ +/- [array::index_mut_array]: backward function 0 + Source: 'src/array.rs', lines 52:0-52:62 -/ def index_mut_array_back (T : Type) (s : Array T 32#usize) (i : Usize) (ret0 : T) : Result (Array T 32#usize) := Array.update_usize T 32#usize s i ret0 -/- [array::index_slice]: forward function -/ +/- [array::index_slice]: forward function + Source: 'src/array.rs', lines 56:0-56:46 -/ def index_slice (T : Type) (s : Slice T) (i : Usize) : Result T := Slice.index_usize T s i -/- [array::index_mut_slice]: forward function -/ +/- [array::index_mut_slice]: forward function + Source: 'src/array.rs', lines 60:0-60:58 -/ def index_mut_slice (T : Type) (s : Slice T) (i : Usize) : Result T := Slice.index_usize T s i -/- [array::index_mut_slice]: backward function 0 -/ +/- [array::index_mut_slice]: backward function 0 + Source: 'src/array.rs', lines 60:0-60:58 -/ def index_mut_slice_back (T : Type) (s : Slice T) (i : Usize) (ret0 : T) : Result (Slice T) := Slice.update_usize T s i ret0 -/- [array::slice_subslice_shared_]: forward function -/ +/- [array::slice_subslice_shared_]: forward function + Source: 'src/array.rs', lines 64:0-64:70 -/ def slice_subslice_shared_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := core.slice.index.Slice.index U32 (core.ops.range.Range Usize) (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x { start := y, end_ := z } -/- [array::slice_subslice_mut_]: forward function -/ +/- [array::slice_subslice_mut_]: forward function + Source: 'src/array.rs', lines 68:0-68:75 -/ def slice_subslice_mut_ (x : Slice U32) (y : Usize) (z : Usize) : Result (Slice U32) := core.slice.index.Slice.index_mut U32 (core.ops.range.Range Usize) (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x { start := y, end_ := z } -/- [array::slice_subslice_mut_]: backward function 0 -/ +/- [array::slice_subslice_mut_]: backward function 0 + Source: 'src/array.rs', lines 68:0-68:75 -/ def slice_subslice_mut__back (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : Result (Slice U32) @@ -110,20 +129,24 @@ def slice_subslice_mut__back (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x { start := y, end_ := z } ret0 -/- [array::array_to_slice_shared_]: forward function -/ +/- [array::array_to_slice_shared_]: forward function + Source: 'src/array.rs', lines 72:0-72:54 -/ def array_to_slice_shared_ (x : Array U32 32#usize) : Result (Slice U32) := Array.to_slice U32 32#usize x -/- [array::array_to_slice_mut_]: forward function -/ +/- [array::array_to_slice_mut_]: forward function + Source: 'src/array.rs', lines 76:0-76:59 -/ def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := Array.to_slice U32 32#usize x -/- [array::array_to_slice_mut_]: backward function 0 -/ +/- [array::array_to_slice_mut_]: backward function 0 + Source: 'src/array.rs', lines 76:0-76:59 -/ def array_to_slice_mut__back (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := Array.from_slice U32 32#usize x ret0 -/- [array::array_subslice_shared_]: forward function -/ +/- [array::array_subslice_shared_]: forward function + Source: 'src/array.rs', lines 80:0-80:74 -/ def array_subslice_shared_ (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize @@ -131,7 +154,8 @@ def array_subslice_shared_ (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } -/- [array::array_subslice_mut_]: forward function -/ +/- [array::array_subslice_mut_]: forward function + Source: 'src/array.rs', lines 84:0-84:79 -/ def array_subslice_mut_ (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index_mut U32 (core.ops.range.Range Usize) 32#usize @@ -139,7 +163,8 @@ def array_subslice_mut_ (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } -/- [array::array_subslice_mut_]: backward function 0 -/ +/- [array::array_subslice_mut_]: backward function 0 + Source: 'src/array.rs', lines 84:0-84:79 -/ def array_subslice_mut__back (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : Result (Array U32 32#usize) @@ -149,15 +174,18 @@ def array_subslice_mut__back (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } ret0 -/- [array::index_slice_0]: forward function -/ +/- [array::index_slice_0]: forward function + Source: 'src/array.rs', lines 88:0-88:38 -/ def index_slice_0 (T : Type) (s : Slice T) : Result T := Slice.index_usize T s 0#usize -/- [array::index_array_0]: forward function -/ +/- [array::index_array_0]: forward function + Source: 'src/array.rs', lines 92:0-92:42 -/ def index_array_0 (T : Type) (s : Array T 32#usize) : Result T := Array.index_usize T 32#usize s 0#usize -/- [array::index_index_array]: forward function -/ +/- [array::index_index_array]: forward function + Source: 'src/array.rs', lines 103:0-103:71 -/ def index_index_array (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : Result U32 @@ -166,7 +194,8 @@ def index_index_array let a ← Array.index_usize (Array U32 32#usize) 32#usize s i Array.index_usize U32 32#usize a j -/- [array::update_update_array]: forward function -/ +/- [array::update_update_array]: forward function + Source: 'src/array.rs', lines 114:0-114:70 -/ def update_update_array (s : Array (Array U32 32#usize) 32#usize) (i : Usize) (j : Usize) : Result Unit @@ -177,28 +206,34 @@ def update_update_array let _ ← Array.update_usize (Array U32 32#usize) 32#usize s i a0 Result.ret () -/- [array::array_local_deep_copy]: forward function -/ +/- [array::array_local_deep_copy]: forward function + Source: 'src/array.rs', lines 118:0-118:43 -/ def array_local_deep_copy (x : Array U32 32#usize) : Result Unit := Result.ret () -/- [array::take_array]: forward function -/ +/- [array::take_array]: forward function + Source: 'src/array.rs', lines 122:0-122:30 -/ def take_array (a : Array U32 2#usize) : Result Unit := Result.ret () -/- [array::take_array_borrow]: forward function -/ +/- [array::take_array_borrow]: forward function + Source: 'src/array.rs', lines 123:0-123:38 -/ def take_array_borrow (a : Array U32 2#usize) : Result Unit := Result.ret () -/- [array::take_slice]: forward function -/ +/- [array::take_slice]: forward function + Source: 'src/array.rs', lines 124:0-124:28 -/ def take_slice (s : Slice U32) : Result Unit := Result.ret () /- [array::take_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 125:0-125:36 -/ def take_mut_slice (s : Slice U32) : Result (Slice U32) := Result.ret s -/- [array::take_all]: forward function -/ +/- [array::take_all]: forward function + Source: 'src/array.rs', lines 127:0-127:17 -/ def take_all : Result Unit := do let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) @@ -213,29 +248,35 @@ def take_all : Result Unit := Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret () -/- [array::index_array]: forward function -/ +/- [array::index_array]: forward function + Source: 'src/array.rs', lines 141:0-141:38 -/ def index_array (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize -/- [array::index_array_borrow]: forward function -/ +/- [array::index_array_borrow]: forward function + Source: 'src/array.rs', lines 144:0-144:46 -/ def index_array_borrow (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize -/- [array::index_slice_u32_0]: forward function -/ +/- [array::index_slice_u32_0]: forward function + Source: 'src/array.rs', lines 148:0-148:42 -/ def index_slice_u32_0 (x : Slice U32) : Result U32 := Slice.index_usize U32 x 0#usize -/- [array::index_mut_slice_u32_0]: forward function -/ +/- [array::index_mut_slice_u32_0]: forward function + Source: 'src/array.rs', lines 152:0-152:50 -/ def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := Slice.index_usize U32 x 0#usize -/- [array::index_mut_slice_u32_0]: backward function 0 -/ +/- [array::index_mut_slice_u32_0]: backward function 0 + Source: 'src/array.rs', lines 152:0-152:50 -/ def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := do let _ ← Slice.index_usize U32 x 0#usize Result.ret x -/- [array::index_all]: forward function -/ +/- [array::index_all]: forward function + Source: 'src/array.rs', lines 156:0-156:25 -/ def index_all : Result U32 := do let i ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) @@ -256,24 +297,28 @@ def index_all : Result U32 := Array.from_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) s1 Result.ret i7 -/- [array::update_array]: forward function -/ +/- [array::update_array]: forward function + Source: 'src/array.rs', lines 170:0-170:36 -/ def update_array (x : Array U32 2#usize) : Result Unit := do let _ ← Array.update_usize U32 2#usize x 0#usize 1#u32 Result.ret () /- [array::update_array_mut_borrow]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 173:0-173:48 -/ def update_array_mut_borrow (x : Array U32 2#usize) : Result (Array U32 2#usize) := Array.update_usize U32 2#usize x 0#usize 1#u32 /- [array::update_mut_slice]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/array.rs', lines 176:0-176:38 -/ def update_mut_slice (x : Slice U32) : Result (Slice U32) := Slice.update_usize U32 x 0#usize 1#u32 -/- [array::update_all]: forward function -/ +/- [array::update_all]: forward function + Source: 'src/array.rs', lines 180:0-180:19 -/ def update_all : Result Unit := do let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) @@ -283,7 +328,8 @@ def update_all : Result Unit := let _ ← Array.from_slice U32 2#usize x s0 Result.ret () -/- [array::range_all]: forward function -/ +/- [array::range_all]: forward function + Source: 'src/array.rs', lines 191:0-191:18 -/ def range_all : Result Unit := do let s ← @@ -301,32 +347,38 @@ def range_all : Result Unit := { start := 1#usize, end_ := 3#usize } s0 Result.ret () -/- [array::deref_array_borrow]: forward function -/ +/- [array::deref_array_borrow]: forward function + Source: 'src/array.rs', lines 200:0-200:46 -/ def deref_array_borrow (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize -/- [array::deref_array_mut_borrow]: forward function -/ +/- [array::deref_array_mut_borrow]: forward function + Source: 'src/array.rs', lines 205:0-205:54 -/ def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize -/- [array::deref_array_mut_borrow]: backward function 0 -/ +/- [array::deref_array_mut_borrow]: backward function 0 + Source: 'src/array.rs', lines 205:0-205:54 -/ def deref_array_mut_borrow_back (x : Array U32 2#usize) : Result (Array U32 2#usize) := do let _ ← Array.index_usize U32 2#usize x 0#usize Result.ret x -/- [array::take_array_t]: forward function -/ +/- [array::take_array_t]: forward function + Source: 'src/array.rs', lines 213:0-213:31 -/ def take_array_t (a : Array AB 2#usize) : Result Unit := Result.ret () -/- [array::non_copyable_array]: forward function -/ +/- [array::non_copyable_array]: forward function + Source: 'src/array.rs', lines 215:0-215:27 -/ def non_copyable_array : Result Unit := do let _ ← take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) Result.ret () -/- [array::sum]: loop 0: forward function -/ +/- [array::sum]: loop 0: forward function + Source: 'src/array.rs', lines 228:0-236:1 -/ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := let i0 := Slice.len U32 s if i < i0 @@ -338,11 +390,13 @@ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := sum_loop s sum1 i2 else Result.ret sum0 -/- [array::sum]: forward function -/ +/- [array::sum]: forward function + Source: 'src/array.rs', lines 228:0-228:28 -/ def sum (s : Slice U32) : Result U32 := sum_loop s 0#u32 0#usize -/- [array::sum2]: loop 0: forward function -/ +/- [array::sum2]: loop 0: forward function + Source: 'src/array.rs', lines 238:0-247:1 -/ divergent def sum2_loop (s : Slice U32) (s2 : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := let i0 := Slice.len U32 s @@ -357,7 +411,8 @@ divergent def sum2_loop sum2_loop s s2 sum1 i4 else Result.ret sum0 -/- [array::sum2]: forward function -/ +/- [array::sum2]: forward function + Source: 'src/array.rs', lines 238:0-238:41 -/ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := let i := Slice.len U32 s let i0 := Slice.len U32 s2 @@ -365,7 +420,8 @@ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := then Result.fail Error.panic else sum2_loop s s2 0#u32 0#usize -/- [array::f0]: forward function -/ +/- [array::f0]: forward function + Source: 'src/array.rs', lines 249:0-249:11 -/ def f0 : Result Unit := do let s ← @@ -375,7 +431,8 @@ def f0 : Result Unit := Array.from_slice U32 2#usize (Array.make U32 2#usize [ 1#u32, 2#u32 ]) s0 Result.ret () -/- [array::f1]: forward function -/ +/- [array::f1]: forward function + Source: 'src/array.rs', lines 254:0-254:11 -/ def f1 : Result Unit := do let _ ← @@ -383,18 +440,21 @@ def f1 : Result Unit := 0#usize 1#u32 Result.ret () -/- [array::f2]: forward function -/ +/- [array::f2]: forward function + Source: 'src/array.rs', lines 259:0-259:17 -/ def f2 (i : U32) : Result Unit := Result.ret () -/- [array::f4]: forward function -/ +/- [array::f4]: forward function + Source: 'src/array.rs', lines 268:0-268:54 -/ def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize (core.ops.index.IndexSliceTIInst U32 (core.ops.range.Range Usize) (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x { start := y, end_ := z } -/- [array::f3]: forward function -/ +/- [array::f3]: forward function + Source: 'src/array.rs', lines 261:0-261:18 -/ def f3 : Result U32 := do let i ← @@ -407,15 +467,18 @@ def f3 : Result U32 := let s0 ← f4 b 16#usize 18#usize sum2 s s0 -/- [array::SZ] -/ +/- [array::SZ] + Source: 'src/array.rs', lines 272:0-272:19 -/ def sz_body : Result Usize := Result.ret 32#usize def sz_c : Usize := eval_global sz_body (by simp) -/- [array::f5]: forward function -/ +/- [array::f5]: forward function + Source: 'src/array.rs', lines 275:0-275:31 -/ def f5 (x : Array U32 32#usize) : Result U32 := Array.index_usize U32 32#usize x 0#usize -/- [array::ite]: forward function -/ +/- [array::ite]: forward function + Source: 'src/array.rs', lines 280:0-280:12 -/ def ite : Result Unit := do let s ← diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 441a3721..45548884 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -7,14 +7,16 @@ open Primitives namespace betree_main -/- [betree_main::betree::load_internal_node]: forward function -/ +/- [betree_main::betree::load_internal_node]: forward function + Source: 'src/betree.rs', lines 36:0-36:52 -/ def betree.load_internal_node (id : U64) (st : State) : Result (State × (betree.List (U64 × betree.Message))) := betree_utils.load_internal_node id st -/- [betree_main::betree::store_internal_node]: forward function -/ +/- [betree_main::betree::store_internal_node]: forward function + Source: 'src/betree.rs', lines 41:0-41:60 -/ def betree.store_internal_node (id : U64) (content : betree.List (U64 × betree.Message)) (st : State) : Result (State × Unit) @@ -23,12 +25,14 @@ def betree.store_internal_node let (st0, _) ← betree_utils.store_internal_node id content st Result.ret (st0, ()) -/- [betree_main::betree::load_leaf_node]: forward function -/ +/- [betree_main::betree::load_leaf_node]: forward function + Source: 'src/betree.rs', lines 46:0-46:44 -/ def betree.load_leaf_node (id : U64) (st : State) : Result (State × (betree.List (U64 × U64))) := betree_utils.load_leaf_node id st -/- [betree_main::betree::store_leaf_node]: forward function -/ +/- [betree_main::betree::store_leaf_node]: forward function + Source: 'src/betree.rs', lines 51:0-51:52 -/ def betree.store_leaf_node (id : U64) (content : betree.List (U64 × U64)) (st : State) : Result (State × Unit) @@ -37,34 +41,40 @@ def betree.store_leaf_node let (st0, _) ← betree_utils.store_leaf_node id content st Result.ret (st0, ()) -/- [betree_main::betree::fresh_node_id]: forward function -/ +/- [betree_main::betree::fresh_node_id]: forward function + Source: 'src/betree.rs', lines 55:0-55:48 -/ def betree.fresh_node_id (counter : U64) : Result U64 := do let _ ← counter + 1#u64 Result.ret counter -/- [betree_main::betree::fresh_node_id]: backward function 0 -/ +/- [betree_main::betree::fresh_node_id]: backward function 0 + Source: 'src/betree.rs', lines 55:0-55:48 -/ def betree.fresh_node_id_back (counter : U64) : Result U64 := counter + 1#u64 -/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function -/ +/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::new]: forward function + Source: 'src/betree.rs', lines 206:4-206:20 -/ def betree.NodeIdCounter.new : Result betree.NodeIdCounter := Result.ret { next_node_id := 0#u64 } -/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function -/ +/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: forward function + Source: 'src/betree.rs', lines 210:4-210:36 -/ def betree.NodeIdCounter.fresh_id (self : betree.NodeIdCounter) : Result U64 := do let _ ← self.next_node_id + 1#u64 Result.ret self.next_node_id -/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::NodeIdCounter}::fresh_id]: backward function 0 + Source: 'src/betree.rs', lines 210:4-210:36 -/ def betree.NodeIdCounter.fresh_id_back (self : betree.NodeIdCounter) : Result betree.NodeIdCounter := do let i ← self.next_node_id + 1#u64 Result.ret { next_node_id := i } -/- [betree_main::betree::upsert_update]: forward function -/ +/- [betree_main::betree::upsert_update]: forward function + Source: 'src/betree.rs', lines 234:0-234:70 -/ def betree.upsert_update (prev : Option U64) (st : betree.UpsertFunState) : Result U64 := match prev with @@ -85,7 +95,8 @@ def betree.upsert_update then prev0 - v else Result.ret 0#u64 -/- [betree_main::betree::{betree_main::betree::List#1}::len]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::len]: forward function + Source: 'src/betree.rs', lines 276:4-276:24 -/ divergent def betree.List.len (T : Type) (self : betree.List T) : Result U64 := match self with | betree.List.Cons t tl => do @@ -93,7 +104,8 @@ divergent def betree.List.len (T : Type) (self : betree.List T) : Result U64 := 1#u64 + i | betree.List.Nil => Result.ret 0#u64 -/- [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::split_at]: forward function + Source: 'src/betree.rs', lines 284:4-284:51 -/ divergent def betree.List.split_at (T : Type) (self : betree.List T) (n : U64) : Result ((betree.List T) × (betree.List T)) @@ -112,21 +124,24 @@ divergent def betree.List.split_at | betree.List.Nil => Result.fail Error.panic /- [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 299:4-299:34 -/ def betree.List.push_front (T : Type) (self : betree.List T) (x : T) : Result (betree.List T) := let tl := core.mem.replace (betree.List T) self betree.List.Nil let l := tl Result.ret (betree.List.Cons x l) -/- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: forward function + Source: 'src/betree.rs', lines 306:4-306:32 -/ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret x | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 + Source: 'src/betree.rs', lines 306:4-306:32 -/ def betree.List.pop_front_back (T : Type) (self : betree.List T) : Result (betree.List T) := let ls := core.mem.replace (betree.List T) self betree.List.Nil @@ -134,13 +149,15 @@ def betree.List.pop_front_back | betree.List.Cons x tl => Result.ret tl | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function + Source: 'src/betree.rs', lines 318:4-318:22 -/ def betree.List.hd (T : Type) (self : betree.List T) : Result T := match self with | betree.List.Cons hd l => Result.ret hd | betree.List.Nil => Result.fail Error.panic -/- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function + Source: 'src/betree.rs', lines 327:4-327:44 -/ def betree.ListTupleU64T.head_has_key (T : Type) (self : betree.List (U64 × T)) (key : U64) : Result Bool := match self with @@ -148,7 +165,8 @@ def betree.ListTupleU64T.head_has_key Result.ret (i = key) | betree.List.Nil => Result.ret false -/- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function -/ +/- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::partition_at_pivot]: forward function + Source: 'src/betree.rs', lines 339:4-339:73 -/ divergent def betree.ListTupleU64T.partition_at_pivot (T : Type) (self : betree.List (U64 × T)) (pivot : U64) : Result ((betree.List (U64 × T)) × (betree.List (U64 × T))) @@ -166,7 +184,8 @@ divergent def betree.ListTupleU64T.partition_at_pivot Result.ret (betree.List.Cons (i, t) l, ls1) | betree.List.Nil => Result.ret (betree.List.Nil, betree.List.Nil) -/- [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Leaf#3}::split]: forward function + Source: 'src/betree.rs', lines 359:4-364:17 -/ def betree.Leaf.split (self : betree.Leaf) (content : betree.List (U64 × U64)) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (st : State) : @@ -186,7 +205,8 @@ def betree.Leaf.split let n0 := betree.Node.Leaf { id := id1, size := params.split_size } Result.ret (st1, betree.Internal.mk self.id pivot n n0) -/- [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 -/ +/- [betree_main::betree::{betree_main::betree::Leaf#3}::split]: backward function 2 + Source: 'src/betree.rs', lines 359:4-364:17 -/ def betree.Leaf.split_back (self : betree.Leaf) (content : betree.List (U64 × U64)) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (st : State) : @@ -203,7 +223,8 @@ def betree.Leaf.split_back let _ ← betree.store_leaf_node id1 content1 st0 betree.NodeIdCounter.fresh_id_back node_id_cnt0 -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: forward function + Source: 'src/betree.rs', lines 789:4-792:34 -/ divergent def betree.Node.lookup_first_message_for_key (key : U64) (msgs : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) @@ -216,7 +237,8 @@ divergent def betree.Node.lookup_first_message_for_key else betree.Node.lookup_first_message_for_key key next_msgs | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_for_key]: backward function 0 + Source: 'src/betree.rs', lines 789:4-792:34 -/ divergent def betree.Node.lookup_first_message_for_key_back (key : U64) (msgs : betree.List (U64 × betree.Message)) (ret0 : betree.List (U64 × betree.Message)) : @@ -234,7 +256,8 @@ divergent def betree.Node.lookup_first_message_for_key_back Result.ret (betree.List.Cons (i, m) next_msgs0) | betree.List.Nil => Result.ret ret0 -/- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function + Source: 'src/betree.rs', lines 819:4-819:90 -/ divergent def betree.Node.apply_upserts (msgs : betree.List (U64 × betree.Message)) (prev : Option U64) (key : U64) (st : State) : @@ -264,7 +287,8 @@ divergent def betree.Node.apply_upserts betree.Message.Insert v) Result.ret (st0, v) -/- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: backward function 0 + Source: 'src/betree.rs', lines 819:4-819:90 -/ divergent def betree.Node.apply_upserts_back (msgs : betree.List (U64 × betree.Message)) (prev : Option U64) (key : U64) (st : State) : @@ -292,7 +316,8 @@ divergent def betree.Node.apply_upserts_back betree.List.push_front (U64 × betree.Message) msgs (key, betree.Message.Insert v) -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 -/ divergent def betree.Node.lookup_in_bindings (key : U64) (bindings : betree.List (U64 × U64)) : Result (Option U64) := match bindings with @@ -306,7 +331,8 @@ divergent def betree.Node.lookup_in_bindings else betree.Node.lookup_in_bindings key tl | betree.List.Nil => Result.ret none -/- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function + Source: 'src/betree.rs', lines 395:4-395:63 -/ mutual divergent def betree.Internal.lookup_in_children (self : betree.Internal) (key : U64) (st : State) : Result (State × (Option U64)) @@ -316,7 +342,8 @@ mutual divergent def betree.Internal.lookup_in_children then betree.Node.lookup n key st else betree.Node.lookup n0 key st -/- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: backward function 0 + Source: 'src/betree.rs', lines 395:4-395:63 -/ divergent def betree.Internal.lookup_in_children_back (self : betree.Internal) (key : U64) (st : State) : Result betree.Internal := let ⟨ i, i0, n, n0 ⟩ := self @@ -330,7 +357,8 @@ divergent def betree.Internal.lookup_in_children_back let n1 ← betree.Node.lookup_back n0 key st Result.ret (betree.Internal.mk i i0 n n1) -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup]: forward function + Source: 'src/betree.rs', lines 709:4-709:58 -/ divergent def betree.Node.lookup (self : betree.Node) (key : U64) (st : State) : Result (State × (Option U64)) @@ -402,7 +430,8 @@ divergent def betree.Node.lookup let o ← betree.Node.lookup_in_bindings key bindings Result.ret (st0, o) -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 709:4-709:58 -/ divergent def betree.Node.lookup_back (self : betree.Node) (key : U64) (st : State) : Result betree.Node := match self with @@ -476,7 +505,8 @@ divergent def betree.Node.lookup_back end /- [betree_main::betree::{betree_main::betree::Node#5}::filter_messages_for_key]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 674:4-674:77 -/ divergent def betree.Node.filter_messages_for_key (key : U64) (msgs : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) @@ -494,7 +524,8 @@ divergent def betree.Node.filter_messages_for_key else Result.ret (betree.List.Cons (k, m) l) | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: forward function + Source: 'src/betree.rs', lines 689:4-692:34 -/ divergent def betree.Node.lookup_first_message_after_key (key : U64) (msgs : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) @@ -507,7 +538,8 @@ divergent def betree.Node.lookup_first_message_after_key else Result.ret (betree.List.Cons (k, m) next_msgs) | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_first_message_after_key]: backward function 0 + Source: 'src/betree.rs', lines 689:4-692:34 -/ divergent def betree.Node.lookup_first_message_after_key_back (key : U64) (msgs : betree.List (U64 × betree.Message)) (ret0 : betree.List (U64 × betree.Message)) : @@ -526,7 +558,8 @@ divergent def betree.Node.lookup_first_message_after_key_back | betree.List.Nil => Result.ret ret0 /- [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 521:4-521:89 -/ def betree.Node.apply_to_internal (msgs : betree.List (U64 × betree.Message)) (key : U64) (new_msg : betree.Message) : @@ -592,7 +625,8 @@ def betree.Node.apply_to_internal betree.Node.lookup_first_message_for_key_back key msgs msgs1 /- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_internal]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 502:4-505:5 -/ divergent def betree.Node.apply_messages_to_internal (msgs : betree.List (U64 × betree.Message)) (new_msgs : betree.List (U64 × betree.Message)) : @@ -606,7 +640,8 @@ divergent def betree.Node.apply_messages_to_internal betree.Node.apply_messages_to_internal msgs0 new_msgs_tl | betree.List.Nil => Result.ret msgs -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: forward function + Source: 'src/betree.rs', lines 653:4-656:32 -/ divergent def betree.Node.lookup_mut_in_bindings (key : U64) (bindings : betree.List (U64 × U64)) : Result (betree.List (U64 × U64)) @@ -619,7 +654,8 @@ divergent def betree.Node.lookup_mut_in_bindings else betree.Node.lookup_mut_in_bindings key tl | betree.List.Nil => Result.ret betree.List.Nil -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_mut_in_bindings]: backward function 0 + Source: 'src/betree.rs', lines 653:4-656:32 -/ divergent def betree.Node.lookup_mut_in_bindings_back (key : U64) (bindings : betree.List (U64 × U64)) (ret0 : betree.List (U64 × U64)) : @@ -637,7 +673,8 @@ divergent def betree.Node.lookup_mut_in_bindings_back | betree.List.Nil => Result.ret ret0 /- [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 460:4-460:87 -/ def betree.Node.apply_to_leaf (bindings : betree.List (U64 × U64)) (key : U64) (new_msg : betree.Message) : @@ -686,7 +723,8 @@ def betree.Node.apply_to_leaf betree.Node.lookup_mut_in_bindings_back key bindings bindings1 /- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages_to_leaf]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/betree.rs', lines 444:4-447:5 -/ divergent def betree.Node.apply_messages_to_leaf (bindings : betree.List (U64 × U64)) (new_msgs : betree.List (U64 × betree.Message)) : @@ -700,7 +738,8 @@ divergent def betree.Node.apply_messages_to_leaf betree.Node.apply_messages_to_leaf bindings0 new_msgs_tl | betree.List.Nil => Result.ret bindings -/- [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::flush]: forward function + Source: 'src/betree.rs', lines 410:4-415:26 -/ mutual divergent def betree.Internal.flush (self : betree.Internal) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -738,7 +777,8 @@ mutual divergent def betree.Internal.flush betree.Node.apply_messages_back n0 params node_id_cnt msgs_right st Result.ret (st0, msgs_left) -/- [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Internal#4}::flush]: backward function 0 + Source: 'src/betree.rs', lines 410:4-415:26 -/ divergent def betree.Internal.flush_back (self : betree.Internal) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -772,7 +812,8 @@ divergent def betree.Internal.flush_back betree.Node.apply_messages_back n0 params node_id_cnt msgs_right st Result.ret (betree.Internal.mk i i0 n n1, node_id_cnt0) -/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: forward function + Source: 'src/betree.rs', lines 588:4-593:5 -/ divergent def betree.Node.apply_messages (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -820,7 +861,8 @@ divergent def betree.Node.apply_messages let (st1, _) ← betree.store_leaf_node node.id content0 st0 Result.ret (st1, ()) -/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply_messages]: backward function 0 + Source: 'src/betree.rs', lines 588:4-593:5 -/ divergent def betree.Node.apply_messages_back (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) @@ -874,7 +916,8 @@ divergent def betree.Node.apply_messages_back end -/- [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply]: forward function + Source: 'src/betree.rs', lines 576:4-582:5 -/ def betree.Node.apply (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (key : U64) (new_msg : betree.Message) @@ -891,7 +934,8 @@ def betree.Node.apply (key, new_msg) l) st Result.ret (st0, ()) -/- [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::Node#5}::apply]: backward function 0 + Source: 'src/betree.rs', lines 576:4-582:5 -/ def betree.Node.apply_back (self : betree.Node) (params : betree.Params) (node_id_cnt : betree.NodeIdCounter) (key : U64) (new_msg : betree.Message) @@ -902,7 +946,8 @@ def betree.Node.apply_back betree.Node.apply_messages_back self params node_id_cnt (betree.List.Cons (key, new_msg) l) st -/- [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::new]: forward function + Source: 'src/betree.rs', lines 849:4-849:60 -/ def betree.BeTree.new (min_flush_size : U64) (split_size : U64) (st : State) : Result (State × betree.BeTree) @@ -920,7 +965,8 @@ def betree.BeTree.new root := (betree.Node.Leaf { id := id, size := 0#u64 }) }) -/- [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: forward function + Source: 'src/betree.rs', lines 868:4-868:47 -/ def betree.BeTree.apply (self : betree.BeTree) (key : U64) (msg : betree.Message) (st : State) : Result (State × Unit) @@ -932,7 +978,8 @@ def betree.BeTree.apply betree.Node.apply_back self.root self.params self.node_id_cnt key msg st Result.ret (st0, ()) -/- [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::apply]: backward function 0 + Source: 'src/betree.rs', lines 868:4-868:47 -/ def betree.BeTree.apply_back (self : betree.BeTree) (key : U64) (msg : betree.Message) (st : State) : Result betree.BeTree @@ -942,7 +989,8 @@ def betree.BeTree.apply_back betree.Node.apply_back self.root self.params self.node_id_cnt key msg st Result.ret { self with node_id_cnt := nic, root := n } -/- [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: forward function + Source: 'src/betree.rs', lines 874:4-874:52 -/ def betree.BeTree.insert (self : betree.BeTree) (key : U64) (value : U64) (st : State) : Result (State × Unit) @@ -954,14 +1002,16 @@ def betree.BeTree.insert betree.BeTree.apply_back self key (betree.Message.Insert value) st Result.ret (st0, ()) -/- [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::insert]: backward function 0 + Source: 'src/betree.rs', lines 874:4-874:52 -/ def betree.BeTree.insert_back (self : betree.BeTree) (key : U64) (value : U64) (st : State) : Result betree.BeTree := betree.BeTree.apply_back self key (betree.Message.Insert value) st -/- [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: forward function + Source: 'src/betree.rs', lines 880:4-880:38 -/ def betree.BeTree.delete (self : betree.BeTree) (key : U64) (st : State) : Result (State × Unit) := do @@ -969,12 +1019,14 @@ def betree.BeTree.delete let _ ← betree.BeTree.apply_back self key betree.Message.Delete st Result.ret (st0, ()) -/- [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::delete]: backward function 0 + Source: 'src/betree.rs', lines 880:4-880:38 -/ def betree.BeTree.delete_back (self : betree.BeTree) (key : U64) (st : State) : Result betree.BeTree := betree.BeTree.apply_back self key betree.Message.Delete st -/- [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: forward function + Source: 'src/betree.rs', lines 886:4-886:59 -/ def betree.BeTree.upsert (self : betree.BeTree) (key : U64) (upd : betree.UpsertFunState) (st : State) : @@ -986,7 +1038,8 @@ def betree.BeTree.upsert let _ ← betree.BeTree.apply_back self key (betree.Message.Upsert upd) st Result.ret (st0, ()) -/- [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::upsert]: backward function 0 + Source: 'src/betree.rs', lines 886:4-886:59 -/ def betree.BeTree.upsert_back (self : betree.BeTree) (key : U64) (upd : betree.UpsertFunState) (st : State) : @@ -994,21 +1047,24 @@ def betree.BeTree.upsert_back := betree.BeTree.apply_back self key (betree.Message.Upsert upd) st -/- [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: forward function + Source: 'src/betree.rs', lines 895:4-895:62 -/ def betree.BeTree.lookup (self : betree.BeTree) (key : U64) (st : State) : Result (State × (Option U64)) := betree.Node.lookup self.root key st -/- [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 -/ +/- [betree_main::betree::{betree_main::betree::BeTree#6}::lookup]: backward function 0 + Source: 'src/betree.rs', lines 895:4-895:62 -/ def betree.BeTree.lookup_back (self : betree.BeTree) (key : U64) (st : State) : Result betree.BeTree := do let n ← betree.Node.lookup_back self.root key st Result.ret { self with root := n } -/- [betree_main::main]: forward function -/ +/- [betree_main::main]: forward function + Source: 'src/betree_main.rs', lines 5:0-5:9 -/ def main : Result Unit := Result.ret () diff --git a/tests/lean/BetreeMain/FunsExternal_Template.lean b/tests/lean/BetreeMain/FunsExternal_Template.lean index 1dc3af0e..95f88873 100644 --- a/tests/lean/BetreeMain/FunsExternal_Template.lean +++ b/tests/lean/BetreeMain/FunsExternal_Template.lean @@ -6,25 +6,30 @@ import BetreeMain.Types open Primitives open betree_main -/- [betree_main::betree_utils::load_internal_node]: forward function -/ +/- [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 -/ axiom betree_utils.load_internal_node : U64 → State → Result (State × (betree.List (U64 × betree.Message))) -/- [betree_main::betree_utils::store_internal_node]: forward function -/ +/- [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 -/ axiom betree_utils.store_internal_node : U64 → betree.List (U64 × betree.Message) → State → Result (State × Unit) -/- [betree_main::betree_utils::load_leaf_node]: forward function -/ +/- [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 -/ axiom betree_utils.load_leaf_node : U64 → State → Result (State × (betree.List (U64 × U64))) -/- [betree_main::betree_utils::store_leaf_node]: forward function -/ +/- [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 -/ axiom betree_utils.store_leaf_node : U64 → betree.List (U64 × U64) → State → Result (State × Unit) -/- [core::option::{core::option::Option}::unwrap]: forward function -/ +/- [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 -/ axiom core.option.Option.unwrap (T : Type) : Option T → State → Result (State × T) diff --git a/tests/lean/BetreeMain/Types.lean b/tests/lean/BetreeMain/Types.lean index 2f5de6a0..6e528437 100644 --- a/tests/lean/BetreeMain/Types.lean +++ b/tests/lean/BetreeMain/Types.lean @@ -5,50 +5,59 @@ open Primitives namespace betree_main -/- [betree_main::betree::List] -/ +/- [betree_main::betree::List] + Source: 'src/betree.rs', lines 17:0-17:23 -/ inductive betree.List (T : Type) := | Cons : T → betree.List T → betree.List T | Nil : betree.List T -/- [betree_main::betree::UpsertFunState] -/ +/- [betree_main::betree::UpsertFunState] + Source: 'src/betree.rs', lines 63:0-63:23 -/ inductive betree.UpsertFunState := | Add : U64 → betree.UpsertFunState | Sub : U64 → betree.UpsertFunState -/- [betree_main::betree::Message] -/ +/- [betree_main::betree::Message] + Source: 'src/betree.rs', lines 69:0-69:23 -/ inductive betree.Message := | Insert : U64 → betree.Message | Delete : betree.Message | Upsert : betree.UpsertFunState → betree.Message -/- [betree_main::betree::Leaf] -/ +/- [betree_main::betree::Leaf] + Source: 'src/betree.rs', lines 167:0-167:11 -/ structure betree.Leaf where id : U64 size : U64 mutual -/- [betree_main::betree::Internal] -/ +/- [betree_main::betree::Internal] + Source: 'src/betree.rs', lines 156:0-156:15 -/ inductive betree.Internal := | mk : U64 → U64 → betree.Node → betree.Node → betree.Internal -/- [betree_main::betree::Node] -/ +/- [betree_main::betree::Node] + Source: 'src/betree.rs', lines 179:0-179:9 -/ inductive betree.Node := | Internal : betree.Internal → betree.Node | Leaf : betree.Leaf → betree.Node end -/- [betree_main::betree::Params] -/ +/- [betree_main::betree::Params] + Source: 'src/betree.rs', lines 187:0-187:13 -/ structure betree.Params where min_flush_size : U64 split_size : U64 -/- [betree_main::betree::NodeIdCounter] -/ +/- [betree_main::betree::NodeIdCounter] + Source: 'src/betree.rs', lines 201:0-201:20 -/ structure betree.NodeIdCounter where next_node_id : U64 -/- [betree_main::betree::BeTree] -/ +/- [betree_main::betree::BeTree] + Source: 'src/betree.rs', lines 218:0-218:17 -/ structure betree.BeTree where params : betree.Params node_id_cnt : betree.NodeIdCounter diff --git a/tests/lean/Constants.lean b/tests/lean/Constants.lean index 62e45d76..80864427 100644 --- a/tests/lean/Constants.lean +++ b/tests/lean/Constants.lean @@ -5,119 +5,147 @@ open Primitives namespace constants -/- [constants::X0] -/ +/- [constants::X0] + Source: 'src/constants.rs', lines 5:0-5:17 -/ def x0_body : Result U32 := Result.ret 0#u32 def x0_c : U32 := eval_global x0_body (by simp) -/- [constants::X1] -/ +/- [constants::X1] + Source: 'src/constants.rs', lines 7:0-7:17 -/ def x1_body : Result U32 := Result.ret core_u32_max def x1_c : U32 := eval_global x1_body (by simp) -/- [constants::X2] -/ +/- [constants::X2] + Source: 'src/constants.rs', lines 10:0-10:17 -/ def x2_body : Result U32 := Result.ret 3#u32 def x2_c : U32 := eval_global x2_body (by simp) -/- [constants::incr]: forward function -/ +/- [constants::incr]: forward function + Source: 'src/constants.rs', lines 17:0-17:32 -/ def incr (n : U32) : Result U32 := n + 1#u32 -/- [constants::X3] -/ +/- [constants::X3] + Source: 'src/constants.rs', lines 15:0-15:17 -/ def x3_body : Result U32 := incr 32#u32 def x3_c : U32 := eval_global x3_body (by simp) -/- [constants::mk_pair0]: forward function -/ +/- [constants::mk_pair0]: forward function + Source: 'src/constants.rs', lines 23:0-23:51 -/ def mk_pair0 (x : U32) (y : U32) : Result (U32 × U32) := Result.ret (x, y) -/- [constants::Pair] -/ +/- [constants::Pair] + Source: 'src/constants.rs', lines 36:0-36:23 -/ structure Pair (T1 T2 : Type) where x : T1 y : T2 -/- [constants::mk_pair1]: forward function -/ +/- [constants::mk_pair1]: forward function + Source: 'src/constants.rs', lines 27:0-27:55 -/ def mk_pair1 (x : U32) (y : U32) : Result (Pair U32 U32) := Result.ret { x := x, y := y } -/- [constants::P0] -/ +/- [constants::P0] + Source: 'src/constants.rs', lines 31:0-31:24 -/ def p0_body : Result (U32 × U32) := mk_pair0 0#u32 1#u32 def p0_c : (U32 × U32) := eval_global p0_body (by simp) -/- [constants::P1] -/ +/- [constants::P1] + Source: 'src/constants.rs', lines 32:0-32:28 -/ def p1_body : Result (Pair U32 U32) := mk_pair1 0#u32 1#u32 def p1_c : Pair U32 U32 := eval_global p1_body (by simp) -/- [constants::P2] -/ +/- [constants::P2] + Source: 'src/constants.rs', lines 33:0-33:24 -/ def p2_body : Result (U32 × U32) := Result.ret (0#u32, 1#u32) def p2_c : (U32 × U32) := eval_global p2_body (by simp) -/- [constants::P3] -/ +/- [constants::P3] + Source: 'src/constants.rs', lines 34:0-34:28 -/ def p3_body : Result (Pair U32 U32) := Result.ret { x := 0#u32, y := 1#u32 } def p3_c : Pair U32 U32 := eval_global p3_body (by simp) -/- [constants::Wrap] -/ +/- [constants::Wrap] + Source: 'src/constants.rs', lines 49:0-49:18 -/ structure Wrap (T : Type) where value : T -/- [constants::{constants::Wrap}::new]: forward function -/ +/- [constants::{constants::Wrap}::new]: forward function + Source: 'src/constants.rs', lines 54:4-54:41 -/ def Wrap.new (T : Type) (value : T) : Result (Wrap T) := Result.ret { value := value } -/- [constants::Y] -/ +/- [constants::Y] + Source: 'src/constants.rs', lines 41:0-41:22 -/ def y_body : Result (Wrap I32) := Wrap.new I32 2#i32 def y_c : Wrap I32 := eval_global y_body (by simp) -/- [constants::unwrap_y]: forward function -/ +/- [constants::unwrap_y]: forward function + Source: 'src/constants.rs', lines 43:0-43:30 -/ def unwrap_y : Result I32 := Result.ret y_c.value -/- [constants::YVAL] -/ +/- [constants::YVAL] + Source: 'src/constants.rs', lines 47:0-47:19 -/ def yval_body : Result I32 := unwrap_y def yval_c : I32 := eval_global yval_body (by simp) -/- [constants::get_z1::Z1] -/ +/- [constants::get_z1::Z1] + Source: 'src/constants.rs', lines 62:4-62:17 -/ def get_z1_z1_body : Result I32 := Result.ret 3#i32 def get_z1_z1_c : I32 := eval_global get_z1_z1_body (by simp) -/- [constants::get_z1]: forward function -/ +/- [constants::get_z1]: forward function + Source: 'src/constants.rs', lines 61:0-61:28 -/ def get_z1 : Result I32 := Result.ret get_z1_z1_c -/- [constants::add]: forward function -/ +/- [constants::add]: forward function + Source: 'src/constants.rs', lines 66:0-66:39 -/ def add (a : I32) (b : I32) : Result I32 := a + b -/- [constants::Q1] -/ +/- [constants::Q1] + Source: 'src/constants.rs', lines 74:0-74:17 -/ def q1_body : Result I32 := Result.ret 5#i32 def q1_c : I32 := eval_global q1_body (by simp) -/- [constants::Q2] -/ +/- [constants::Q2] + Source: 'src/constants.rs', lines 75:0-75:17 -/ def q2_body : Result I32 := Result.ret q1_c def q2_c : I32 := eval_global q2_body (by simp) -/- [constants::Q3] -/ +/- [constants::Q3] + Source: 'src/constants.rs', lines 76:0-76:17 -/ def q3_body : Result I32 := add q2_c 3#i32 def q3_c : I32 := eval_global q3_body (by simp) -/- [constants::get_z2]: forward function -/ +/- [constants::get_z2]: forward function + Source: 'src/constants.rs', lines 70:0-70:28 -/ def get_z2 : Result I32 := do let i ← get_z1 let i0 ← add i q3_c add q1_c i0 -/- [constants::S1] -/ +/- [constants::S1] + Source: 'src/constants.rs', lines 80:0-80:18 -/ def s1_body : Result U32 := Result.ret 6#u32 def s1_c : U32 := eval_global s1_body (by simp) -/- [constants::S2] -/ +/- [constants::S2] + Source: 'src/constants.rs', lines 81:0-81:18 -/ def s2_body : Result U32 := incr s1_c def s2_c : U32 := eval_global s2_body (by simp) -/- [constants::S3] -/ +/- [constants::S3] + Source: 'src/constants.rs', lines 82:0-82:29 -/ def s3_body : Result (Pair U32 U32) := Result.ret p3_c def s3_c : Pair U32 U32 := eval_global s3_body (by simp) -/- [constants::S4] -/ +/- [constants::S4] + Source: 'src/constants.rs', lines 83:0-83:29 -/ def s4_body : Result (Pair U32 U32) := mk_pair1 7#u32 8#u32 def s4_c : Pair U32 U32 := eval_global s4_body (by simp) diff --git a/tests/lean/External/Funs.lean b/tests/lean/External/Funs.lean index 55fb07be..e5655c7e 100644 --- a/tests/lean/External/Funs.lean +++ b/tests/lean/External/Funs.lean @@ -7,7 +7,8 @@ open Primitives namespace external -/- [external::swap]: forward function -/ +/- [external::swap]: forward function + Source: 'src/external.rs', lines 6:0-6:46 -/ def swap (T : Type) (x : T) (y : T) (st : State) : Result (State × Unit) := do let (st0, _) ← core.mem.swap T x y st @@ -15,7 +16,8 @@ def swap (T : Type) (x : T) (y : T) (st : State) : Result (State × Unit) := let (st2, _) ← core.mem.swap_back1 T x y st st1 Result.ret (st2, ()) -/- [external::swap]: backward function 0 -/ +/- [external::swap]: backward function 0 + Source: 'src/external.rs', lines 6:0-6:46 -/ def swap_back (T : Type) (x : T) (y : T) (st : State) (st0 : State) : Result (State × (T × T)) @@ -26,14 +28,16 @@ def swap_back let (_, y0) ← core.mem.swap_back1 T x y st st2 Result.ret (st0, (x0, y0)) -/- [external::test_new_non_zero_u32]: forward function -/ +/- [external::test_new_non_zero_u32]: forward function + Source: 'src/external.rs', lines 11:0-11:60 -/ def test_new_non_zero_u32 (x : U32) (st : State) : Result (State × core.num.nonzero.NonZeroU32) := do let (st0, o) ← core.num.nonzero.NonZeroU32.new x st core.option.Option.unwrap core.num.nonzero.NonZeroU32 o st0 -/- [external::test_vec]: forward function -/ +/- [external::test_vec]: forward function + Source: 'src/external.rs', lines 17:0-17:17 -/ def test_vec : Result Unit := do let v := alloc.vec.Vec.new U32 @@ -43,7 +47,8 @@ def test_vec : Result Unit := /- Unit test for [external::test_vec] -/ #assert (test_vec == .ret ()) -/- [external::custom_swap]: forward function -/ +/- [external::custom_swap]: forward function + Source: 'src/external.rs', lines 24:0-24:66 -/ def custom_swap (T : Type) (x : T) (y : T) (st : State) : Result (State × T) := do @@ -52,7 +57,8 @@ def custom_swap let (st2, _) ← core.mem.swap_back1 T x y st st1 Result.ret (st2, x0) -/- [external::custom_swap]: backward function 0 -/ +/- [external::custom_swap]: backward function 0 + Source: 'src/external.rs', lines 24:0-24:66 -/ def custom_swap_back (T : Type) (x : T) (y : T) (st : State) (ret0 : T) (st0 : State) : Result (State × (T × T)) @@ -63,21 +69,24 @@ def custom_swap_back let (_, y0) ← core.mem.swap_back1 T x y st st2 Result.ret (st0, (ret0, y0)) -/- [external::test_custom_swap]: forward function -/ +/- [external::test_custom_swap]: forward function + Source: 'src/external.rs', lines 29:0-29:59 -/ def test_custom_swap (x : U32) (y : U32) (st : State) : Result (State × Unit) := do let (st0, _) ← custom_swap U32 x y st Result.ret (st0, ()) -/- [external::test_custom_swap]: backward function 0 -/ +/- [external::test_custom_swap]: backward function 0 + Source: 'src/external.rs', lines 29:0-29:59 -/ def test_custom_swap_back (x : U32) (y : U32) (st : State) (st0 : State) : Result (State × (U32 × U32)) := custom_swap_back U32 x y st 1#u32 st0 -/- [external::test_swap_non_zero]: forward function -/ +/- [external::test_swap_non_zero]: forward function + Source: 'src/external.rs', lines 35:0-35:44 -/ def test_swap_non_zero (x : U32) (st : State) : Result (State × U32) := do let (st0, _) ← swap U32 x 0#u32 st diff --git a/tests/lean/External/FunsExternal_Template.lean b/tests/lean/External/FunsExternal_Template.lean index 0fccef86..55cd6bb5 100644 --- a/tests/lean/External/FunsExternal_Template.lean +++ b/tests/lean/External/FunsExternal_Template.lean @@ -6,22 +6,27 @@ import External.Types open Primitives open external -/- [core::mem::swap]: forward function -/ +/- [core::mem::swap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 -/ axiom core.mem.swap (T : Type) : T → T → State → Result (State × Unit) -/- [core::mem::swap]: backward function 0 -/ +/- [core::mem::swap]: backward function 0 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 -/ axiom core.mem.swap_back0 (T : Type) : T → T → State → State → Result (State × T) -/- [core::mem::swap]: backward function 1 -/ +/- [core::mem::swap]: backward function 1 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 -/ axiom core.mem.swap_back1 (T : Type) : T → T → State → State → Result (State × T) -/- [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function -/ +/- [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 -/ axiom core.num.nonzero.NonZeroU32.new : U32 → State → Result (State × (Option core.num.nonzero.NonZeroU32)) -/- [core::option::{core::option::Option}::unwrap]: forward function -/ +/- [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 -/ axiom core.option.Option.unwrap (T : Type) : Option T → State → Result (State × T) diff --git a/tests/lean/External/Types.lean b/tests/lean/External/Types.lean index 71d70eed..40f20cda 100644 --- a/tests/lean/External/Types.lean +++ b/tests/lean/External/Types.lean @@ -5,7 +5,8 @@ open Primitives namespace external -/- [core::num::nonzero::NonZeroU32] -/ +/- [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 -/ axiom core.num.nonzero.NonZeroU32 : Type /- The state type used in the state-error monad -/ diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index a1cd435e..95c501f6 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -6,11 +6,13 @@ open Primitives namespace hashmap -/- [hashmap::hash_key]: forward function -/ +/- [hashmap::hash_key]: forward function + Source: 'src/hashmap.rs', lines 27:0-27:32 -/ def hash_key (k : Usize) : Result Usize := Result.ret k -/- [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::allocate_slots]: loop 0: forward function + Source: 'src/hashmap.rs', lines 50:4-56:5 -/ divergent def HashMap.allocate_slots_loop (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : Result (alloc.vec.Vec (List T)) @@ -23,14 +25,16 @@ divergent def HashMap.allocate_slots_loop HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots -/- [hashmap::{hashmap::HashMap}::allocate_slots]: forward function -/ +/- [hashmap::{hashmap::HashMap}::allocate_slots]: forward function + Source: 'src/hashmap.rs', lines 50:4-50:76 -/ def HashMap.allocate_slots (T : Type) (slots : alloc.vec.Vec (List T)) (n : Usize) : Result (alloc.vec.Vec (List T)) := HashMap.allocate_slots_loop T slots n -/- [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function -/ +/- [hashmap::{hashmap::HashMap}::new_with_capacity]: forward function + Source: 'src/hashmap.rs', lines 59:4-63:13 -/ def HashMap.new_with_capacity (T : Type) (capacity : Usize) (max_load_dividend : Usize) (max_load_divisor : Usize) : @@ -49,12 +53,14 @@ def HashMap.new_with_capacity slots := slots } -/- [hashmap::{hashmap::HashMap}::new]: forward function -/ +/- [hashmap::{hashmap::HashMap}::new]: forward function + Source: 'src/hashmap.rs', lines 75:4-75:24 -/ def HashMap.new (T : Type) : Result (HashMap T) := HashMap.new_with_capacity T 32#usize 4#usize 5#usize /- [hashmap::{hashmap::HashMap}::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-88:5 -/ divergent def HashMap.clear_loop (T : Type) (slots : alloc.vec.Vec (List T)) (i : Usize) : Result (alloc.vec.Vec (List T)) @@ -72,17 +78,20 @@ divergent def HashMap.clear_loop else Result.ret slots /- [hashmap::{hashmap::HashMap}::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-80:27 -/ def HashMap.clear (T : Type) (self : HashMap T) : Result (HashMap T) := do let v ← HashMap.clear_loop T self.slots 0#usize Result.ret { self with num_entries := 0#usize, slots := v } -/- [hashmap::{hashmap::HashMap}::len]: forward function -/ +/- [hashmap::{hashmap::HashMap}::len]: forward function + Source: 'src/hashmap.rs', lines 90:4-90:30 -/ def HashMap.len (T : Type) (self : HashMap T) : Result Usize := Result.ret self.num_entries -/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 97:4-114:5 -/ divergent def HashMap.insert_in_list_loop (T : Type) (key : Usize) (value : T) (ls : List T) : Result Bool := match ls with @@ -92,12 +101,14 @@ divergent def HashMap.insert_in_list_loop else HashMap.insert_in_list_loop T key value tl | List.Nil => Result.ret true -/- [hashmap::{hashmap::HashMap}::insert_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: forward function + Source: 'src/hashmap.rs', lines 97:4-97:71 -/ def HashMap.insert_in_list (T : Type) (key : Usize) (value : T) (ls : List T) : Result Bool := HashMap.insert_in_list_loop T key value ls -/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-114:5 -/ divergent def HashMap.insert_in_list_loop_back (T : Type) (key : Usize) (value : T) (ls : List T) : Result (List T) := match ls with @@ -111,13 +122,15 @@ divergent def HashMap.insert_in_list_loop_back | List.Nil => let l := List.Nil Result.ret (List.Cons key value l) -/- [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::insert_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-97:71 -/ def HashMap.insert_in_list_back (T : Type) (key : Usize) (value : T) (ls : List T) : Result (List T) := HashMap.insert_in_list_loop_back T key value ls /- [hashmap::{hashmap::HashMap}::insert_no_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 117:4-117:54 -/ def HashMap.insert_no_resize (T : Type) (self : HashMap T) (key : Usize) (value : T) : Result (HashMap T) @@ -151,7 +164,8 @@ def HashMap.insert_no_resize Result.ret { self with slots := v } /- [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-196:5 -/ divergent def HashMap.move_elements_from_list_loop (T : Type) (ntable : HashMap T) (ls : List T) : Result (HashMap T) := match ls with @@ -162,13 +176,15 @@ divergent def HashMap.move_elements_from_list_loop | List.Nil => Result.ret ntable /- [hashmap::{hashmap::HashMap}::move_elements_from_list]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-183:72 -/ def HashMap.move_elements_from_list (T : Type) (ntable : HashMap T) (ls : List T) : Result (HashMap T) := HashMap.move_elements_from_list_loop T ntable ls /- [hashmap::{hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-180:5 -/ divergent def HashMap.move_elements_loop (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) : @@ -192,7 +208,8 @@ divergent def HashMap.move_elements_loop else Result.ret (ntable, slots) /- [hashmap::{hashmap::HashMap}::move_elements]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-171:95 -/ def HashMap.move_elements (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) : @@ -201,7 +218,8 @@ def HashMap.move_elements HashMap.move_elements_loop T ntable slots i /- [hashmap::{hashmap::HashMap}::try_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 140:4-140:28 -/ def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := do let max_usize ← Scalar.cast .Usize core_u32_max @@ -224,7 +242,8 @@ def HashMap.try_resize (T : Type) (self : HashMap T) : Result (HashMap T) := else Result.ret { self with max_load_factor := (i, i0) } /- [hashmap::{hashmap::HashMap}::insert]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 129:4-129:48 -/ def HashMap.insert (T : Type) (self : HashMap T) (key : Usize) (value : T) : Result (HashMap T) @@ -236,7 +255,8 @@ def HashMap.insert then HashMap.try_resize T self0 else Result.ret self0 -/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 206:4-219:5 -/ divergent def HashMap.contains_key_in_list_loop (T : Type) (key : Usize) (ls : List T) : Result Bool := match ls with @@ -246,12 +266,14 @@ divergent def HashMap.contains_key_in_list_loop else HashMap.contains_key_in_list_loop T key tl | List.Nil => Result.ret false -/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: forward function + Source: 'src/hashmap.rs', lines 206:4-206:68 -/ def HashMap.contains_key_in_list (T : Type) (key : Usize) (ls : List T) : Result Bool := HashMap.contains_key_in_list_loop T key ls -/- [hashmap::{hashmap::HashMap}::contains_key]: forward function -/ +/- [hashmap::{hashmap::HashMap}::contains_key]: forward function + Source: 'src/hashmap.rs', lines 199:4-199:49 -/ def HashMap.contains_key (T : Type) (self : HashMap T) (key : Usize) : Result Bool := do @@ -264,7 +286,8 @@ def HashMap.contains_key hash_mod HashMap.contains_key_in_list T key l -/- [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 224:4-237:5 -/ divergent def HashMap.get_in_list_loop (T : Type) (key : Usize) (ls : List T) : Result T := match ls with @@ -274,11 +297,13 @@ divergent def HashMap.get_in_list_loop else HashMap.get_in_list_loop T key tl | List.Nil => Result.fail Error.panic -/- [hashmap::{hashmap::HashMap}::get_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_in_list]: forward function + Source: 'src/hashmap.rs', lines 224:4-224:70 -/ def HashMap.get_in_list (T : Type) (key : Usize) (ls : List T) : Result T := HashMap.get_in_list_loop T key ls -/- [hashmap::{hashmap::HashMap}::get]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get]: forward function + Source: 'src/hashmap.rs', lines 239:4-239:55 -/ def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key @@ -290,7 +315,8 @@ def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := hash_mod HashMap.get_in_list T key l -/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 245:4-254:5 -/ divergent def HashMap.get_mut_in_list_loop (T : Type) (ls : List T) (key : Usize) : Result T := match ls with @@ -300,12 +326,14 @@ divergent def HashMap.get_mut_in_list_loop else HashMap.get_mut_in_list_loop T tl key | List.Nil => Result.fail Error.panic -/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function + Source: 'src/hashmap.rs', lines 245:4-245:86 -/ def HashMap.get_mut_in_list (T : Type) (ls : List T) (key : Usize) : Result T := HashMap.get_mut_in_list_loop T ls key -/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-254:5 -/ divergent def HashMap.get_mut_in_list_loop_back (T : Type) (ls : List T) (key : Usize) (ret0 : T) : Result (List T) := match ls with @@ -318,12 +346,14 @@ divergent def HashMap.get_mut_in_list_loop_back Result.ret (List.Cons ckey cvalue tl0) | List.Nil => Result.fail Error.panic -/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-245:86 -/ def HashMap.get_mut_in_list_back (T : Type) (ls : List T) (key : Usize) (ret0 : T) : Result (List T) := HashMap.get_mut_in_list_loop_back T ls key ret0 -/- [hashmap::{hashmap::HashMap}::get_mut]: forward function -/ +/- [hashmap::{hashmap::HashMap}::get_mut]: forward function + Source: 'src/hashmap.rs', lines 257:4-257:67 -/ def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := do let hash ← hash_key key @@ -335,7 +365,8 @@ def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := hash_mod HashMap.get_mut_in_list T l key -/- [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 + Source: 'src/hashmap.rs', lines 257:4-257:67 -/ def HashMap.get_mut_back (T : Type) (self : HashMap T) (key : Usize) (ret0 : T) : Result (HashMap T) @@ -355,7 +386,8 @@ def HashMap.get_mut_back hash_mod l0 Result.ret { self with slots := v } -/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 265:4-291:5 -/ divergent def HashMap.remove_from_list_loop (T : Type) (key : Usize) (ls : List T) : Result (Option T) := match ls with @@ -369,12 +401,14 @@ divergent def HashMap.remove_from_list_loop else HashMap.remove_from_list_loop T key tl | List.Nil => Result.ret none -/- [hashmap::{hashmap::HashMap}::remove_from_list]: forward function -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: forward function + Source: 'src/hashmap.rs', lines 265:4-265:69 -/ def HashMap.remove_from_list (T : Type) (key : Usize) (ls : List T) : Result (Option T) := HashMap.remove_from_list_loop T key ls -/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-291:5 -/ divergent def HashMap.remove_from_list_loop_back (T : Type) (key : Usize) (ls : List T) : Result (List T) := match ls with @@ -391,12 +425,14 @@ divergent def HashMap.remove_from_list_loop_back Result.ret (List.Cons ckey t tl0) | List.Nil => Result.ret List.Nil -/- [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 -/ +/- [hashmap::{hashmap::HashMap}::remove_from_list]: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-265:69 -/ def HashMap.remove_from_list_back (T : Type) (key : Usize) (ls : List T) : Result (List T) := HashMap.remove_from_list_loop_back T key ls -/- [hashmap::{hashmap::HashMap}::remove]: forward function -/ +/- [hashmap::{hashmap::HashMap}::remove]: forward function + Source: 'src/hashmap.rs', lines 294:4-294:52 -/ def HashMap.remove (T : Type) (self : HashMap T) (key : Usize) : Result (Option T) := do @@ -414,7 +450,8 @@ def HashMap.remove let _ ← self.num_entries - 1#usize Result.ret (some x0) -/- [hashmap::{hashmap::HashMap}::remove]: backward function 0 -/ +/- [hashmap::{hashmap::HashMap}::remove]: backward function 0 + Source: 'src/hashmap.rs', lines 294:4-294:52 -/ def HashMap.remove_back (T : Type) (self : HashMap T) (key : Usize) : Result (HashMap T) := do @@ -445,7 +482,8 @@ def HashMap.remove_back hash_mod l0 Result.ret { self with num_entries := i0, slots := v } -/- [hashmap::test1]: forward function -/ +/- [hashmap::test1]: forward function + Source: 'src/hashmap.rs', lines 315:0-315:10 -/ def test1 : Result Unit := do let hm ← HashMap.new U64 diff --git a/tests/lean/Hashmap/Types.lean b/tests/lean/Hashmap/Types.lean index e007bce0..fa454123 100644 --- a/tests/lean/Hashmap/Types.lean +++ b/tests/lean/Hashmap/Types.lean @@ -5,12 +5,14 @@ open Primitives namespace hashmap -/- [hashmap::List] -/ +/- [hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 -/ inductive List (T : Type) := | Cons : Usize → T → List T → List T | Nil : List T -/- [hashmap::HashMap] -/ +/- [hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 -/ structure HashMap (T : Type) where num_entries : Usize max_load_factor : (Usize × Usize) diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index 5e05a399..abe84bbf 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -7,11 +7,13 @@ open Primitives namespace hashmap_main -/- [hashmap_main::hashmap::hash_key]: forward function -/ +/- [hashmap_main::hashmap::hash_key]: forward function + Source: 'src/hashmap.rs', lines 27:0-27:32 -/ def hashmap.hash_key (k : Usize) : Result Usize := Result.ret k -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: loop 0: forward function + Source: 'src/hashmap.rs', lines 50:4-56:5 -/ divergent def hashmap.HashMap.allocate_slots_loop (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : Result (alloc.vec.Vec (hashmap.List T)) @@ -24,14 +26,16 @@ divergent def hashmap.HashMap.allocate_slots_loop hashmap.HashMap.allocate_slots_loop T slots0 n0 else Result.ret slots -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::allocate_slots]: forward function + Source: 'src/hashmap.rs', lines 50:4-50:76 -/ def hashmap.HashMap.allocate_slots (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (n : Usize) : Result (alloc.vec.Vec (hashmap.List T)) := hashmap.HashMap.allocate_slots_loop T slots n -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new_with_capacity]: forward function + Source: 'src/hashmap.rs', lines 59:4-63:13 -/ def hashmap.HashMap.new_with_capacity (T : Type) (capacity : Usize) (max_load_dividend : Usize) (max_load_divisor : Usize) : @@ -50,12 +54,14 @@ def hashmap.HashMap.new_with_capacity slots := slots } -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::new]: forward function + Source: 'src/hashmap.rs', lines 75:4-75:24 -/ def hashmap.HashMap.new (T : Type) : Result (hashmap.HashMap T) := hashmap.HashMap.new_with_capacity T 32#usize 4#usize 5#usize /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-88:5 -/ divergent def hashmap.HashMap.clear_loop (T : Type) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : Result (alloc.vec.Vec (hashmap.List T)) @@ -73,18 +79,21 @@ divergent def hashmap.HashMap.clear_loop else Result.ret slots /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 80:4-80:27 -/ def hashmap.HashMap.clear (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do let v ← hashmap.HashMap.clear_loop T self.slots 0#usize Result.ret { self with num_entries := 0#usize, slots := v } -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: forward function + Source: 'src/hashmap.rs', lines 90:4-90:30 -/ def hashmap.HashMap.len (T : Type) (self : hashmap.HashMap T) : Result Usize := Result.ret self.num_entries -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 97:4-114:5 -/ divergent def hashmap.HashMap.insert_in_list_loop (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result Bool := match ls with @@ -94,12 +103,14 @@ divergent def hashmap.HashMap.insert_in_list_loop else hashmap.HashMap.insert_in_list_loop T key value tl | hashmap.List.Nil => Result.ret true -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: forward function + Source: 'src/hashmap.rs', lines 97:4-97:71 -/ def hashmap.HashMap.insert_in_list (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result Bool := hashmap.HashMap.insert_in_list_loop T key value ls -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-114:5 -/ divergent def hashmap.HashMap.insert_in_list_loop_back (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result (hashmap.List T) @@ -116,7 +127,8 @@ divergent def hashmap.HashMap.insert_in_list_loop_back let l := hashmap.List.Nil Result.ret (hashmap.List.Cons key value l) -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 97:4-97:71 -/ def hashmap.HashMap.insert_in_list_back (T : Type) (key : Usize) (value : T) (ls : hashmap.List T) : Result (hashmap.List T) @@ -124,7 +136,8 @@ def hashmap.HashMap.insert_in_list_back hashmap.HashMap.insert_in_list_loop_back T key value ls /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 117:4-117:54 -/ def hashmap.HashMap.insert_no_resize (T : Type) (self : hashmap.HashMap T) (key : Usize) (value : T) : Result (hashmap.HashMap T) @@ -158,7 +171,8 @@ def hashmap.HashMap.insert_no_resize Result.ret { self with slots := v } /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-196:5 -/ divergent def hashmap.HashMap.move_elements_from_list_loop (T : Type) (ntable : hashmap.HashMap T) (ls : hashmap.List T) : Result (hashmap.HashMap T) @@ -171,7 +185,8 @@ divergent def hashmap.HashMap.move_elements_from_list_loop | hashmap.List.Nil => Result.ret ntable /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 183:4-183:72 -/ def hashmap.HashMap.move_elements_from_list (T : Type) (ntable : hashmap.HashMap T) (ls : hashmap.List T) : Result (hashmap.HashMap T) @@ -179,7 +194,8 @@ def hashmap.HashMap.move_elements_from_list hashmap.HashMap.move_elements_from_list_loop T ntable ls /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-180:5 -/ divergent def hashmap.HashMap.move_elements_loop (T : Type) (ntable : hashmap.HashMap T) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : @@ -204,7 +220,8 @@ divergent def hashmap.HashMap.move_elements_loop else Result.ret (ntable, slots) /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 171:4-171:95 -/ def hashmap.HashMap.move_elements (T : Type) (ntable : hashmap.HashMap T) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : @@ -213,7 +230,8 @@ def hashmap.HashMap.move_elements hashmap.HashMap.move_elements_loop T ntable slots i /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 140:4-140:28 -/ def hashmap.HashMap.try_resize (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := do @@ -238,7 +256,8 @@ def hashmap.HashMap.try_resize else Result.ret { self with max_load_factor := (i, i0) } /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/hashmap.rs', lines 129:4-129:48 -/ def hashmap.HashMap.insert (T : Type) (self : hashmap.HashMap T) (key : Usize) (value : T) : Result (hashmap.HashMap T) @@ -250,7 +269,8 @@ def hashmap.HashMap.insert then hashmap.HashMap.try_resize T self0 else Result.ret self0 -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 206:4-219:5 -/ divergent def hashmap.HashMap.contains_key_in_list_loop (T : Type) (key : Usize) (ls : hashmap.List T) : Result Bool := match ls with @@ -260,12 +280,14 @@ divergent def hashmap.HashMap.contains_key_in_list_loop else hashmap.HashMap.contains_key_in_list_loop T key tl | hashmap.List.Nil => Result.ret false -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: forward function + Source: 'src/hashmap.rs', lines 206:4-206:68 -/ def hashmap.HashMap.contains_key_in_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result Bool := hashmap.HashMap.contains_key_in_list_loop T key ls -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: forward function + Source: 'src/hashmap.rs', lines 199:4-199:49 -/ def hashmap.HashMap.contains_key (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result Bool := do @@ -278,7 +300,8 @@ def hashmap.HashMap.contains_key self.slots hash_mod hashmap.HashMap.contains_key_in_list T key l -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 224:4-237:5 -/ divergent def hashmap.HashMap.get_in_list_loop (T : Type) (key : Usize) (ls : hashmap.List T) : Result T := match ls with @@ -288,12 +311,14 @@ divergent def hashmap.HashMap.get_in_list_loop else hashmap.HashMap.get_in_list_loop T key tl | hashmap.List.Nil => Result.fail Error.panic -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function + Source: 'src/hashmap.rs', lines 224:4-224:70 -/ def hashmap.HashMap.get_in_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result T := hashmap.HashMap.get_in_list_loop T key ls -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: forward function + Source: 'src/hashmap.rs', lines 239:4-239:55 -/ def hashmap.HashMap.get (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do @@ -306,7 +331,8 @@ def hashmap.HashMap.get self.slots hash_mod hashmap.HashMap.get_in_list T key l -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 245:4-254:5 -/ divergent def hashmap.HashMap.get_mut_in_list_loop (T : Type) (ls : hashmap.List T) (key : Usize) : Result T := match ls with @@ -316,12 +342,14 @@ divergent def hashmap.HashMap.get_mut_in_list_loop else hashmap.HashMap.get_mut_in_list_loop T tl key | hashmap.List.Nil => Result.fail Error.panic -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function + Source: 'src/hashmap.rs', lines 245:4-245:86 -/ def hashmap.HashMap.get_mut_in_list (T : Type) (ls : hashmap.List T) (key : Usize) : Result T := hashmap.HashMap.get_mut_in_list_loop T ls key -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-254:5 -/ divergent def hashmap.HashMap.get_mut_in_list_loop_back (T : Type) (ls : hashmap.List T) (key : Usize) (ret0 : T) : Result (hashmap.List T) @@ -336,14 +364,16 @@ divergent def hashmap.HashMap.get_mut_in_list_loop_back Result.ret (hashmap.List.Cons ckey cvalue tl0) | hashmap.List.Nil => Result.fail Error.panic -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 + Source: 'src/hashmap.rs', lines 245:4-245:86 -/ def hashmap.HashMap.get_mut_in_list_back (T : Type) (ls : hashmap.List T) (key : Usize) (ret0 : T) : Result (hashmap.List T) := hashmap.HashMap.get_mut_in_list_loop_back T ls key ret0 -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function + Source: 'src/hashmap.rs', lines 257:4-257:67 -/ def hashmap.HashMap.get_mut (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result T := do @@ -356,7 +386,8 @@ def hashmap.HashMap.get_mut self.slots hash_mod hashmap.HashMap.get_mut_in_list T l key -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 + Source: 'src/hashmap.rs', lines 257:4-257:67 -/ def hashmap.HashMap.get_mut_back (T : Type) (self : hashmap.HashMap T) (key : Usize) (ret0 : T) : Result (hashmap.HashMap T) @@ -376,7 +407,8 @@ def hashmap.HashMap.get_mut_back self.slots hash_mod l0 Result.ret { self with slots := v } -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: forward function + Source: 'src/hashmap.rs', lines 265:4-291:5 -/ divergent def hashmap.HashMap.remove_from_list_loop (T : Type) (key : Usize) (ls : hashmap.List T) : Result (Option T) := match ls with @@ -392,12 +424,14 @@ divergent def hashmap.HashMap.remove_from_list_loop else hashmap.HashMap.remove_from_list_loop T key tl | hashmap.List.Nil => Result.ret none -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: forward function + Source: 'src/hashmap.rs', lines 265:4-265:69 -/ def hashmap.HashMap.remove_from_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result (Option T) := hashmap.HashMap.remove_from_list_loop T key ls -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-291:5 -/ divergent def hashmap.HashMap.remove_from_list_loop_back (T : Type) (key : Usize) (ls : hashmap.List T) : Result (hashmap.List T) := match ls with @@ -416,12 +450,14 @@ divergent def hashmap.HashMap.remove_from_list_loop_back Result.ret (hashmap.List.Cons ckey t tl0) | hashmap.List.Nil => Result.ret hashmap.List.Nil -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: backward function 1 + Source: 'src/hashmap.rs', lines 265:4-265:69 -/ def hashmap.HashMap.remove_from_list_back (T : Type) (key : Usize) (ls : hashmap.List T) : Result (hashmap.List T) := hashmap.HashMap.remove_from_list_loop_back T key ls -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: forward function + Source: 'src/hashmap.rs', lines 294:4-294:52 -/ def hashmap.HashMap.remove (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result (Option T) := do @@ -439,7 +475,8 @@ def hashmap.HashMap.remove let _ ← self.num_entries - 1#usize Result.ret (some x0) -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 -/ +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: backward function 0 + Source: 'src/hashmap.rs', lines 294:4-294:52 -/ def hashmap.HashMap.remove_back (T : Type) (self : hashmap.HashMap T) (key : Usize) : Result (hashmap.HashMap T) @@ -472,7 +509,8 @@ def hashmap.HashMap.remove_back self.slots hash_mod l0 Result.ret { self with num_entries := i0, slots := v } -/- [hashmap_main::hashmap::test1]: forward function -/ +/- [hashmap_main::hashmap::test1]: forward function + Source: 'src/hashmap.rs', lines 315:0-315:10 -/ def hashmap.test1 : Result Unit := do let hm ← hashmap.HashMap.new U64 @@ -515,7 +553,8 @@ def hashmap.test1 : Result Unit := then Result.fail Error.panic else Result.ret () -/- [hashmap_main::insert_on_disk]: forward function -/ +/- [hashmap_main::insert_on_disk]: forward function + Source: 'src/hashmap_main.rs', lines 7:0-7:43 -/ def insert_on_disk (key : Usize) (value : U64) (st : State) : Result (State × Unit) := do @@ -524,7 +563,8 @@ def insert_on_disk let (st1, _) ← hashmap_utils.serialize hm0 st0 Result.ret (st1, ()) -/- [hashmap_main::main]: forward function -/ +/- [hashmap_main::main]: forward function + Source: 'src/hashmap_main.rs', lines 16:0-16:13 -/ def main : Result Unit := Result.ret () diff --git a/tests/lean/HashmapMain/FunsExternal_Template.lean b/tests/lean/HashmapMain/FunsExternal_Template.lean index f537fc8f..02ca5b0e 100644 --- a/tests/lean/HashmapMain/FunsExternal_Template.lean +++ b/tests/lean/HashmapMain/FunsExternal_Template.lean @@ -6,11 +6,13 @@ import HashmapMain.Types open Primitives open hashmap_main -/- [hashmap_main::hashmap_utils::deserialize]: forward function -/ +/- [hashmap_main::hashmap_utils::deserialize]: forward function + Source: 'src/hashmap_utils.rs', lines 10:0-10:43 -/ axiom hashmap_utils.deserialize : State → Result (State × (hashmap.HashMap U64)) -/- [hashmap_main::hashmap_utils::serialize]: forward function -/ +/- [hashmap_main::hashmap_utils::serialize]: forward function + Source: 'src/hashmap_utils.rs', lines 5:0-5:42 -/ axiom hashmap_utils.serialize : hashmap.HashMap U64 → State → Result (State × Unit) diff --git a/tests/lean/HashmapMain/Types.lean b/tests/lean/HashmapMain/Types.lean index 065c109b..f7be6719 100644 --- a/tests/lean/HashmapMain/Types.lean +++ b/tests/lean/HashmapMain/Types.lean @@ -5,12 +5,14 @@ open Primitives namespace hashmap_main -/- [hashmap_main::hashmap::List] -/ +/- [hashmap_main::hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 -/ inductive hashmap.List (T : Type) := | Cons : Usize → T → hashmap.List T → hashmap.List T | Nil : hashmap.List T -/- [hashmap_main::hashmap::HashMap] -/ +/- [hashmap_main::hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 -/ structure hashmap.HashMap (T : Type) where num_entries : Usize max_load_factor : (Usize × Usize) diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index 701dc6f7..ae1d87aa 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -5,7 +5,8 @@ open Primitives namespace loops -/- [loops::sum]: loop 0: forward function -/ +/- [loops::sum]: loop 0: forward function + Source: 'src/loops.rs', lines 4:0-14:1 -/ divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := if i < max then do @@ -14,11 +15,13 @@ divergent def sum_loop (max : U32) (i : U32) (s : U32) : Result U32 := sum_loop max i0 s0 else s * 2#u32 -/- [loops::sum]: forward function -/ +/- [loops::sum]: forward function + Source: 'src/loops.rs', lines 4:0-4:27 -/ def sum (max : U32) : Result U32 := sum_loop max 0#u32 0#u32 -/- [loops::sum_with_mut_borrows]: loop 0: forward function -/ +/- [loops::sum_with_mut_borrows]: loop 0: forward function + Source: 'src/loops.rs', lines 19:0-31:1 -/ divergent def sum_with_mut_borrows_loop (max : U32) (mi : U32) (ms : U32) : Result U32 := if mi < max @@ -29,11 +32,13 @@ divergent def sum_with_mut_borrows_loop sum_with_mut_borrows_loop max mi0 ms0 else ms * 2#u32 -/- [loops::sum_with_mut_borrows]: forward function -/ +/- [loops::sum_with_mut_borrows]: forward function + Source: 'src/loops.rs', lines 19:0-19:44 -/ def sum_with_mut_borrows (max : U32) : Result U32 := sum_with_mut_borrows_loop max 0#u32 0#u32 -/- [loops::sum_with_shared_borrows]: loop 0: forward function -/ +/- [loops::sum_with_shared_borrows]: loop 0: forward function + Source: 'src/loops.rs', lines 34:0-48:1 -/ divergent def sum_with_shared_borrows_loop (max : U32) (i : U32) (s : U32) : Result U32 := if i < max @@ -44,12 +49,14 @@ divergent def sum_with_shared_borrows_loop sum_with_shared_borrows_loop max i0 s0 else s * 2#u32 -/- [loops::sum_with_shared_borrows]: forward function -/ +/- [loops::sum_with_shared_borrows]: forward function + Source: 'src/loops.rs', lines 34:0-34:47 -/ def sum_with_shared_borrows (max : U32) : Result U32 := sum_with_shared_borrows_loop max 0#u32 0#u32 /- [loops::clear]: loop 0: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/loops.rs', lines 52:0-58:1 -/ divergent def clear_loop (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := let i0 := alloc.vec.Vec.len U32 v @@ -64,16 +71,19 @@ divergent def clear_loop else Result.ret v /- [loops::clear]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/loops.rs', lines 52:0-52:30 -/ def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := clear_loop v 0#usize -/- [loops::List] -/ +/- [loops::List] + Source: 'src/loops.rs', lines 60:0-60:16 -/ inductive List (T : Type) := | Cons : T → List T → List T | Nil : List T -/- [loops::list_mem]: loop 0: forward function -/ +/- [loops::list_mem]: loop 0: forward function + Source: 'src/loops.rs', lines 66:0-75:1 -/ divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := match ls with | List.Cons y tl => if y = x @@ -81,11 +91,13 @@ divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := else list_mem_loop x tl | List.Nil => Result.ret false -/- [loops::list_mem]: forward function -/ +/- [loops::list_mem]: forward function + Source: 'src/loops.rs', lines 66:0-66:52 -/ def list_mem (x : U32) (ls : List U32) : Result Bool := list_mem_loop x ls -/- [loops::list_nth_mut_loop]: loop 0: forward function -/ +/- [loops::list_nth_mut_loop]: loop 0: forward function + Source: 'src/loops.rs', lines 78:0-88:1 -/ divergent def list_nth_mut_loop_loop (T : Type) (ls : List T) (i : U32) : Result T := match ls with @@ -97,11 +109,13 @@ divergent def list_nth_mut_loop_loop list_nth_mut_loop_loop T tl i0 | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop]: forward function -/ +/- [loops::list_nth_mut_loop]: forward function + Source: 'src/loops.rs', lines 78:0-78:71 -/ def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result T := list_nth_mut_loop_loop T ls i -/- [loops::list_nth_mut_loop]: loop 0: backward function 0 -/ +/- [loops::list_nth_mut_loop]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 78:0-88:1 -/ divergent def list_nth_mut_loop_loop_back (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := match ls with @@ -115,12 +129,14 @@ divergent def list_nth_mut_loop_loop_back Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop]: backward function 0 -/ +/- [loops::list_nth_mut_loop]: backward function 0 + Source: 'src/loops.rs', lines 78:0-78:71 -/ def list_nth_mut_loop_back (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := list_nth_mut_loop_loop_back T ls i ret0 -/- [loops::list_nth_shared_loop]: loop 0: forward function -/ +/- [loops::list_nth_shared_loop]: loop 0: forward function + Source: 'src/loops.rs', lines 91:0-101:1 -/ divergent def list_nth_shared_loop_loop (T : Type) (ls : List T) (i : U32) : Result T := match ls with @@ -132,11 +148,13 @@ divergent def list_nth_shared_loop_loop list_nth_shared_loop_loop T tl i0 | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_loop]: forward function -/ +/- [loops::list_nth_shared_loop]: forward function + Source: 'src/loops.rs', lines 91:0-91:66 -/ def list_nth_shared_loop (T : Type) (ls : List T) (i : U32) : Result T := list_nth_shared_loop_loop T ls i -/- [loops::get_elem_mut]: loop 0: forward function -/ +/- [loops::get_elem_mut]: loop 0: forward function + Source: 'src/loops.rs', lines 103:0-117:1 -/ divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := match ls with | List.Cons y tl => if y = x @@ -144,7 +162,8 @@ divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := else get_elem_mut_loop x tl | List.Nil => Result.fail Error.panic -/- [loops::get_elem_mut]: forward function -/ +/- [loops::get_elem_mut]: forward function + Source: 'src/loops.rs', lines 103:0-103:73 -/ def get_elem_mut (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := do @@ -153,7 +172,8 @@ def get_elem_mut (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize get_elem_mut_loop x l -/- [loops::get_elem_mut]: loop 0: backward function 0 -/ +/- [loops::get_elem_mut]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 103:0-117:1 -/ divergent def get_elem_mut_loop_back (x : Usize) (ls : List Usize) (ret0 : Usize) : Result (List Usize) := match ls with @@ -166,7 +186,8 @@ divergent def get_elem_mut_loop_back Result.ret (List.Cons y tl0) | List.Nil => Result.fail Error.panic -/- [loops::get_elem_mut]: backward function 0 -/ +/- [loops::get_elem_mut]: backward function 0 + Source: 'src/loops.rs', lines 103:0-103:73 -/ def get_elem_mut_back (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret0 : Usize) : Result (alloc.vec.Vec (List Usize)) @@ -180,7 +201,8 @@ def get_elem_mut_back (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize l0 -/- [loops::get_elem_shared]: loop 0: forward function -/ +/- [loops::get_elem_shared]: loop 0: forward function + Source: 'src/loops.rs', lines 119:0-133:1 -/ divergent def get_elem_shared_loop (x : Usize) (ls : List Usize) : Result Usize := match ls with @@ -189,7 +211,8 @@ divergent def get_elem_shared_loop else get_elem_shared_loop x tl | List.Nil => Result.fail Error.panic -/- [loops::get_elem_shared]: forward function -/ +/- [loops::get_elem_shared]: forward function + Source: 'src/loops.rs', lines 119:0-119:68 -/ def get_elem_shared (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := do @@ -198,19 +221,23 @@ def get_elem_shared (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize get_elem_shared_loop x l -/- [loops::id_mut]: forward function -/ +/- [loops::id_mut]: forward function + Source: 'src/loops.rs', lines 135:0-135:50 -/ def id_mut (T : Type) (ls : List T) : Result (List T) := Result.ret ls -/- [loops::id_mut]: backward function 0 -/ +/- [loops::id_mut]: backward function 0 + Source: 'src/loops.rs', lines 135:0-135:50 -/ def id_mut_back (T : Type) (ls : List T) (ret0 : List T) : Result (List T) := Result.ret ret0 -/- [loops::id_shared]: forward function -/ +/- [loops::id_shared]: forward function + Source: 'src/loops.rs', lines 139:0-139:45 -/ def id_shared (T : Type) (ls : List T) : Result (List T) := Result.ret ls -/- [loops::list_nth_mut_loop_with_id]: loop 0: forward function -/ +/- [loops::list_nth_mut_loop_with_id]: loop 0: forward function + Source: 'src/loops.rs', lines 144:0-155:1 -/ divergent def list_nth_mut_loop_with_id_loop (T : Type) (i : U32) (ls : List T) : Result T := match ls with @@ -222,13 +249,15 @@ divergent def list_nth_mut_loop_with_id_loop list_nth_mut_loop_with_id_loop T i0 tl | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_with_id]: forward function -/ +/- [loops::list_nth_mut_loop_with_id]: forward function + Source: 'src/loops.rs', lines 144:0-144:75 -/ def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := do let ls0 ← id_mut T ls list_nth_mut_loop_with_id_loop T i ls0 -/- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 -/ +/- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 144:0-155:1 -/ divergent def list_nth_mut_loop_with_id_loop_back (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := match ls with @@ -242,7 +271,8 @@ divergent def list_nth_mut_loop_with_id_loop_back Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_with_id]: backward function 0 -/ +/- [loops::list_nth_mut_loop_with_id]: backward function 0 + Source: 'src/loops.rs', lines 144:0-144:75 -/ def list_nth_mut_loop_with_id_back (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := do @@ -250,7 +280,8 @@ def list_nth_mut_loop_with_id_back let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret0 id_mut_back T ls l -/- [loops::list_nth_shared_loop_with_id]: loop 0: forward function -/ +/- [loops::list_nth_shared_loop_with_id]: loop 0: forward function + Source: 'src/loops.rs', lines 158:0-169:1 -/ divergent def list_nth_shared_loop_with_id_loop (T : Type) (i : U32) (ls : List T) : Result T := match ls with @@ -262,14 +293,16 @@ divergent def list_nth_shared_loop_with_id_loop list_nth_shared_loop_with_id_loop T i0 tl | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_loop_with_id]: forward function -/ +/- [loops::list_nth_shared_loop_with_id]: forward function + Source: 'src/loops.rs', lines 158:0-158:70 -/ def list_nth_shared_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := do let ls0 ← id_shared T ls list_nth_shared_loop_with_id_loop T i ls0 -/- [loops::list_nth_mut_loop_pair]: loop 0: forward function -/ +/- [loops::list_nth_mut_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 174:0-195:1 -/ divergent def list_nth_mut_loop_pair_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -284,12 +317,14 @@ divergent def list_nth_mut_loop_pair_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_pair]: forward function -/ +/- [loops::list_nth_mut_loop_pair]: forward function + Source: 'src/loops.rs', lines 174:0-178:27 -/ def list_nth_mut_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_mut_loop_pair_loop T ls0 ls1 i -/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 -/ +/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 174:0-195:1 -/ divergent def list_nth_mut_loop_pair_loop_back'a (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) @@ -308,14 +343,16 @@ divergent def list_nth_mut_loop_pair_loop_back'a | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_pair]: backward function 0 -/ +/- [loops::list_nth_mut_loop_pair]: backward function 0 + Source: 'src/loops.rs', lines 174:0-178:27 -/ def list_nth_mut_loop_pair_back'a (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) := list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret0 -/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 -/ +/- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 + Source: 'src/loops.rs', lines 174:0-195:1 -/ divergent def list_nth_mut_loop_pair_loop_back'b (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) @@ -334,14 +371,16 @@ divergent def list_nth_mut_loop_pair_loop_back'b | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_pair]: backward function 1 -/ +/- [loops::list_nth_mut_loop_pair]: backward function 1 + Source: 'src/loops.rs', lines 174:0-178:27 -/ def list_nth_mut_loop_pair_back'b (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) := list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret0 -/- [loops::list_nth_shared_loop_pair]: loop 0: forward function -/ +/- [loops::list_nth_shared_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 198:0-219:1 -/ divergent def list_nth_shared_loop_pair_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -356,12 +395,14 @@ divergent def list_nth_shared_loop_pair_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_loop_pair]: forward function -/ +/- [loops::list_nth_shared_loop_pair]: forward function + Source: 'src/loops.rs', lines 198:0-202:19 -/ def list_nth_shared_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_shared_loop_pair_loop T ls0 ls1 i -/- [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function -/ +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 223:0-238:1 -/ divergent def list_nth_mut_loop_pair_merge_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -377,12 +418,14 @@ divergent def list_nth_mut_loop_pair_merge_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_pair_merge]: forward function -/ +/- [loops::list_nth_mut_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 223:0-227:27 -/ def list_nth_mut_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_mut_loop_pair_merge_loop T ls0 ls1 i -/- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 -/ +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 223:0-238:1 -/ divergent def list_nth_mut_loop_pair_merge_loop_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : Result ((List T) × (List T)) @@ -403,14 +446,16 @@ divergent def list_nth_mut_loop_pair_merge_loop_back | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_loop_pair_merge]: backward function 0 -/ +/- [loops::list_nth_mut_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 223:0-227:27 -/ def list_nth_mut_loop_pair_merge_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : Result ((List T) × (List T)) := list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 -/- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function -/ +/- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 241:0-256:1 -/ divergent def list_nth_shared_loop_pair_merge_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -426,12 +471,14 @@ divergent def list_nth_shared_loop_pair_merge_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_loop_pair_merge]: forward function -/ +/- [loops::list_nth_shared_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 241:0-245:19 -/ def list_nth_shared_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_shared_loop_pair_merge_loop T ls0 ls1 i -/- [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function -/ +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 259:0-274:1 -/ divergent def list_nth_mut_shared_loop_pair_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -447,12 +494,14 @@ divergent def list_nth_mut_shared_loop_pair_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_shared_loop_pair]: forward function -/ +/- [loops::list_nth_mut_shared_loop_pair]: forward function + Source: 'src/loops.rs', lines 259:0-263:23 -/ def list_nth_mut_shared_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_mut_shared_loop_pair_loop T ls0 ls1 i -/- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 -/ +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 259:0-274:1 -/ divergent def list_nth_mut_shared_loop_pair_loop_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) @@ -472,14 +521,16 @@ divergent def list_nth_mut_shared_loop_pair_loop_back | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_shared_loop_pair]: backward function 0 -/ +/- [loops::list_nth_mut_shared_loop_pair]: backward function 0 + Source: 'src/loops.rs', lines 259:0-263:23 -/ def list_nth_mut_shared_loop_pair_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) := list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret0 -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function -/ +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 278:0-293:1 -/ divergent def list_nth_mut_shared_loop_pair_merge_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -495,12 +546,14 @@ divergent def list_nth_mut_shared_loop_pair_merge_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_shared_loop_pair_merge]: forward function -/ +/- [loops::list_nth_mut_shared_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 278:0-282:23 -/ def list_nth_mut_shared_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 -/ +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 278:0-293:1 -/ divergent def list_nth_mut_shared_loop_pair_merge_loop_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) @@ -520,14 +573,16 @@ divergent def list_nth_mut_shared_loop_pair_merge_loop_back | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 -/ +/- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 278:0-282:23 -/ def list_nth_mut_shared_loop_pair_merge_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) := list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret0 -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function -/ +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function + Source: 'src/loops.rs', lines 297:0-312:1 -/ divergent def list_nth_shared_mut_loop_pair_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -543,12 +598,14 @@ divergent def list_nth_shared_mut_loop_pair_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_mut_loop_pair]: forward function -/ +/- [loops::list_nth_shared_mut_loop_pair]: forward function + Source: 'src/loops.rs', lines 297:0-301:23 -/ def list_nth_shared_mut_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_shared_mut_loop_pair_loop T ls0 ls1 i -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 -/ +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 + Source: 'src/loops.rs', lines 297:0-312:1 -/ divergent def list_nth_shared_mut_loop_pair_loop_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) @@ -568,14 +625,16 @@ divergent def list_nth_shared_mut_loop_pair_loop_back | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_mut_loop_pair]: backward function 1 -/ +/- [loops::list_nth_shared_mut_loop_pair]: backward function 1 + Source: 'src/loops.rs', lines 297:0-301:23 -/ def list_nth_shared_mut_loop_pair_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) := list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret0 -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function -/ +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function + Source: 'src/loops.rs', lines 316:0-331:1 -/ divergent def list_nth_shared_mut_loop_pair_merge_loop (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := match ls0 with @@ -591,12 +650,14 @@ divergent def list_nth_shared_mut_loop_pair_merge_loop | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_mut_loop_pair_merge]: forward function -/ +/- [loops::list_nth_shared_mut_loop_pair_merge]: forward function + Source: 'src/loops.rs', lines 316:0-320:23 -/ def list_nth_shared_mut_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 -/ +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 + Source: 'src/loops.rs', lines 316:0-331:1 -/ divergent def list_nth_shared_mut_loop_pair_merge_loop_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) @@ -616,7 +677,8 @@ divergent def list_nth_shared_mut_loop_pair_merge_loop_back | List.Nil => Result.fail Error.panic | List.Nil => Result.fail Error.panic -/- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 -/ +/- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 + Source: 'src/loops.rs', lines 316:0-320:23 -/ def list_nth_shared_mut_loop_pair_merge_back (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : Result (List T) diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index 79049837..3b1c3f9f 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -5,78 +5,96 @@ open Primitives namespace no_nested_borrows -/- [no_nested_borrows::Pair] -/ +/- [no_nested_borrows::Pair] + Source: 'src/no_nested_borrows.rs', lines 4:0-4:23 -/ structure Pair (T1 T2 : Type) where x : T1 y : T2 -/- [no_nested_borrows::List] -/ +/- [no_nested_borrows::List] + Source: 'src/no_nested_borrows.rs', lines 9:0-9:16 -/ inductive List (T : Type) := | Cons : T → List T → List T | Nil : List T -/- [no_nested_borrows::One] -/ +/- [no_nested_borrows::One] + Source: 'src/no_nested_borrows.rs', lines 20:0-20:16 -/ inductive One (T1 : Type) := | One : T1 → One T1 -/- [no_nested_borrows::EmptyEnum] -/ +/- [no_nested_borrows::EmptyEnum] + Source: 'src/no_nested_borrows.rs', lines 26:0-26:18 -/ inductive EmptyEnum := | Empty : EmptyEnum -/- [no_nested_borrows::Enum] -/ +/- [no_nested_borrows::Enum] + Source: 'src/no_nested_borrows.rs', lines 32:0-32:13 -/ inductive Enum := | Variant1 : Enum | Variant2 : Enum -/- [no_nested_borrows::EmptyStruct] -/ +/- [no_nested_borrows::EmptyStruct] + Source: 'src/no_nested_borrows.rs', lines 39:0-39:22 -/ structure EmptyStruct where -/- [no_nested_borrows::Sum] -/ +/- [no_nested_borrows::Sum] + Source: 'src/no_nested_borrows.rs', lines 41:0-41:20 -/ inductive Sum (T1 T2 : Type) := | Left : T1 → Sum T1 T2 | Right : T2 → Sum T1 T2 -/- [no_nested_borrows::neg_test]: forward function -/ +/- [no_nested_borrows::neg_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 48:0-48:30 -/ def neg_test (x : I32) : Result I32 := - x -/- [no_nested_borrows::add_test]: forward function -/ +/- [no_nested_borrows::add_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 54:0-54:38 -/ def add_test (x : U32) (y : U32) : Result U32 := x + y -/- [no_nested_borrows::subs_test]: forward function -/ +/- [no_nested_borrows::subs_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 60:0-60:39 -/ def subs_test (x : U32) (y : U32) : Result U32 := x - y -/- [no_nested_borrows::div_test]: forward function -/ +/- [no_nested_borrows::div_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 66:0-66:38 -/ def div_test (x : U32) (y : U32) : Result U32 := x / y -/- [no_nested_borrows::div_test1]: forward function -/ +/- [no_nested_borrows::div_test1]: forward function + Source: 'src/no_nested_borrows.rs', lines 73:0-73:31 -/ def div_test1 (x : U32) : Result U32 := x / 2#u32 -/- [no_nested_borrows::rem_test]: forward function -/ +/- [no_nested_borrows::rem_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 78:0-78:38 -/ def rem_test (x : U32) (y : U32) : Result U32 := x % y -/- [no_nested_borrows::mul_test]: forward function -/ +/- [no_nested_borrows::mul_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 82:0-82:38 -/ def mul_test (x : U32) (y : U32) : Result U32 := x * y -/- [no_nested_borrows::CONST0] -/ +/- [no_nested_borrows::CONST0] + Source: 'src/no_nested_borrows.rs', lines 91:0-91:23 -/ def const0_body : Result Usize := 1#usize + 1#usize def const0_c : Usize := eval_global const0_body (by simp) -/- [no_nested_borrows::CONST1] -/ +/- [no_nested_borrows::CONST1] + Source: 'src/no_nested_borrows.rs', lines 92:0-92:23 -/ def const1_body : Result Usize := 2#usize * 2#usize def const1_c : Usize := eval_global const1_body (by simp) -/- [no_nested_borrows::cast_test]: forward function -/ +/- [no_nested_borrows::cast_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 94:0-94:31 -/ def cast_test (x : U32) : Result I32 := Scalar.cast .I32 x -/- [no_nested_borrows::test2]: forward function -/ +/- [no_nested_borrows::test2]: forward function + Source: 'src/no_nested_borrows.rs', lines 99:0-99:14 -/ def test2 : Result Unit := do let _ ← 23#u32 + 44#u32 @@ -85,13 +103,15 @@ def test2 : Result Unit := /- Unit test for [no_nested_borrows::test2] -/ #assert (test2 == .ret ()) -/- [no_nested_borrows::get_max]: forward function -/ +/- [no_nested_borrows::get_max]: forward function + Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 -/ def get_max (x : U32) (y : U32) : Result U32 := if x >= y then Result.ret x else Result.ret y -/- [no_nested_borrows::test3]: forward function -/ +/- [no_nested_borrows::test3]: forward function + Source: 'src/no_nested_borrows.rs', lines 119:0-119:14 -/ def test3 : Result Unit := do let x ← get_max 4#u32 3#u32 @@ -104,7 +124,8 @@ def test3 : Result Unit := /- Unit test for [no_nested_borrows::test3] -/ #assert (test3 == .ret ()) -/- [no_nested_borrows::test_neg1]: forward function -/ +/- [no_nested_borrows::test_neg1]: forward function + Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 -/ def test_neg1 : Result Unit := do let y ← - 3#i32 @@ -115,7 +136,8 @@ def test_neg1 : Result Unit := /- Unit test for [no_nested_borrows::test_neg1] -/ #assert (test_neg1 == .ret ()) -/- [no_nested_borrows::refs_test1]: forward function -/ +/- [no_nested_borrows::refs_test1]: forward function + Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 -/ def refs_test1 : Result Unit := if not (1#i32 = 1#i32) then Result.fail Error.panic @@ -124,7 +146,8 @@ def refs_test1 : Result Unit := /- Unit test for [no_nested_borrows::refs_test1] -/ #assert (refs_test1 == .ret ()) -/- [no_nested_borrows::refs_test2]: forward function -/ +/- [no_nested_borrows::refs_test2]: forward function + Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 -/ def refs_test2 : Result Unit := if not (2#i32 = 2#i32) then Result.fail Error.panic @@ -142,14 +165,16 @@ def refs_test2 : Result Unit := /- Unit test for [no_nested_borrows::refs_test2] -/ #assert (refs_test2 == .ret ()) -/- [no_nested_borrows::test_list1]: forward function -/ +/- [no_nested_borrows::test_list1]: forward function + Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 -/ def test_list1 : Result Unit := Result.ret () /- Unit test for [no_nested_borrows::test_list1] -/ #assert (test_list1 == .ret ()) -/- [no_nested_borrows::test_box1]: forward function -/ +/- [no_nested_borrows::test_box1]: forward function + Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 -/ def test_box1 : Result Unit := do let b := 0#i32 @@ -162,23 +187,27 @@ def test_box1 : Result Unit := /- Unit test for [no_nested_borrows::test_box1] -/ #assert (test_box1 == .ret ()) -/- [no_nested_borrows::copy_int]: forward function -/ +/- [no_nested_borrows::copy_int]: forward function + Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 -/ def copy_int (x : I32) : Result I32 := Result.ret x -/- [no_nested_borrows::test_unreachable]: forward function -/ +/- [no_nested_borrows::test_unreachable]: forward function + Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 -/ def test_unreachable (b : Bool) : Result Unit := if b then Result.fail Error.panic else Result.ret () -/- [no_nested_borrows::test_panic]: forward function -/ +/- [no_nested_borrows::test_panic]: forward function + Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 -/ def test_panic (b : Bool) : Result Unit := if b then Result.fail Error.panic else Result.ret () -/- [no_nested_borrows::test_copy_int]: forward function -/ +/- [no_nested_borrows::test_copy_int]: forward function + Source: 'src/no_nested_borrows.rs', lines 196:0-196:22 -/ def test_copy_int : Result Unit := do let y ← copy_int 0#i32 @@ -189,13 +218,15 @@ def test_copy_int : Result Unit := /- Unit test for [no_nested_borrows::test_copy_int] -/ #assert (test_copy_int == .ret ()) -/- [no_nested_borrows::is_cons]: forward function -/ +/- [no_nested_borrows::is_cons]: forward function + Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 -/ def is_cons (T : Type) (l : List T) : Result Bool := match l with | List.Cons t l0 => Result.ret true | List.Nil => Result.ret false -/- [no_nested_borrows::test_is_cons]: forward function -/ +/- [no_nested_borrows::test_is_cons]: forward function + Source: 'src/no_nested_borrows.rs', lines 210:0-210:21 -/ def test_is_cons : Result Unit := do let l := List.Nil @@ -207,13 +238,15 @@ def test_is_cons : Result Unit := /- Unit test for [no_nested_borrows::test_is_cons] -/ #assert (test_is_cons == .ret ()) -/- [no_nested_borrows::split_list]: forward function -/ +/- [no_nested_borrows::split_list]: forward function + Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 -/ def split_list (T : Type) (l : List T) : Result (T × (List T)) := match l with | List.Cons hd tl => Result.ret (hd, tl) | List.Nil => Result.fail Error.panic -/- [no_nested_borrows::test_split_list]: forward function -/ +/- [no_nested_borrows::test_split_list]: forward function + Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 -/ def test_split_list : Result Unit := do let l := List.Nil @@ -226,20 +259,23 @@ def test_split_list : Result Unit := /- Unit test for [no_nested_borrows::test_split_list] -/ #assert (test_split_list == .ret ()) -/- [no_nested_borrows::choose]: forward function -/ +/- [no_nested_borrows::choose]: forward function + Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 -/ def choose (T : Type) (b : Bool) (x : T) (y : T) : Result T := if b then Result.ret x else Result.ret y -/- [no_nested_borrows::choose]: backward function 0 -/ +/- [no_nested_borrows::choose]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 -/ def choose_back (T : Type) (b : Bool) (x : T) (y : T) (ret0 : T) : Result (T × T) := if b then Result.ret (ret0, y) else Result.ret (x, ret0) -/- [no_nested_borrows::choose_test]: forward function -/ +/- [no_nested_borrows::choose_test]: forward function + Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 -/ def choose_test : Result Unit := do let z ← choose I32 true 0#i32 0#i32 @@ -258,25 +294,29 @@ def choose_test : Result Unit := /- Unit test for [no_nested_borrows::choose_test] -/ #assert (choose_test == .ret ()) -/- [no_nested_borrows::test_char]: forward function -/ +/- [no_nested_borrows::test_char]: forward function + Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 -/ def test_char : Result Char := Result.ret 'a' mutual -/- [no_nested_borrows::Tree] -/ +/- [no_nested_borrows::Tree] + Source: 'src/no_nested_borrows.rs', lines 256:0-256:16 -/ inductive Tree (T : Type) := | Leaf : T → Tree T | Node : T → NodeElem T → Tree T → Tree T -/- [no_nested_borrows::NodeElem] -/ +/- [no_nested_borrows::NodeElem] + Source: 'src/no_nested_borrows.rs', lines 261:0-261:20 -/ inductive NodeElem (T : Type) := | Cons : Tree T → NodeElem T → NodeElem T | Nil : NodeElem T end -/- [no_nested_borrows::list_length]: forward function -/ +/- [no_nested_borrows::list_length]: forward function + Source: 'src/no_nested_borrows.rs', lines 296:0-296:48 -/ divergent def list_length (T : Type) (l : List T) : Result U32 := match l with | List.Cons t l1 => do @@ -284,7 +324,8 @@ divergent def list_length (T : Type) (l : List T) : Result U32 := 1#u32 + i | List.Nil => Result.ret 0#u32 -/- [no_nested_borrows::list_nth_shared]: forward function -/ +/- [no_nested_borrows::list_nth_shared]: forward function + Source: 'src/no_nested_borrows.rs', lines 304:0-304:62 -/ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => @@ -295,7 +336,8 @@ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := list_nth_shared T tl i0 | List.Nil => Result.fail Error.panic -/- [no_nested_borrows::list_nth_mut]: forward function -/ +/- [no_nested_borrows::list_nth_mut]: forward function + Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 -/ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => @@ -306,7 +348,8 @@ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := list_nth_mut T tl i0 | List.Nil => Result.fail Error.panic -/- [no_nested_borrows::list_nth_mut]: backward function 0 -/ +/- [no_nested_borrows::list_nth_mut]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 -/ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := match l with @@ -320,7 +363,8 @@ divergent def list_nth_mut_back Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic -/- [no_nested_borrows::list_rev_aux]: forward function -/ +/- [no_nested_borrows::list_rev_aux]: forward function + Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 -/ divergent def list_rev_aux (T : Type) (li : List T) (lo : List T) : Result (List T) := match li with @@ -328,12 +372,14 @@ divergent def list_rev_aux | List.Nil => Result.ret lo /- [no_nested_borrows::list_rev]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/no_nested_borrows.rs', lines 350:0-350:42 -/ def list_rev (T : Type) (l : List T) : Result (List T) := let li := core.mem.replace (List T) l List.Nil list_rev_aux T li List.Nil -/- [no_nested_borrows::test_list_functions]: forward function -/ +/- [no_nested_borrows::test_list_functions]: forward function + Source: 'src/no_nested_borrows.rs', lines 355:0-355:28 -/ def test_list_functions : Result Unit := do let l := List.Nil @@ -379,81 +425,98 @@ def test_list_functions : Result Unit := /- Unit test for [no_nested_borrows::test_list_functions] -/ #assert (test_list_functions == .ret ()) -/- [no_nested_borrows::id_mut_pair1]: forward function -/ +/- [no_nested_borrows::id_mut_pair1]: forward function + Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 -/ def id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : Result (T1 × T2) := Result.ret (x, y) -/- [no_nested_borrows::id_mut_pair1]: backward function 0 -/ +/- [no_nested_borrows::id_mut_pair1]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 -/ def id_mut_pair1_back (T1 T2 : Type) (x : T1) (y : T2) (ret0 : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := ret0 Result.ret (t, t0) -/- [no_nested_borrows::id_mut_pair2]: forward function -/ +/- [no_nested_borrows::id_mut_pair2]: forward function + Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 -/ def id_mut_pair2 (T1 T2 : Type) (p : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := p Result.ret (t, t0) -/- [no_nested_borrows::id_mut_pair2]: backward function 0 -/ +/- [no_nested_borrows::id_mut_pair2]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 -/ def id_mut_pair2_back (T1 T2 : Type) (p : (T1 × T2)) (ret0 : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := ret0 Result.ret (t, t0) -/- [no_nested_borrows::id_mut_pair3]: forward function -/ +/- [no_nested_borrows::id_mut_pair3]: forward function + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ def id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : Result (T1 × T2) := Result.ret (x, y) -/- [no_nested_borrows::id_mut_pair3]: backward function 0 -/ +/- [no_nested_borrows::id_mut_pair3]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ def id_mut_pair3_back'a (T1 T2 : Type) (x : T1) (y : T2) (ret0 : T1) : Result T1 := Result.ret ret0 -/- [no_nested_borrows::id_mut_pair3]: backward function 1 -/ +/- [no_nested_borrows::id_mut_pair3]: backward function 1 + Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ def id_mut_pair3_back'b (T1 T2 : Type) (x : T1) (y : T2) (ret0 : T2) : Result T2 := Result.ret ret0 -/- [no_nested_borrows::id_mut_pair4]: forward function -/ +/- [no_nested_borrows::id_mut_pair4]: forward function + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ def id_mut_pair4 (T1 T2 : Type) (p : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := p Result.ret (t, t0) -/- [no_nested_borrows::id_mut_pair4]: backward function 0 -/ +/- [no_nested_borrows::id_mut_pair4]: backward function 0 + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ def id_mut_pair4_back'a (T1 T2 : Type) (p : (T1 × T2)) (ret0 : T1) : Result T1 := Result.ret ret0 -/- [no_nested_borrows::id_mut_pair4]: backward function 1 -/ +/- [no_nested_borrows::id_mut_pair4]: backward function 1 + Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ def id_mut_pair4_back'b (T1 T2 : Type) (p : (T1 × T2)) (ret0 : T2) : Result T2 := Result.ret ret0 -/- [no_nested_borrows::StructWithTuple] -/ +/- [no_nested_borrows::StructWithTuple] + Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 -/ structure StructWithTuple (T1 T2 : Type) where p : (T1 × T2) -/- [no_nested_borrows::new_tuple1]: forward function -/ +/- [no_nested_borrows::new_tuple1]: forward function + Source: 'src/no_nested_borrows.rs', lines 394:0-394:48 -/ def new_tuple1 : Result (StructWithTuple U32 U32) := Result.ret { p := (1#u32, 2#u32) } -/- [no_nested_borrows::new_tuple2]: forward function -/ +/- [no_nested_borrows::new_tuple2]: forward function + Source: 'src/no_nested_borrows.rs', lines 398:0-398:48 -/ def new_tuple2 : Result (StructWithTuple I16 I16) := Result.ret { p := (1#i16, 2#i16) } -/- [no_nested_borrows::new_tuple3]: forward function -/ +/- [no_nested_borrows::new_tuple3]: forward function + Source: 'src/no_nested_borrows.rs', lines 402:0-402:48 -/ def new_tuple3 : Result (StructWithTuple U64 I64) := Result.ret { p := (1#u64, 2#i64) } -/- [no_nested_borrows::StructWithPair] -/ +/- [no_nested_borrows::StructWithPair] + Source: 'src/no_nested_borrows.rs', lines 407:0-407:33 -/ structure StructWithPair (T1 T2 : Type) where p : Pair T1 T2 -/- [no_nested_borrows::new_pair1]: forward function -/ +/- [no_nested_borrows::new_pair1]: forward function + Source: 'src/no_nested_borrows.rs', lines 411:0-411:46 -/ def new_pair1 : Result (StructWithPair U32 U32) := Result.ret { p := { x := 1#u32, y := 2#u32 } } -/- [no_nested_borrows::test_constants]: forward function -/ +/- [no_nested_borrows::test_constants]: forward function + Source: 'src/no_nested_borrows.rs', lines 419:0-419:23 -/ def test_constants : Result Unit := do let swt ← new_tuple1 @@ -482,7 +545,8 @@ def test_constants : Result Unit := /- Unit test for [no_nested_borrows::test_constants] -/ #assert (test_constants == .ret ()) -/- [no_nested_borrows::test_weird_borrows1]: forward function -/ +/- [no_nested_borrows::test_weird_borrows1]: forward function + Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 -/ def test_weird_borrows1 : Result Unit := Result.ret () @@ -490,30 +554,35 @@ def test_weird_borrows1 : Result Unit := #assert (test_weird_borrows1 == .ret ()) /- [no_nested_borrows::test_mem_replace]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/no_nested_borrows.rs', lines 438:0-438:37 -/ def test_mem_replace (px : U32) : Result U32 := let y := core.mem.replace U32 px 1#u32 if not (y = 0#u32) then Result.fail Error.panic else Result.ret 2#u32 -/- [no_nested_borrows::test_shared_borrow_bool1]: forward function -/ +/- [no_nested_borrows::test_shared_borrow_bool1]: forward function + Source: 'src/no_nested_borrows.rs', lines 445:0-445:47 -/ def test_shared_borrow_bool1 (b : Bool) : Result U32 := if b then Result.ret 0#u32 else Result.ret 1#u32 -/- [no_nested_borrows::test_shared_borrow_bool2]: forward function -/ +/- [no_nested_borrows::test_shared_borrow_bool2]: forward function + Source: 'src/no_nested_borrows.rs', lines 458:0-458:40 -/ def test_shared_borrow_bool2 : Result U32 := Result.ret 0#u32 -/- [no_nested_borrows::test_shared_borrow_enum1]: forward function -/ +/- [no_nested_borrows::test_shared_borrow_enum1]: forward function + Source: 'src/no_nested_borrows.rs', lines 473:0-473:52 -/ def test_shared_borrow_enum1 (l : List U32) : Result U32 := match l with | List.Cons i l0 => Result.ret 1#u32 | List.Nil => Result.ret 0#u32 -/- [no_nested_borrows::test_shared_borrow_enum2]: forward function -/ +/- [no_nested_borrows::test_shared_borrow_enum2]: forward function + Source: 'src/no_nested_borrows.rs', lines 485:0-485:40 -/ def test_shared_borrow_enum2 : Result U32 := Result.ret 0#u32 diff --git a/tests/lean/Paper.lean b/tests/lean/Paper.lean index ae4dd243..37e0e70e 100644 --- a/tests/lean/Paper.lean +++ b/tests/lean/Paper.lean @@ -6,11 +6,13 @@ open Primitives namespace paper /- [paper::ref_incr]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/paper.rs', lines 4:0-4:28 -/ def ref_incr (x : I32) : Result I32 := x + 1#i32 -/- [paper::test_incr]: forward function -/ +/- [paper::test_incr]: forward function + Source: 'src/paper.rs', lines 8:0-8:18 -/ def test_incr : Result Unit := do let x ← ref_incr 0#i32 @@ -21,20 +23,23 @@ def test_incr : Result Unit := /- Unit test for [paper::test_incr] -/ #assert (test_incr == .ret ()) -/- [paper::choose]: forward function -/ +/- [paper::choose]: forward function + Source: 'src/paper.rs', lines 15:0-15:70 -/ def choose (T : Type) (b : Bool) (x : T) (y : T) : Result T := if b then Result.ret x else Result.ret y -/- [paper::choose]: backward function 0 -/ +/- [paper::choose]: backward function 0 + Source: 'src/paper.rs', lines 15:0-15:70 -/ def choose_back (T : Type) (b : Bool) (x : T) (y : T) (ret0 : T) : Result (T × T) := if b then Result.ret (ret0, y) else Result.ret (x, ret0) -/- [paper::test_choose]: forward function -/ +/- [paper::test_choose]: forward function + Source: 'src/paper.rs', lines 23:0-23:20 -/ def test_choose : Result Unit := do let z ← choose I32 true 0#i32 0#i32 @@ -53,12 +58,14 @@ def test_choose : Result Unit := /- Unit test for [paper::test_choose] -/ #assert (test_choose == .ret ()) -/- [paper::List] -/ +/- [paper::List] + Source: 'src/paper.rs', lines 35:0-35:16 -/ inductive List (T : Type) := | Cons : T → List T → List T | Nil : List T -/- [paper::list_nth_mut]: forward function -/ +/- [paper::list_nth_mut]: forward function + Source: 'src/paper.rs', lines 42:0-42:67 -/ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => @@ -69,7 +76,8 @@ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := list_nth_mut T tl i0 | List.Nil => Result.fail Error.panic -/- [paper::list_nth_mut]: backward function 0 -/ +/- [paper::list_nth_mut]: backward function 0 + Source: 'src/paper.rs', lines 42:0-42:67 -/ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := match l with @@ -83,7 +91,8 @@ divergent def list_nth_mut_back Result.ret (List.Cons x tl0) | List.Nil => Result.fail Error.panic -/- [paper::sum]: forward function -/ +/- [paper::sum]: forward function + Source: 'src/paper.rs', lines 57:0-57:32 -/ divergent def sum (l : List I32) : Result I32 := match l with | List.Cons x tl => do @@ -91,7 +100,8 @@ divergent def sum (l : List I32) : Result I32 := x + i | List.Nil => Result.ret 0#i32 -/- [paper::test_nth]: forward function -/ +/- [paper::test_nth]: forward function + Source: 'src/paper.rs', lines 68:0-68:17 -/ def test_nth : Result Unit := do let l := List.Nil @@ -108,7 +118,8 @@ def test_nth : Result Unit := /- Unit test for [paper::test_nth] -/ #assert (test_nth == .ret ()) -/- [paper::call_choose]: forward function -/ +/- [paper::call_choose]: forward function + Source: 'src/paper.rs', lines 76:0-76:44 -/ def call_choose (p : (U32 × U32)) : Result U32 := do let (px, py) := p diff --git a/tests/lean/PoloniusList.lean b/tests/lean/PoloniusList.lean index 07f206a8..0ef71791 100644 --- a/tests/lean/PoloniusList.lean +++ b/tests/lean/PoloniusList.lean @@ -5,12 +5,14 @@ open Primitives namespace polonius_list -/- [polonius_list::List] -/ +/- [polonius_list::List] + Source: 'src/polonius_list.rs', lines 3:0-3:16 -/ inductive List (T : Type) := | Cons : T → List T → List T | Nil : List T -/- [polonius_list::get_list_at_x]: forward function -/ +/- [polonius_list::get_list_at_x]: forward function + Source: 'src/polonius_list.rs', lines 13:0-13:76 -/ divergent def get_list_at_x (ls : List U32) (x : U32) : Result (List U32) := match ls with | List.Cons hd tl => @@ -19,7 +21,8 @@ divergent def get_list_at_x (ls : List U32) (x : U32) : Result (List U32) := else get_list_at_x tl x | List.Nil => Result.ret List.Nil -/- [polonius_list::get_list_at_x]: backward function 0 -/ +/- [polonius_list::get_list_at_x]: backward function 0 + Source: 'src/polonius_list.rs', lines 13:0-13:76 -/ divergent def get_list_at_x_back (ls : List U32) (x : U32) (ret0 : List U32) : Result (List U32) := match ls with diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index 51a05581..f854da76 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -5,25 +5,30 @@ open Primitives namespace traits -/- Trait declaration: [traits::BoolTrait] -/ +/- Trait declaration: [traits::BoolTrait] + Source: 'src/traits.rs', lines 1:0-1:19 -/ structure BoolTrait (Self : Type) where get_bool : Self → Result Bool -/- [traits::{bool}::get_bool]: forward function -/ +/- [traits::{bool}::get_bool]: forward function + Source: 'src/traits.rs', lines 12:4-12:30 -/ def Bool.get_bool (self : Bool) : Result Bool := Result.ret self -/- Trait implementation: [traits::{bool}] -/ +/- Trait implementation: [traits::{bool}] + Source: 'src/traits.rs', lines 11:0-11:23 -/ def traits.BoolTraitBoolInst : BoolTrait Bool := { get_bool := Bool.get_bool } -/- [traits::BoolTrait::ret_true]: forward function -/ +/- [traits::BoolTrait::ret_true]: forward function + Source: 'src/traits.rs', lines 6:4-6:30 -/ def BoolTrait.ret_true {Self : Type} (self_clause : BoolTrait Self) (self : Self) : Result Bool := Result.ret true -/- [traits::test_bool_trait_bool]: forward function -/ +/- [traits::test_bool_trait_bool]: forward function + Source: 'src/traits.rs', lines 17:0-17:44 -/ def test_bool_trait_bool (x : Bool) : Result Bool := do let b ← Bool.get_bool x @@ -31,19 +36,22 @@ def test_bool_trait_bool (x : Bool) : Result Bool := then BoolTrait.ret_true traits.BoolTraitBoolInst x else Result.ret false -/- [traits::{core::option::Option#1}::get_bool]: forward function -/ +/- [traits::{core::option::Option#1}::get_bool]: forward function + Source: 'src/traits.rs', lines 23:4-23:30 -/ def Option.get_bool (T : Type) (self : Option T) : Result Bool := match self with | none => Result.ret false | some t => Result.ret true -/- Trait implementation: [traits::{core::option::Option#1}] -/ +/- Trait implementation: [traits::{core::option::Option#1}] + Source: 'src/traits.rs', lines 22:0-22:31 -/ def traits.BoolTraitcoreoptionOptionTInst (T : Type) : BoolTrait (Option T) := { get_bool := Option.get_bool T } -/- [traits::test_bool_trait_option]: forward function -/ +/- [traits::test_bool_trait_option]: forward function + Source: 'src/traits.rs', lines 31:0-31:54 -/ def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := do let b ← Option.get_bool T x @@ -51,24 +59,29 @@ def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := then BoolTrait.ret_true (traits.BoolTraitcoreoptionOptionTInst T) x else Result.ret false -/- [traits::test_bool_trait]: forward function -/ +/- [traits::test_bool_trait]: forward function + Source: 'src/traits.rs', lines 35:0-35:50 -/ def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := inst.get_bool x -/- Trait declaration: [traits::ToU64] -/ +/- Trait declaration: [traits::ToU64] + Source: 'src/traits.rs', lines 39:0-39:15 -/ structure ToU64 (Self : Type) where to_u64 : Self → Result U64 -/- [traits::{u64#2}::to_u64]: forward function -/ +/- [traits::{u64#2}::to_u64]: forward function + Source: 'src/traits.rs', lines 44:4-44:26 -/ def U64.to_u64 (self : U64) : Result U64 := Result.ret self -/- Trait implementation: [traits::{u64#2}] -/ +/- Trait implementation: [traits::{u64#2}] + Source: 'src/traits.rs', lines 43:0-43:18 -/ def traits.ToU64U64Inst : ToU64 U64 := { to_u64 := U64.to_u64 } -/- [traits::{(A, A)#3}::to_u64]: forward function -/ +/- [traits::{(A, A)#3}::to_u64]: forward function + Source: 'src/traits.rs', lines 50:4-50:26 -/ def Pair.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := do let (t, t0) := self @@ -76,106 +89,128 @@ def Pair.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := let i0 ← inst.to_u64 t0 i + i0 -/- Trait implementation: [traits::{(A, A)#3}] -/ +/- Trait implementation: [traits::{(A, A)#3}] + Source: 'src/traits.rs', lines 49:0-49:31 -/ def traits.ToU64TupleAAInst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { to_u64 := Pair.to_u64 A inst } -/- [traits::f]: forward function -/ +/- [traits::f]: forward function + Source: 'src/traits.rs', lines 55:0-55:36 -/ def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := Pair.to_u64 T inst x -/- [traits::g]: forward function -/ +/- [traits::g]: forward function + Source: 'src/traits.rs', lines 59:0-61:18 -/ def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := inst.to_u64 x -/- [traits::h0]: forward function -/ +/- [traits::h0]: forward function + Source: 'src/traits.rs', lines 66:0-66:24 -/ def h0 (x : U64) : Result U64 := U64.to_u64 x -/- [traits::Wrapper] -/ +/- [traits::Wrapper] + Source: 'src/traits.rs', lines 70:0-70:21 -/ structure Wrapper (T : Type) where x : T -/- [traits::{traits::Wrapper#4}::to_u64]: forward function -/ +/- [traits::{traits::Wrapper#4}::to_u64]: forward function + Source: 'src/traits.rs', lines 75:4-75:26 -/ def Wrapper.to_u64 (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := inst.to_u64 self.x -/- Trait implementation: [traits::{traits::Wrapper#4}] -/ +/- Trait implementation: [traits::{traits::Wrapper#4}] + Source: 'src/traits.rs', lines 74:0-74:35 -/ def traits.ToU64traitsWrapperTInst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper T) := { to_u64 := Wrapper.to_u64 T inst } -/- [traits::h1]: forward function -/ +/- [traits::h1]: forward function + Source: 'src/traits.rs', lines 80:0-80:33 -/ def h1 (x : Wrapper U64) : Result U64 := Wrapper.to_u64 U64 traits.ToU64U64Inst x -/- [traits::h2]: forward function -/ +/- [traits::h2]: forward function + Source: 'src/traits.rs', lines 84:0-84:41 -/ def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := Wrapper.to_u64 T inst x -/- Trait declaration: [traits::ToType] -/ +/- Trait declaration: [traits::ToType] + Source: 'src/traits.rs', lines 88:0-88:19 -/ structure ToType (Self T : Type) where to_type : Self → Result T -/- [traits::{u64#5}::to_type]: forward function -/ +/- [traits::{u64#5}::to_type]: forward function + Source: 'src/traits.rs', lines 93:4-93:28 -/ def U64.to_type (self : U64) : Result Bool := Result.ret (self > 0#u64) -/- Trait implementation: [traits::{u64#5}] -/ +/- Trait implementation: [traits::{u64#5}] + Source: 'src/traits.rs', lines 92:0-92:25 -/ def traits.ToTypeU64BoolInst : ToType U64 Bool := { to_type := U64.to_type } -/- Trait declaration: [traits::OfType] -/ +/- Trait declaration: [traits::OfType] + Source: 'src/traits.rs', lines 98:0-98:16 -/ structure OfType (Self : Type) where of_type : forall (T : Type) (inst : ToType T Self), T → Result Self -/- [traits::h3]: forward function -/ +/- [traits::h3]: forward function + Source: 'src/traits.rs', lines 104:0-104:50 -/ def h3 (T1 T2 : Type) (inst : OfType T1) (inst0 : ToType T2 T1) (y : T2) : Result T1 := inst.of_type T2 inst0 y -/- Trait declaration: [traits::OfTypeBis] -/ +/- Trait declaration: [traits::OfTypeBis] + Source: 'src/traits.rs', lines 109:0-109:36 -/ structure OfTypeBis (Self T : Type) where parent_clause_0 : ToType T Self of_type : T → Result Self -/- [traits::h4]: forward function -/ +/- [traits::h4]: forward function + Source: 'src/traits.rs', lines 118:0-118:57 -/ def h4 (T1 T2 : Type) (inst : OfTypeBis T1 T2) (inst0 : ToType T2 T1) (y : T2) : Result T1 := inst.of_type y -/- [traits::TestType] -/ +/- [traits::TestType] + Source: 'src/traits.rs', lines 122:0-122:22 -/ structure TestType (T : Type) where _0 : T -/- [traits::{traits::TestType#6}::test::TestType1] -/ +/- [traits::{traits::TestType#6}::test::TestType1] + Source: 'src/traits.rs', lines 127:8-127:24 -/ structure TestType.test.TestType1 where _0 : U64 -/- Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] -/ +/- Trait declaration: [traits::{traits::TestType#6}::test::TestTrait] + Source: 'src/traits.rs', lines 128:8-128:23 -/ structure TestType.test.TestTrait (Self : Type) where test : Self → Result Bool -/- [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function -/ +/- [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}::test]: forward function + Source: 'src/traits.rs', lines 139:12-139:34 -/ def TestType.test.TestType1.test (self : TestType.test.TestType1) : Result Bool := Result.ret (self._0 > 1#u64) -/- Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] -/ +/- Trait implementation: [traits::{traits::TestType#6}::test::{traits::{traits::TestType#6}::test::TestType1}] + Source: 'src/traits.rs', lines 138:8-138:36 -/ def traits.TestType.test.TestTraittraitstraitsTestTypeTtestTestType1Inst : TestType.test.TestTrait TestType.test.TestType1 := { test := TestType.test.TestType1.test } -/- [traits::{traits::TestType#6}::test]: forward function -/ +/- [traits::{traits::TestType#6}::test]: forward function + Source: 'src/traits.rs', lines 126:4-126:36 -/ def TestType.test (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := do @@ -184,27 +219,32 @@ def TestType.test then TestType.test.TestType1.test { _0 := 0#u64 } else Result.ret false -/- [traits::BoolWrapper] -/ +/- [traits::BoolWrapper] + Source: 'src/traits.rs', lines 150:0-150:22 -/ structure BoolWrapper where _0 : Bool -/- [traits::{traits::BoolWrapper#7}::to_type]: forward function -/ +/- [traits::{traits::BoolWrapper#7}::to_type]: forward function + Source: 'src/traits.rs', lines 156:4-156:25 -/ def BoolWrapper.to_type (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := inst.to_type self._0 -/- Trait implementation: [traits::{traits::BoolWrapper#7}] -/ +/- Trait implementation: [traits::{traits::BoolWrapper#7}] + Source: 'src/traits.rs', lines 152:0-152:33 -/ def traits.ToTypetraitsBoolWrapperTInst (T : Type) (inst : ToType Bool T) : ToType BoolWrapper T := { to_type := BoolWrapper.to_type T inst } -/- [traits::WithConstTy::LEN2] -/ +/- [traits::WithConstTy::LEN2] + Source: 'src/traits.rs', lines 164:4-164:21 -/ def with_const_ty_len2_body : Result Usize := Result.ret 32#usize def with_const_ty_len2_c : Usize := eval_global with_const_ty_len2_body (by simp) -/- Trait declaration: [traits::WithConstTy] -/ +/- Trait declaration: [traits::WithConstTy] + Source: 'src/traits.rs', lines 161:0-161:39 -/ structure WithConstTy (Self : Type) (LEN : Usize) where LEN1 : Usize LEN2 : Usize @@ -213,16 +253,19 @@ structure WithConstTy (Self : Type) (LEN : Usize) where W_clause_0 : ToU64 W f : W → Array U8 LEN → Result W -/- [traits::{bool#8}::LEN1] -/ +/- [traits::{bool#8}::LEN1] + Source: 'src/traits.rs', lines 175:4-175:21 -/ def bool_len1_body : Result Usize := Result.ret 12#usize def bool_len1_c : Usize := eval_global bool_len1_body (by simp) /- [traits::{bool#8}::f]: merged forward/backward function - (there is a single backward function, and the forward function returns ()) -/ + (there is a single backward function, and the forward function returns ()) + Source: 'src/traits.rs', lines 180:4-180:39 -/ def Bool.f (i : U64) (a : Array U8 32#usize) : Result U64 := Result.ret i -/- Trait implementation: [traits::{bool#8}] -/ +/- Trait implementation: [traits::{bool#8}] + Source: 'src/traits.rs', lines 174:0-174:29 -/ def traits.WithConstTyBool32Inst : WithConstTy Bool 32#usize := { LEN1 := bool_len1_c LEN2 := with_const_ty_len2_c @@ -232,153 +275,183 @@ def traits.WithConstTyBool32Inst : WithConstTy Bool 32#usize := { f := Bool.f } -/- [traits::use_with_const_ty1]: forward function -/ +/- [traits::use_with_const_ty1]: forward function + Source: 'src/traits.rs', lines 183:0-183:75 -/ def use_with_const_ty1 (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) : Result Usize := let i := inst.LEN1 Result.ret i -/- [traits::use_with_const_ty2]: forward function -/ +/- [traits::use_with_const_ty2]: forward function + Source: 'src/traits.rs', lines 187:0-187:73 -/ def use_with_const_ty2 (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (w : inst.W) : Result Unit := Result.ret () -/- [traits::use_with_const_ty3]: forward function -/ +/- [traits::use_with_const_ty3]: forward function + Source: 'src/traits.rs', lines 189:0-189:80 -/ def use_with_const_ty3 (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (x : inst.W) : Result U64 := inst.W_clause_0.to_u64 x -/- [traits::test_where1]: forward function -/ +/- [traits::test_where1]: forward function + Source: 'src/traits.rs', lines 193:0-193:40 -/ def test_where1 (T : Type) (_x : T) : Result Unit := Result.ret () -/- [traits::test_where2]: forward function -/ +/- [traits::test_where2]: forward function + Source: 'src/traits.rs', lines 194:0-194:57 -/ def test_where2 (T : Type) (inst : WithConstTy T 32#usize) (_x : U32) : Result Unit := Result.ret () -/- [alloc::string::String] -/ +/- [alloc::string::String] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/alloc/src/string.rs', lines 365:0-365:17 -/ axiom alloc.string.String : Type -/- Trait declaration: [traits::ParentTrait0] -/ +/- Trait declaration: [traits::ParentTrait0] + Source: 'src/traits.rs', lines 200:0-200:22 -/ structure ParentTrait0 (Self : Type) where W : Type get_name : Self → Result alloc.string.String get_w : Self → Result W -/- Trait declaration: [traits::ParentTrait1] -/ +/- Trait declaration: [traits::ParentTrait1] + Source: 'src/traits.rs', lines 205:0-205:22 -/ structure ParentTrait1 (Self : Type) where -/- Trait declaration: [traits::ChildTrait] -/ +/- Trait declaration: [traits::ChildTrait] + Source: 'src/traits.rs', lines 206:0-206:49 -/ structure ChildTrait (Self : Type) where parent_clause_0 : ParentTrait0 Self parent_clause_1 : ParentTrait1 Self -/- [traits::test_child_trait1]: forward function -/ +/- [traits::test_child_trait1]: forward function + Source: 'src/traits.rs', lines 209:0-209:56 -/ def test_child_trait1 (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := inst.parent_clause_0.get_name x -/- [traits::test_child_trait2]: forward function -/ +/- [traits::test_child_trait2]: forward function + Source: 'src/traits.rs', lines 213:0-213:54 -/ def test_child_trait2 (T : Type) (inst : ChildTrait T) (x : T) : Result inst.parent_clause_0.W := inst.parent_clause_0.get_w x -/- [traits::order1]: forward function -/ +/- [traits::order1]: forward function + Source: 'src/traits.rs', lines 219:0-219:59 -/ def order1 (T U : Type) (inst : ParentTrait0 T) (inst0 : ParentTrait0 U) : Result Unit := Result.ret () -/- Trait declaration: [traits::ChildTrait1] -/ +/- Trait declaration: [traits::ChildTrait1] + Source: 'src/traits.rs', lines 222:0-222:35 -/ structure ChildTrait1 (Self : Type) where parent_clause_0 : ParentTrait1 Self -/- Trait implementation: [traits::{usize#9}] -/ +/- Trait implementation: [traits::{usize#9}] + Source: 'src/traits.rs', lines 224:0-224:27 -/ def traits.ParentTrait1UsizeInst : ParentTrait1 Usize := { } -/- Trait implementation: [traits::{usize#10}] -/ +/- Trait implementation: [traits::{usize#10}] + Source: 'src/traits.rs', lines 225:0-225:26 -/ def traits.ChildTrait1UsizeInst : ChildTrait1 Usize := { parent_clause_0 := traits.ParentTrait1UsizeInst } -/- Trait declaration: [traits::Iterator] -/ +/- Trait declaration: [traits::Iterator] + Source: 'src/traits.rs', lines 229:0-229:18 -/ structure Iterator (Self : Type) where Item : Type -/- Trait declaration: [traits::IntoIterator] -/ +/- Trait declaration: [traits::IntoIterator] + Source: 'src/traits.rs', lines 233:0-233:22 -/ structure IntoIterator (Self : Type) where Item : Type IntoIter : Type IntoIter_clause_0 : Iterator IntoIter into_iter : Self → Result IntoIter -/- Trait declaration: [traits::FromResidual] -/ +/- Trait declaration: [traits::FromResidual] + Source: 'src/traits.rs', lines 250:0-250:21 -/ structure FromResidual (Self T : Type) where -/- Trait declaration: [traits::Try] -/ +/- Trait declaration: [traits::Try] + Source: 'src/traits.rs', lines 246:0-246:48 -/ structure Try (Self : Type) where Residual : Type parent_clause_0 : FromResidual Self Residual -/- Trait declaration: [traits::WithTarget] -/ +/- Trait declaration: [traits::WithTarget] + Source: 'src/traits.rs', lines 252:0-252:20 -/ structure WithTarget (Self : Type) where Target : Type -/- Trait declaration: [traits::ParentTrait2] -/ +/- Trait declaration: [traits::ParentTrait2] + Source: 'src/traits.rs', lines 256:0-256:22 -/ structure ParentTrait2 (Self : Type) where U : Type U_clause_0 : WithTarget U -/- Trait declaration: [traits::ChildTrait2] -/ +/- Trait declaration: [traits::ChildTrait2] + Source: 'src/traits.rs', lines 260:0-260:35 -/ structure ChildTrait2 (Self : Type) where parent_clause_0 : ParentTrait2 Self convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target -/- Trait implementation: [traits::{u32#11}] -/ +/- Trait implementation: [traits::{u32#11}] + Source: 'src/traits.rs', lines 264:0-264:23 -/ def traits.WithTargetU32Inst : WithTarget U32 := { Target := U32 } -/- Trait implementation: [traits::{u32#12}] -/ +/- Trait implementation: [traits::{u32#12}] + Source: 'src/traits.rs', lines 268:0-268:25 -/ def traits.ParentTrait2U32Inst : ParentTrait2 U32 := { U := U32 U_clause_0 := traits.WithTargetU32Inst } -/- [traits::{u32#13}::convert]: forward function -/ +/- [traits::{u32#13}::convert]: forward function + Source: 'src/traits.rs', lines 273:4-273:29 -/ def U32.convert (x : U32) : Result U32 := Result.ret x -/- Trait implementation: [traits::{u32#13}] -/ +/- Trait implementation: [traits::{u32#13}] + Source: 'src/traits.rs', lines 272:0-272:24 -/ def traits.ChildTrait2U32Inst : ChildTrait2 U32 := { parent_clause_0 := traits.ParentTrait2U32Inst convert := U32.convert } -/- Trait declaration: [traits::CFnOnce] -/ +/- Trait declaration: [traits::CFnOnce] + Source: 'src/traits.rs', lines 286:0-286:23 -/ structure CFnOnce (Self Args : Type) where Output : Type call_once : Self → Args → Result Output -/- Trait declaration: [traits::CFnMut] -/ +/- Trait declaration: [traits::CFnMut] + Source: 'src/traits.rs', lines 292:0-292:37 -/ structure CFnMut (Self Args : Type) where parent_clause_0 : CFnOnce Self Args call_mut : Self → Args → Result parent_clause_0.Output call_mut_back : Self → Args → parent_clause_0.Output → Result Self -/- Trait declaration: [traits::CFn] -/ +/- Trait declaration: [traits::CFn] + Source: 'src/traits.rs', lines 296:0-296:33 -/ structure CFn (Self Args : Type) where parent_clause_0 : CFnMut Self Args call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output -/- [traits::incr_u32]: forward function -/ +/- [traits::incr_u32]: forward function + Source: 'src/traits.rs', lines 300:0-300:30 -/ def incr_u32 (x : U32) : Result U32 := x + 1#u32 -- cgit v1.2.3 From b916f696c5265dc4f5af4a67b118b005a7ed8612 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 17:24:50 +0100 Subject: Reorganize the "Extract" files --- compiler/Config.ml | 27 + compiler/Extract.ml | 47 +- compiler/ExtractBase.ml | 1643 ++++++++++++++++++++++++++++++-------------- compiler/ExtractBuiltin.ml | 25 +- compiler/ExtractTypes.ml | 980 +++----------------------- compiler/Main.ml | 5 +- compiler/Translate.ml | 19 +- 7 files changed, 1303 insertions(+), 1443 deletions(-) diff --git a/compiler/Config.ml b/compiler/Config.ml index a487f9e2..fe110ee4 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -336,3 +336,30 @@ let type_check_pure_code = 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 + +(** 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 + ]} + *) +let variant_concatenate_type_name = ref true diff --git a/compiler/Extract.ml b/compiler/Extract.ml index d7b4c152..16262c91 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -6,7 +6,6 @@ open Pure open PureUtils open TranslateCore -open ExtractBase open Config include ExtractTypes @@ -236,12 +235,10 @@ let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) (is_let : bool) (inside : bool) (v : typed_pattern) : extraction_ctx = match v.value with | PatConstant cv -> - ctx.fmt.extract_literal fmt inside cv; + extract_literal fmt inside cv; ctx | PatVar (v, _) -> - let vname = - ctx.fmt.var_basename ctx.names_maps.names_map.names_set v.basename v.ty - in + let vname = ctx_compute_var_basename ctx v.basename v.ty in let ctx, vname = ctx_add_var vname v.id ctx in F.pp_print_string fmt vname; ctx @@ -274,7 +271,7 @@ let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) | 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 + | Const cv -> extract_literal fmt inside cv | App _ -> let app, args = destruct_apps e in extract_App ctx fmt inside app args @@ -354,10 +351,10 @@ and extract_function_call (ctx : extraction_ctx) (fmt : F.formatter) * Note that the way we generate the translation, we shouldn't get the * case where we have no argument (all functions are fully instantiated, * and no AST transformation introduces partial calls). *) - ctx.fmt.extract_unop (extract_texpression ctx fmt) fmt inside unop arg + extract_unop (extract_texpression ctx fmt) fmt inside unop arg | Binop (binop, int_ty), [ arg0; arg1 ] -> (* Number of arguments: similar to unop *) - ctx.fmt.extract_binop + extract_binop (extract_texpression ctx fmt) fmt inside binop int_ty arg0 arg1 | Fun fun_id, _ -> @@ -1359,7 +1356,7 @@ let extract_fun_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) is_opaque_coq && def.signature.generics <> empty_generic_params in (* Print the qualifier ("assume", etc.). *) - let qualif = ctx.fmt.fun_decl_kind_to_qualif kind in + let qualif = fun_decl_kind_to_qualif kind in (match qualif with | Some qualif -> F.pp_print_string fmt qualif; @@ -1655,7 +1652,7 @@ let extract_global_decl_body_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Open "QUALIF NAME : TYPE =" box (depth=1) *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print "QUALIF NAME " *) - (match ctx.fmt.fun_decl_kind_to_qualif kind with + (match fun_decl_kind_to_qualif kind with | Some qualif -> F.pp_print_string fmt qualif; F.pp_print_space fmt () @@ -1824,11 +1821,11 @@ let extract_trait_decl_register_parent_clause_names (ctx : extraction_ctx) | None -> List.map (fun (c : trait_clause) -> - let name = ctx.fmt.trait_parent_clause_name trait_decl c in + let name = ctx_compute_trait_parent_clause_name ctx 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 + else ctx_compute_trait_decl_name ctx trait_decl ^ name in (c.clause_id, name)) trait_decl.parent_clauses @@ -1855,11 +1852,11 @@ let extract_trait_decl_register_constant_names (ctx : extraction_ctx) | None -> List.map (fun (item_name, _) -> - let name = ctx.fmt.trait_const_name trait_decl item_name in + let name = ctx_compute_trait_const_name ctx 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 + else ctx_compute_trait_decl_name ctx trait_decl ^ name in (item_name, name)) consts @@ -1887,19 +1884,21 @@ let extract_trait_decl_type_names (ctx : extraction_ctx) 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 + let type_name = + ctx_compute_trait_type_name ctx trait_decl item_name + in if !Config.record_fields_short_names then type_name - else ctx.fmt.trait_decl_name trait_decl ^ type_name + else ctx_compute_trait_decl_name ctx 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 + ctx_compute_trait_type_clause_name ctx 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 + else ctx_compute_trait_decl_name ctx trait_decl ^ name in (clause.clause_id, name) in @@ -1971,7 +1970,7 @@ let extract_trait_decl_method_names (ctx : extraction_ctx) (* Add a prefix if necessary *) let name = if !Config.record_fields_short_names then name - else ctx.fmt.trait_decl_name trait_decl ^ "_" ^ name + else ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ name in (f.back_id, name) in @@ -2036,8 +2035,8 @@ let extract_trait_decl_register_names (ctx : extraction_ctx) let trait_name, trait_constructor = match builtin_info with | None -> - ( ctx.fmt.trait_decl_name trait_decl, - ctx.fmt.trait_decl_constructor trait_decl ) + ( ctx_compute_trait_decl_name ctx trait_decl, + ctx_compute_trait_decl_constructor ctx trait_decl ) | Some info -> (info.extract_name, info.constructor) in let ctx = ctx_add (TraitDeclId trait_decl.def_id) trait_name ctx in @@ -2101,7 +2100,7 @@ let extract_trait_impl_register_names (ctx : extraction_ctx) (* Compute the name *) let name = match builtin_info with - | None -> ctx.fmt.trait_impl_name trait_decl trait_impl + | None -> ctx_compute_trait_impl_name ctx trait_decl trait_impl | Some name -> name in ctx_add (TraitImplId trait_impl.def_id) name ctx @@ -2214,7 +2213,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Open the box for the name + generics *) F.pp_open_hovbox fmt ctx.indent_incr; let qualif = - Option.get (ctx.fmt.type_decl_kind_to_qualif SingleNonRec (Some Struct)) + Option.get (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 *) @@ -2505,7 +2504,7 @@ 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; - (match ctx.fmt.fun_decl_kind_to_qualif SingleNonRec with + (match fun_decl_kind_to_qualif SingleNonRec with | Some qualif -> F.pp_print_string fmt qualif; F.pp_print_space fmt () diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index f1ba35a2..0b9908b2 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -2,9 +2,11 @@ open Contexts open Pure -open TranslateCore +open StringUtils +open Config module F = Format open ExtractBuiltin +open TranslateCore (** The local logger *) let log = Logging.extract_log @@ -109,225 +111,6 @@ let decl_is_not_last_from_group (kind : decl_kind) : bool = type type_decl_kind = Enum | Struct [@@deriving show] -(* 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, - information about the region group, etc.) it should come up with an - appropriate name for the forward/backward function. - - It can of course apply many transformations, like changing to camel case/ - 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; - char_name : string; - int_name : integer_type -> string; - str_name : string; - type_decl_kind_to_qualif : - decl_kind -> type_decl_kind option -> string option; - (** Compute the qualified for a type definition/declaration. - - For instance: "type", "and", etc. - - Remark: can return [None] for some backends like HOL4. - *) - fun_decl_kind_to_qualif : decl_kind -> string option; - (** Compute the qualified for a function definition/declaration. - - For instance: "let", "let rec", "and", etc. - - Remark: can return [None] for some backends like HOL4. - *) - field_name : llbc_name -> FieldId.id -> string option -> string; - (** Inputs: - - type name - - field id - - field name - - Note that fields don't always have names, but we still need to - generate some names if we want to extract the structures to records... - We might want to extract such structures to tuples, later, but field - access then causes trouble because not all provers accept syntax like - [x.3] where [x] is a tuple. - *) - variant_name : llbc_name -> string -> string; - (** Inputs: - - type name - - variant name - *) - struct_constructor : llbc_name -> string; - (** Structure constructors are used when constructing structure values. - - For instance, in F*: - {[ - type pair = { x : nat; y : nat } - let p : pair = Mkpair 0 1 - ]} - - Inputs: - - type name - *) - type_name : llbc_name -> string; - (** Provided a basename, compute a type name. *) - global_name : llbc_name -> string; - (** Provided a basename, compute a global name. *) - fun_name : - llbc_name -> - int -> - LoopId.id option -> - int -> - region_group_info option -> - bool * int -> - string; - (** Compute the name of a regular (non-assumed) function. - - Inputs: - - function basename (TODO: shouldn't appear for assumed functions?...) - - number of loops in the function (useful to check if we need to use - indices to derive unique names for the loops for instance - if there is - exactly one loop, we don't need to use indices) - - loop id (if pertinent) - - number of region groups - - region group information in case of a backward function - ([None] if forward function) - - pair: - - do we generate the forward function (it may have been filtered)? - - the number of *extracted backward functions* (same comment as for - the number of loops) - The number of extracted backward functions if not necessarily - equal to the number of region groups, because we may have - filtered some of them. - TODO: use the fun id for the assumed functions. - *) - termination_measure_name : - A.FunDeclId.id -> llbc_name -> int -> LoopId.id option -> string; - (** Generates the name of the termination measure used to prove/reason about - termination. The generated code uses this clause where needed, - but its body must be defined by the user. - - F* and Lean only. - - Inputs: - - function id: this is especially useful to identify whether the - function is an assumed function or a local function - - function basename - - the number of loops in the parent function. This is used for - the same purpose as in {!field:llbc_name}. - - loop identifier, if this is for a loop - *) - decreases_proof_name : - A.FunDeclId.id -> llbc_name -> int -> LoopId.id option -> string; - (** Generates the name of the proof used to prove/reason about - termination. The generated code uses this clause where needed, - but its body must be defined by the user. - - Lean only. - - Inputs: - - function id: this is especially useful to identify whether the - function is an assumed function or a local function - - function basename - - the number of loops in the parent function. This is used for - the same purpose as in {!field:llbc_name}. - - loop identifier, if this is for a loop - *) - 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; - trait_method_name : trait_decl -> string -> string; - trait_type_clause_name : trait_decl -> string -> trait_clause -> string; - var_basename : StringSet.t -> string option -> ty -> string; - (** Generates a variable basename. - - Inputs: - - the set of names used in the context so far - - the basename we got from the symbolic execution, if we have one - - the type of the variable (can be useful for heuristics, in order - not to always use "x" for instance, whenever naming anonymous - variables) - - Note that once the formatter generated a basename, we add an index - if necessary to prevent name clashes: the burden of name clashes checks - is thus on the caller's side. - *) - type_var_basename : StringSet.t -> string -> string; - (** 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. - - 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 - indices to names, the responsability of finding a proper index is - delegated to helper functions. - *) - extract_literal : F.formatter -> bool -> literal -> unit; - (** Format a constant value. - - Inputs: - - formatter - - [inside]: if [true], the value should be wrapped in parentheses - if it is made of an application (ex.: [U32 3]) - - the constant value - *) - extract_unop : - (bool -> texpression -> unit) -> - F.formatter -> - bool -> - unop -> - texpression -> - unit; - (** Format a unary operation - - Inputs: - - a formatter for expressions (called on the argument of the unop) - - extraction context (see below) - - formatter - - expression formatter - - [inside] - - unop - - argument - *) - extract_binop : - (bool -> texpression -> unit) -> - F.formatter -> - bool -> - E.binop -> - integer_type -> - texpression -> - texpression -> - unit; - (** Format a binary operation - - Inputs: - - a formatter for expressions (called on the arguments of the binop) - - extraction context (see below) - - formatter - - expression formatter - - [inside] - - binop - - argument 0 - - argument 1 - *) -} - (** We use identifiers to look for name clashes *) type id = | GlobalId of A.GlobalDeclId.id @@ -590,6 +373,152 @@ type names_maps = { *) } +(** 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 + | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ + | TraitMethodId _ -> + !Config.record_fields_short_names + | FunId (Pure _ | FromLlbc (FunId (FAssumed _), _, _)) -> + (* We map several assumed functions to the same id *) + true + | _ -> false + +(** 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. + + 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 + others (ex.: fields and keywords). + *) + 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 nm.strict_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 nm.strict_names_map + else nm.strict_names_map + in + let names_map = names_map_add id_to_string id name nm.names_map in + { nm with strict_names_map; names_map } + +(** 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 ^ " -> " ^ n) + (IdMap.bindings m)) + ^ "\n]" + in + if allow_collisions id then ( + 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 ^ "\nNames map:\n" + ^ map_to_string m + in + log#serror 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 + match IdMap.find_opt id m with + | Some s -> s + | None -> + let err = + "Could not find: " ^ id_to_string id ^ "\nNames map:\n" + ^ map_to_string m + in + log#serror err; + if !Config.fail_hard then raise (Failure err) + else "(ERROR: \"" ^ id_to_string id ^ "\")" + +type names_map_init = { + keywords : string list; + assumed_adts : (assumed_ty * string) list; + assumed_structs : (assumed_ty * string) list; + assumed_variants : (assumed_ty * VariantId.id * string) list; + assumed_llbc_functions : + (A.assumed_fun_id * RegionGroupId.id option * string) list; + assumed_pure_functions : (pure_assumed_fun_id * string) list; +} + +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 (TAssumed id)) name nm + +let names_maps_add_assumed_struct (id_to_string : id -> string) + (id : assumed_ty) (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (StructId (TAssumed id)) name nm + +let names_maps_add_assumed_variant (id_to_string : id -> string) + (id : assumed_ty) (variant_id : VariantId.id) (name : string) + (nm : names_maps) : names_maps = + names_maps_add id_to_string (VariantId (TAssumed id, variant_id)) name nm + +let names_maps_add_function (id_to_string : id -> string) (fid : fun_id) + (name : string) (nm : names_maps) : names_maps = + names_maps_add id_to_string (FunId fid) name nm + +let bool_name () = if !backend = Lean then "Bool" else "bool" +let char_name () = if !backend = Lean then "Char" else "char" +let str_name () = if !backend = Lean then "String" else "string" + +(** 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 + (** Extraction context. Note that the extraction context contains information coming from the @@ -601,7 +530,6 @@ 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 *) use_dep_ite : bool; @@ -741,130 +669,20 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = ^ ", 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 - 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 - | FieldId _ | TraitItemClauseId _ | TraitParentClauseId _ | TraitItemId _ - | TraitMethodId _ -> - !Config.record_fields_short_names - | FunId (Pure _ | FromLlbc (FunId (FAssumed _), _, _)) -> - (* We map several assumed functions to the same id *) - true - | _ -> false - -(** 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. - - 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 - others (ex.: fields and keywords). - *) - 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 nm.strict_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 nm.strict_names_map - else nm.strict_names_map - in - let names_map = names_map_add id_to_string id name nm.names_map in - { nm with strict_names_map; names_map } - 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 ^ " -> " ^ n) - (IdMap.bindings m)) - ^ "\n]" - in - if allow_collisions id then ( - 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 ^ "\nNames map:\n" - ^ map_to_string m - in - log#serror 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 - match IdMap.find_opt id m with - | Some s -> s - | None -> - let err = - "Could not find: " ^ id_to_string id ^ "\nNames map:\n" - ^ map_to_string m - in - log#serror err; - if !Config.fail_hard then raise (Failure err) - 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 (TAssumed id)) name nm +let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx -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 (TAssumed id)) name nm - -let names_maps_add_assumed_variant (id_to_string : id -> string) - (id : assumed_ty) (variant_id : VariantId.id) (name : string) - (nm : names_maps) : names_maps = - names_maps_add id_to_string (VariantId (TAssumed id, variant_id)) name nm - -let names_maps_add_function (id_to_string : id -> string) (fid : fun_id) - (name : string) (nm : names_maps) : names_maps = - 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 - -let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = - ctx_get (FunId id) ctx +let ctx_get_function (id : fun_id) (ctx : extraction_ctx) : string = + ctx_get (FunId id) ctx let ctx_get_local_function (id : A.FunDeclId.id) (lp : LoopId.id option) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = @@ -950,15 +768,970 @@ let ctx_get_termination_measure (def_id : A.FunDeclId.id) (loop_id : LoopId.id option) (ctx : extraction_ctx) : string = ctx_get (TerminationMeasureId (FRegular def_id, loop_id)) ctx +(** 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"; + "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 -> + [ + (TState, "State"); + (TResult, "Result"); + (TError, "Error"); + (TFuel, "Nat"); + (TArray, "Array"); + (TSlice, "Slice"); + (TStr, "Str"); + (TRawPtr Mut, "MutRawPtr"); + (TRawPtr Const, "ConstRawPtr"); + ] + | Coq | FStar | HOL4 -> + [ + (TState, "state"); + (TResult, "result"); + (TError, "error"); + (TFuel, if !backend = HOL4 then "num" else "nat"); + (TArray, "array"); + (TSlice, "slice"); + (TStr, "str"); + (TRawPtr Mut, "mut_raw_ptr"); + (TRawPtr Const, "const_raw_ptr"); + ] + +let assumed_struct_constructors () : (assumed_ty * string) list = + match !backend with + | Lean -> [ (TArray, "Array.make") ] + | Coq -> [ (TArray, "mk_array") ] + | FStar -> [ (TArray, "mk_array") ] + | HOL4 -> [ (TArray, "mk_array") ] + +let assumed_variants () : (assumed_ty * VariantId.id * string) list = + match !backend with + | FStar -> + [ + (TResult, result_return_id, "Return"); + (TResult, result_fail_id, "Fail"); + (TError, error_failure_id, "Failure"); + (TError, error_out_of_fuel_id, "OutOfFuel"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + | Coq -> + [ + (TResult, result_return_id, "Return"); + (TResult, result_fail_id, "Fail_"); + (TError, error_failure_id, "Failure"); + (TError, error_out_of_fuel_id, "OutOfFuel"); + (TFuel, fuel_zero_id, "O"); + (TFuel, fuel_succ_id, "S"); + ] + | Lean -> + [ + (TResult, result_return_id, "ret"); + (TResult, result_fail_id, "fail"); + (TError, error_failure_id, "panic"); + (* No Fuel::Zero on purpose *) + (* No Fuel::Succ on purpose *) + ] + | HOL4 -> + [ + (TResult, result_return_id, "Return"); + (TResult, result_fail_id, "Fail"); + (TError, 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_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_usize"); + (SliceIndexMut, None, "slice_index_usize"); + (SliceIndexMut, rg0, "slice_update_usize"); + ] + | Lean -> + [ + (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_usize"); + (SliceIndexMut, None, "Slice.index_usize"); + (SliceIndexMut, rg0, "Slice.update_usize"); + ] + +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 (); + } + +(** Initialize names maps with a proper set of keywords/names coming from the + target language/prover. *) +let initialize_names_maps () : names_maps = + let init = names_map_init () in + let int_names = List.map int_name T.all_int_types in + let keywords = + List.concat + [ [ bool_name (); char_name (); str_name () ]; int_names; init.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. *) + let id_to_name = IdMap.empty 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 + (* 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 + * - the assumed variants + * - the assumed functions + *) + let nm = + List.fold_left + (fun nm (type_id, name) -> + 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_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_maps_add_assumed_variant id_to_string type_id variant_id name nm) + nm init.assumed_variants + in + let assumed_functions = + List.map + (fun (fid, rg, name) -> + (FromLlbc (Pure.FunId (FAssumed fid), None, rg), name)) + init.assumed_llbc_functions + @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions + in + let nm = + List.fold_left + (fun nm (fid, name) -> names_maps_add_function id_to_string fid name nm) + nm assumed_functions + in + (* Return *) + nm + +(** Compute the qualified for a type definition/declaration. + + For instance: "type", "and", etc. + + Remark: can return [None] for some backends like HOL4. + *) +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 + +(** Compute the qualified for a function definition/declaration. + + For instance: "let", "let rec", "and", etc. + + Remark: can return [None] for some backends like HOL4. + *) +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") + +(** Helper *) +let name_last_elem_as_ident (n : llbc_name) : string = + match Collections.List.last n with + | PeIdent (s, _) -> s + | PeImpl _ -> raise (Failure "Unexpected") + +(** Helper + + Prepare a name. + The first id elem is always the crate: if it is the local crate, + we remove it. We ignore disambiguators (there may be collisions, but we + check if there are). + *) +let ctx_compute_simple_name (ctx : extraction_ctx) (name : llbc_name) : + string list = + (* Rmk.: initially we only filtered the disambiguators equal to 0 *) + match name with + | (PeIdent (crate, _) as id) :: name -> + let name = if crate = ctx.crate.name then name else id :: name in + name_to_simple_name ctx.trans_ctx name + | _ -> + raise + (Failure + ("Unexpected name shape: " + ^ TranslateCore.name_to_string ctx.trans_ctx name)) + +(** Helper *) +let ctx_compute_simple_type_name = ctx_compute_simple_name + +(** Helper *) +let ctx_compute_type_name_no_suffix (ctx : extraction_ctx) (name : llbc_name) : + string = + flatten_name (ctx_compute_simple_type_name ctx name) + +(** Provided a basename, compute a type name. *) +let ctx_compute_type_name (ctx : extraction_ctx) (name : llbc_name) = + let name = ctx_compute_type_name_no_suffix ctx name in + match !backend with + | FStar -> StringUtils.lowercase_first_letter (name ^ "_t") + | Coq | HOL4 -> name ^ "_t" + | Lean -> name + +(** Inputs: + - type name + - field id + - field name + + Note that fields don't always have names, but we still need to + generate some names if we want to extract the structures to records... + We might want to extract such structures to tuples, later, but field + access then causes trouble because not all provers accept syntax like + [x.3] where [x] is a tuple. + *) +let ctx_compute_field_name (ctx : extraction_ctx) (def_name : llbc_name) + (field_id : FieldId.id) (field_name : string option) : string = + let field_name_s = + match field_name with + | Some field_name -> field_name + | 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 = + ctx_compute_type_name_no_suffix ctx def_name ^ "_" ^ field_name_s + in + match !backend with + | Lean | HOL4 -> def_name + | Coq | FStar -> StringUtils.lowercase_first_letter def_name + +(** Inputs: + - type name + - variant name + *) +let ctx_compute_variant_name (ctx : extraction_ctx) (def_name : llbc_name) + (variant : string) : string = + match !backend with + | FStar | Coq | HOL4 -> + let variant = to_camel_case variant in + if !variant_concatenate_type_name then + StringUtils.capitalize_first_letter + (ctx_compute_type_name_no_suffix ctx def_name ^ "_" ^ variant) + else variant + | Lean -> variant + +(** Structure constructors are used when constructing structure values. + + For instance, in F*: + {[ + type pair = { x : nat; y : nat } + let p : pair = Mkpair 0 1 + ]} + + Inputs: + - type name +*) +let ctx_compute_struct_constructor (ctx : extraction_ctx) (basename : llbc_name) + : string = + let tname = ctx_compute_type_name ctx basename in + ExtractBuiltin.mk_struct_constructor tname + +let ctx_compute_fun_name_no_suffix (ctx : extraction_ctx) (fname : llbc_name) : + string = + let fname = ctx_compute_simple_name ctx fname in + (* TODO: don't convert to snake case for Coq, HOL4, F* *) + let fname = flatten_name fname in + match !backend with + | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter fname + | Lean -> fname + +(** Provided a basename, compute the name of a global declaration. *) +let ctx_compute_global_name (ctx : extraction_ctx) (name : llbc_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 (ctx_compute_simple_name ctx name) in + String.concat "_" parts + +(** Helper function: generate a suffix for a function name, i.e., generates + a suffix like "_loop", "loop1", etc. to append to a function name. + *) +let default_fun_loop_suffix (num_loops : int) (loop_id : LoopId.id option) : + string = + match loop_id with + | None -> "" + | Some loop_id -> + (* If this is for a loop, generally speaking, we append the loop index. + If this function admits only one loop, we omit it. *) + if num_loops = 1 then "_loop" else "_loop" ^ LoopId.to_string loop_id + +(** A helper function: generates a function suffix from a region group + information. + TODO: move all those helpers. +*) +let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) + (num_region_groups : int) (rg : region_group_info option) + ((keep_fwd, num_backs) : bool * int) : string = + let lp_suff = default_fun_loop_suffix num_loops loop_id in + + (* There are several cases: + - [rg] is [Some]: this is a forward function: + - we add "_fwd" + - [rg] is [None]: this is a backward function: + - this function has one extracted backward function: + - if the forward function has been filtered, we add "_fwd_back": + the forward function is useless, so the unique backward function + takes its place, in a way + - otherwise we add "_back" + - this function has several backward functions: we add "_back" and an + additional suffix to identify the precise backward function + Note that we always add a suffix (in case there are no region groups, + we could not add the "_fwd" suffix) to prevent name clashes between + definitions (in particular between type and function definitions). + *) + let rg_suff = + (* TODO: make all the backends match what is done for Lean *) + match rg with + | 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 *) + 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 + - otherwise we use an index + *) + List.for_all Option.is_some rg.region_names + then + (* Concatenate the region names *) + "_back" ^ String.concat "" (List.map Option.get rg.region_names) + else (* Use the region index *) + "_back" ^ RegionGroupId.to_string rg.id + in + lp_suff ^ rg_suff + +(** Compute the name of a regular (non-assumed) function. + + Inputs: + - function basename (TODO: shouldn't appear for assumed functions?...) + - number of loops in the function (useful to check if we need to use + indices to derive unique names for the loops for instance - if there is + exactly one loop, we don't need to use indices) + - loop id (if pertinent) + - number of region groups + - region group information in case of a backward function + ([None] if forward function) + - pair: + - do we generate the forward function (it may have been filtered)? + - the number of *extracted backward functions* (same comment as for + the number of loops) + The number of extracted backward functions if not necessarily + equal to the number of region groups, because we may have + filtered some of them. + TODO: use the fun id for the assumed functions. + *) +let ctx_compute_fun_name (ctx : extraction_ctx) (fname : llbc_name) + (num_loops : int) (loop_id : LoopId.id option) (num_rgs : int) + (rg : region_group_info option) (filter_info : bool * int) : string = + let fname = ctx_compute_fun_name_no_suffix ctx fname in + (* Compute the suffix *) + let suffix = default_fun_suffix num_loops loop_id num_rgs rg filter_info in + (* Concatenate *) + fname ^ suffix + +let ctx_compute_trait_decl_name (ctx : extraction_ctx) (trait_decl : trait_decl) + : string = + ctx_compute_type_name ctx trait_decl.llbc_name + +let ctx_compute_trait_impl_name (ctx : extraction_ctx) (trait_decl : trait_decl) + (trait_impl : trait_impl) : string = + (* We derive the trait impl name from the implemented trait. + For instance, if this implementation is an instance of `trait::Trait` + for ``, we generate the name: "trait.TraitFooFooU32Inst". + Importantly, it is to be noted that the name is independent of the place + where the instance has been defined (it is indepedent of the file, etc.). + *) + let name = + (* We need to lookup the LLBC definitions, to have the original instantiation *) + let trait_impl = + TraitImplId.Map.find trait_impl.def_id + ctx.trans_ctx.trait_impls_ctx.trait_impls + in + let params = trait_impl.generics in + let args = trait_impl.impl_trait.decl_generics in + name_with_generics_to_simple_name ctx.trans_ctx trait_decl.llbc_name params + args + in + let name = flatten_name name in + match !backend with + | FStar -> StringUtils.lowercase_first_letter name + | Coq | HOL4 | Lean -> name + +let ctx_compute_trait_decl_constructor (ctx : extraction_ctx) + (trait_decl : trait_decl) : string = + let name = ctx_compute_trait_decl_name ctx trait_decl in + ExtractBuiltin.mk_struct_constructor name + +let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) + (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 ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ clause + +let ctx_compute_trait_type_name (ctx : extraction_ctx) (trait_decl : trait_decl) + (item : string) : string = + let name = + if !Config.record_fields_short_names then item + else ctx_compute_trait_decl_name ctx 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 + +let ctx_compute_trait_const_name (ctx : extraction_ctx) + (trait_decl : trait_decl) (item : string) : string = + let name = + if !Config.record_fields_short_names then item + else ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ item + in + (* See [trait_type_name] *) + match !backend with FStar -> "c" ^ name | Coq | Lean | HOL4 -> name + +let ctx_compute_trait_method_name (ctx : extraction_ctx) + (trait_decl : trait_decl) (item : string) : string = + if !Config.record_fields_short_names then item + else ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ item + +let ctx_compute_trait_type_clause_name (ctx : extraction_ctx) + (trait_decl : trait_decl) (item : string) (clause : trait_clause) : string = + (* TODO: improve - it would be better to not use indices *) + ctx_compute_trait_type_name ctx trait_decl item + ^ "_clause_" + ^ TraitClauseId.to_string clause.clause_id + +(** Generates the name of the termination measure used to prove/reason about + termination. The generated code uses this clause where needed, + but its body must be defined by the user. + + F* and Lean only. + + Inputs: + - function id: this is especially useful to identify whether the + function is an assumed function or a local function + - function basename + - the number of loops in the parent function. This is used for + the same purpose as in {!field:llbc_name}. + - loop identifier, if this is for a loop + *) +let ctx_compute_termination_measure_name (ctx : extraction_ctx) + (_fid : A.FunDeclId.id) (fname : llbc_name) (num_loops : int) + (loop_id : LoopId.id option) : string = + let fname = ctx_compute_fun_name_no_suffix ctx 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 + +(** Generates the name of the proof used to prove/reason about + termination. The generated code uses this clause where needed, + but its body must be defined by the user. + + Lean only. + + Inputs: + - function id: this is especially useful to identify whether the + function is an assumed function or a local function + - function basename + - the number of loops in the parent function. This is used for + the same purpose as in {!field:llbc_name}. + - loop identifier, if this is for a loop + *) +let ctx_compute_decreases_proof_name (ctx : extraction_ctx) + (_fid : A.FunDeclId.id) (fname : llbc_name) (num_loops : int) + (loop_id : LoopId.id option) : string = + let fname = ctx_compute_fun_name_no_suffix ctx 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 + +(** Generates a variable basename. + + Inputs: + - the set of names used in the context so far + - the basename we got from the symbolic execution, if we have one + - the type of the variable (can be useful for heuristics, in order + not to always use "x" for instance, whenever naming anonymous + variables) + + Note that once the formatter generated a basename, we add an index + if necessary to prevent name clashes: the burden of name clashes checks + is thus on the caller's side. + *) +let ctx_compute_var_basename (ctx : extraction_ctx) (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 + | TAdt (type_id, generics) -> ( + match type_id with + | TTuple -> + (* The "pair" case is frequent enough to have its special treatment *) + if List.length generics.types = 2 then "p" else "t" + | TAssumed TResult -> "r" + | TAssumed TError -> ConstStrings.error_basename + | TAssumed TFuel -> ConstStrings.fuel_basename + | TAssumed TArray -> "a" + | TAssumed TSlice -> "s" + | TAssumed TStr -> "s" + | TAssumed TState -> ConstStrings.state_basename + | TAssumed (TRawPtr _) -> "p" + | TAdtId adt_id -> + let def = + TypeDeclId.Map.find adt_id ctx.trans_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 = Collections.List.last def.name in + name_from_type_ident (TypesUtils.as_ident cl)) + | TVar _ -> ( + (* TODO: use "t" also for F* *) + match !backend with + | FStar -> "x" (* lacking inspiration here... *) + | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) + | TLiteral lty -> ( + match lty with TBool -> "b" | TChar -> "c" | TInteger _ -> "i") + | TArrow _ -> "f" + | TTraitType (_, _, name) -> name_from_type_ident name) + +(** Generates a type variable basename. *) +let ctx_compute_type_var_basename (_ctx : extraction_ctx) (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 + +(** Generates a const generic variable basename. *) +let ctx_compute_const_generic_var_basename (_ctx : extraction_ctx) + (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 + +(** 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. + *) +let ctx_compute_trait_clause_basename (_ctx : extraction_ctx) + (_clause : trait_clause) : string = + (* TODO: actually use the clause to derive the name *) + "inst" + +let trait_self_clause_basename = "self_clause" + +(** 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 + indices to names, the responsability of finding a proper index is + delegated to helper functions. + *) +let name_append_index (basename : string) (i : int) : string = + basename ^ string_of_int i + (** 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_compute_type_var_basename ctx basename in let 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 + basename_to_unique ctx.names_maps.names_map.names_set name_append_index name in let ctx = ctx_add (TypeVarId id) name ctx in (ctx, name) @@ -966,13 +1739,9 @@ let ctx_add_type_var (basename : string) (id : TypeVarId.id) (** 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 name = ctx_compute_const_generic_var_basename ctx basename in let name = - ctx.fmt.const_generic_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 + basename_to_unique ctx.names_maps.names_map.names_set name_append_index name in let ctx = ctx_add (ConstGenericVarId id) name ctx in (ctx, name) @@ -988,7 +1757,7 @@ 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_maps.names_map.names_set ctx.fmt.append_index + basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename in let ctx = ctx_add (VarId id) name ctx in @@ -996,9 +1765,9 @@ let ctx_add_var (basename : string) (id : VarId.id) (ctx : extraction_ctx) : (** 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 basename = ctx.fmt.trait_self_clause_basename in + let basename = trait_self_clause_basename in let name = - basename_to_unique ctx.names_maps.names_map.names_set ctx.fmt.append_index + basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename in let ctx = ctx_add TraitSelfClauseId name ctx in @@ -1008,7 +1777,7 @@ 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_maps.names_map.names_set ctx.fmt.append_index + basename_to_unique ctx.names_maps.names_map.names_set name_append_index basename in let ctx = ctx_add (LocalTraitClauseId id) name ctx in @@ -1019,9 +1788,7 @@ 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_maps.names_map.names_set v.basename v.ty - in + let name = ctx_compute_var_basename ctx v.basename v.ty in ctx_add_var name v.id ctx) ctx vars @@ -1042,9 +1809,7 @@ 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_maps.names_map.names_set c - in + let basename = ctx_compute_trait_clause_basename ctx c in ctx_add_local_trait_clause basename c.clause_id ctx) ctx clauses @@ -1064,7 +1829,7 @@ let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx.fmt.decreases_proof_name def.def_id def.llbc_name def.num_loops + ctx_compute_decreases_proof_name ctx def.def_id def.llbc_name def.num_loops def.loop_id in ctx_add (DecreasesProofId (FRegular def.def_id, def.loop_id)) name ctx @@ -1072,8 +1837,8 @@ let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : let ctx_add_termination_measure (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = let name = - ctx.fmt.termination_measure_name def.def_id def.llbc_name def.num_loops - def.loop_id + ctx_compute_termination_measure_name ctx def.def_id def.llbc_name + def.num_loops def.loop_id in ctx_add (TerminationMeasureId (FRegular def.def_id, def.loop_id)) name ctx @@ -1091,7 +1856,7 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : ctx_add decl name ctx | None -> (* Not the case: "standard" registration *) - let name = ctx.fmt.global_name def.name in + let name = ctx_compute_global_name ctx def.name in let body = FunId (FromLlbc (FunId (FRegular def.body), None, None)) in let ctx = ctx_add decl (name ^ "_c") ctx in let ctx = ctx_add body (name ^ "_body") ctx in @@ -1123,8 +1888,8 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) Some { id = rg_id; region_names } in (* Add the function name *) - ctx.fmt.fun_name def.llbc_name def.num_loops def.loop_id num_rgs rg_info - (keep_fwd, num_backs) + ctx_compute_fun_name ctx def.llbc_name 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) @@ -1148,156 +1913,6 @@ let ctx_add_fun_decl (trans_group : pure_fun_translation) (def : fun_decl) ctx.fun_name_info; } -type names_map_init = { - keywords : string list; - assumed_adts : (assumed_ty * string) list; - assumed_structs : (assumed_ty * string) list; - assumed_variants : (assumed_ty * VariantId.id * string) list; - assumed_llbc_functions : - (A.assumed_fun_id * RegionGroupId.id option * string) list; - assumed_pure_functions : (pure_assumed_fun_id * string) list; -} - -(** Initialize names maps with a proper set of keywords/names coming from the - target language/prover. *) -let initialize_names_maps (fmt : formatter) (init : names_map_init) : names_maps +let ctx_compute_type_decl_name (ctx : extraction_ctx) (def : type_decl) : string = - let int_names = List.map fmt.int_name T.all_int_types in - let keywords = - List.concat - [ - [ fmt.bool_name; fmt.char_name; fmt.str_name ]; int_names; init.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. *) - let id_to_name = IdMap.empty 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 - (* 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 - * - the assumed variants - * - the assumed functions - *) - let nm = - List.fold_left - (fun nm (type_id, name) -> - 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_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_maps_add_assumed_variant id_to_string type_id variant_id name nm) - nm init.assumed_variants - in - let assumed_functions = - List.map - (fun (fid, rg, name) -> - (FromLlbc (Pure.FunId (FAssumed fid), None, rg), name)) - init.assumed_llbc_functions - @ List.map (fun (fid, name) -> (Pure fid, name)) init.assumed_pure_functions - in - let nm = - List.fold_left - (fun nm (fid, name) -> names_maps_add_function id_to_string fid name nm) - nm assumed_functions - in - (* Return *) - nm - -let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = - fmt.type_name def.llbc_name - -(** Helper function: generate a suffix for a function name, i.e., generates - a suffix like "_loop", "loop1", etc. to append to a function name. - *) -let default_fun_loop_suffix (num_loops : int) (loop_id : LoopId.id option) : - string = - match loop_id with - | None -> "" - | Some loop_id -> - (* If this is for a loop, generally speaking, we append the loop index. - If this function admits only one loop, we omit it. *) - if num_loops = 1 then "_loop" else "_loop" ^ LoopId.to_string loop_id - -(** A helper function: generates a function suffix from a region group - information. - TODO: move all those helpers. -*) -let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) - (num_region_groups : int) (rg : region_group_info option) - ((keep_fwd, num_backs) : bool * int) : string = - let lp_suff = default_fun_loop_suffix num_loops loop_id in - - (* There are several cases: - - [rg] is [Some]: this is a forward function: - - we add "_fwd" - - [rg] is [None]: this is a backward function: - - this function has one extracted backward function: - - if the forward function has been filtered, we add "_fwd_back": - the forward function is useless, so the unique backward function - takes its place, in a way - - otherwise we add "_back" - - this function has several backward functions: we add "_back" and an - additional suffix to identify the precise backward function - Note that we always add a suffix (in case there are no region groups, - we could not add the "_fwd" suffix) to prevent name clashes between - definitions (in particular between type and function definitions). - *) - let rg_suff = - (* TODO: make all the backends match what is done for Lean *) - match rg with - | 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 *) - 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 - - otherwise we use an index - *) - List.for_all Option.is_some rg.region_names - then - (* Concatenate the region names *) - "_back" ^ String.concat "" (List.map Option.get rg.region_names) - else (* Use the region index *) - "_back" ^ RegionGroupId.to_string rg.id - in - lp_suff ^ rg_suff + ctx_compute_type_name ctx def.llbc_name diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index b0a5159f..ef746ddf 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -26,6 +26,11 @@ let mk_memoized (f : unit -> 'a) : unit -> 'a = let split_on_separator (s : string) : string list = Str.split (Str.regexp "\\(::\\|\\.\\)") s +let flatten_name (name : string list) : string = + match !backend with + | FStar | Coq | HOL4 -> String.concat "_" name + | Lean -> String.concat "." name + let () = assert (split_on_separator "x::y::z" = [ "x"; "y"; "z" ]); assert (split_on_separator "x.y.z" = [ "x"; "y"; "z" ]) @@ -124,10 +129,7 @@ let mk_struct_constructor (type_name : string) : string = let builtin_types () : builtin_type_info list = let mk_type (rust_name : string) ?(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 (split_on_separator rust_name) - in + let extract_name = flatten_name (split_on_separator rust_name) in let body_info : builtin_type_body_info option = match kind with | KOpaque -> None @@ -231,11 +233,7 @@ let builtin_funs () : (pattern * bool list option * builtin_fun_info list) list | None -> pattern_to_fun_extract_name rust_name | Some name -> split_on_separator name in - let basename = - match !backend with - | FStar | Coq | HOL4 -> String.concat "_" extract_name - | Lean -> String.concat "." extract_name - in + let basename = flatten_name extract_name 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 @@ -400,11 +398,9 @@ let builtin_trait_decls_info () = let extract_name = match extract_name with | Some n -> n - | None -> ( + | None -> let rust_name = pattern_to_fun_extract_name rust_name in - match !backend with - | Coq | FStar | HOL4 -> String.concat "_" rust_name - | Lean -> String.concat "." rust_name) + flatten_name rust_name in let constructor = mk_struct_constructor extract_name in let consts = [] in @@ -502,13 +498,12 @@ let builtin_trait_impls_info () : (pattern * (bool list option * string)) list = pattern * (bool list option * string) = let rust_name = parse_pattern rust_name in let name = - let sep = backend_choice "_" "." in let name = match extract_name with | None -> pattern_to_trait_impl_extract_name rust_name | Some name -> split_on_separator name in - String.concat sep name + flatten_name name in (rust_name, (filter, name)) in diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 3a81e6fe..c9be5abe 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -6,354 +6,88 @@ open Pure open PureUtils open TranslateCore -open ExtractBase -open StringUtils open Config -module F = Format +include ExtractBase -(** 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 +(** Format a constant value. -(** 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*. + Inputs: + - formatter + - [inside]: if [true], the value should be wrapped in parentheses + if it is made of an application (ex.: [U32 3]) + - the constant value *) -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"; - "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 extract_literal (fmt : F.formatter) (inside : bool) (cv : literal) : unit = + match cv with + | VScalar sv -> ( + match !backend with + | FStar -> F.pp_print_string fmt (Z.to_string sv.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.int_ty); + F.pp_print_space fmt () + | _ -> raise (Failure "Unreachable")); + (* We need to add parentheses if the value is negative *) + if sv.value >= Z.of_int 0 then + F.pp_print_string fmt (Z.to_string sv.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.value) ^ ":Int))") + else F.pp_print_string fmt ("(" ^ Z.to_string sv.value ^ ")"); + (match !backend with + | Coq -> + let iname = int_name sv.int_ty in + F.pp_print_string fmt ("%" ^ iname) + | Lean -> + let iname = String.lowercase_ascii (int_name sv.int_ty) in + F.pp_print_string fmt ("#" ^ iname) + | HOL4 -> () + | _ -> raise (Failure "Unreachable")); + if print_brackets then F.pp_print_string fmt ")") + | VBool b -> + let b = + match !backend with + | HOL4 -> if b then "T" else "F" + | Coq | FStar | Lean -> if b then "true" else "false" + in + F.pp_print_string fmt b + | VChar 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 ")") -let assumed_adts () : (assumed_ty * string) list = - match !backend with - | Lean -> - [ - (TState, "State"); - (TResult, "Result"); - (TError, "Error"); - (TFuel, "Nat"); - (TArray, "Array"); - (TSlice, "Slice"); - (TStr, "Str"); - (TRawPtr Mut, "MutRawPtr"); - (TRawPtr Const, "ConstRawPtr"); - ] - | Coq | FStar | HOL4 -> - [ - (TState, "state"); - (TResult, "result"); - (TError, "error"); - (TFuel, if !backend = HOL4 then "num" else "nat"); - (TArray, "array"); - (TSlice, "slice"); - (TStr, "str"); - (TRawPtr Mut, "mut_raw_ptr"); - (TRawPtr Const, "const_raw_ptr"); - ] - -let assumed_struct_constructors () : (assumed_ty * string) list = - match !backend with - | Lean -> [ (TArray, "Array.make") ] - | Coq -> [ (TArray, "mk_array") ] - | FStar -> [ (TArray, "mk_array") ] - | HOL4 -> [ (TArray, "mk_array") ] - -let assumed_variants () : (assumed_ty * VariantId.id * string) list = - match !backend with - | FStar -> - [ - (TResult, result_return_id, "Return"); - (TResult, result_fail_id, "Fail"); - (TError, error_failure_id, "Failure"); - (TError, error_out_of_fuel_id, "OutOfFuel"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - ] - | Coq -> - [ - (TResult, result_return_id, "Return"); - (TResult, result_fail_id, "Fail_"); - (TError, error_failure_id, "Failure"); - (TError, error_out_of_fuel_id, "OutOfFuel"); - (TFuel, fuel_zero_id, "O"); - (TFuel, fuel_succ_id, "S"); - ] - | Lean -> - [ - (TResult, result_return_id, "ret"); - (TResult, result_fail_id, "fail"); - (TError, error_failure_id, "panic"); - (* No Fuel::Zero on purpose *) - (* No Fuel::Succ on purpose *) - ] - | HOL4 -> - [ - (TResult, result_return_id, "Return"); - (TResult, result_fail_id, "Fail"); - (TError, 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_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_usize"); - (SliceIndexMut, None, "slice_index_usize"); - (SliceIndexMut, rg0, "slice_update_usize"); - ] - | Lean -> - [ - (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_usize"); - (SliceIndexMut, None, "Slice.index_usize"); - (SliceIndexMut, rg0, "Slice.update_usize"); - ] - -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 (); - } +(** Format a unary operation + Inputs: + - a formatter for expressions (called on the argument of the unop) + - extraction context (see below) + - formatter + - expression formatter + - [inside] + - unop + - argument + *) let extract_unop (extract_expr : bool -> texpression -> unit) (fmt : F.formatter) (inside : bool) (unop : unop) (arg : texpression) : unit = @@ -409,7 +143,18 @@ let extract_unop (extract_expr : bool -> texpression -> unit) extract_expr true arg; if inside then F.pp_print_string fmt ")") -(** [extract_expr] : the boolean argument is [inside] *) +(** Format a binary operation + + Inputs: + - a formatter for expressions (called on the arguments of the binop) + - extraction context (see below) + - formatter + - expression formatter + - [inside] + - binop + - argument 0 + - argument 1 + *) 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 = @@ -451,523 +196,6 @@ let extract_binop (extract_expr : bool -> texpression -> unit) 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") - -let name_last_elem_as_ident (n : llbc_name) : string = - match Collections.List.last n with - | PeIdent (s, _) -> s - | PeImpl _ -> 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 ignore disambiguators (there may be collisions, but we - check if there are). - *) - let name_to_simple_name (name : llbc_name) : string list = - (* Rmk.: initially we only filtered the disambiguators equal to 0 *) - match name with - | (PeIdent (crate, _) as id) :: name -> - let name = if crate = crate_name then name else id :: name in - name_to_simple_name ctx name - | _ -> - raise - (Failure - ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx 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_name name : string list = name_to_simple_name name in - let get_type_name = get_name in - let get_type_name_no_suffix name = - match !backend with - | 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 : llbc_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 = 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 : llbc_name) (variant : string) : string = - match !backend with - | FStar | Coq | HOL4 -> - let variant = to_camel_case variant in - if variant_concatenate_type_name then - StringUtils.capitalize_first_letter - (get_type_name_no_suffix def_name ^ "_" ^ variant) - else variant - | Lean -> variant - in - let struct_constructor (basename : llbc_name) : string = - let tname = type_name basename in - ExtractBuiltin.mk_struct_constructor tname - in - let get_fun_name fname = - let fname = get_name fname in - (* TODO: don't convert to snake case for Coq, HOL4, F* *) - let fname = flatten_name fname in - match !backend with - | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter fname - | Lean -> fname - in - let global_name (name : llbc_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 : llbc_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.llbc_name - in - - let trait_impl_name (trait_decl : trait_decl) (trait_impl : trait_impl) : - string = - (* We derive the trait impl name from the implemented trait. - For instance, if this implementation is an instance of `trait::Trait` - for ``, we generate the name: "trait.TraitFooFooU32Inst". - Importantly, it is to be noted that the name is independent of the place - where the instance has been defined (it is indepedent of the file, etc.). - *) - let name = - (* We need to lookup the LLBC definitions, to have the original instantiation *) - let trait_impl = - TraitImplId.Map.find trait_impl.def_id ctx.trait_impls_ctx.trait_impls - in - let params = trait_impl.generics in - let args = trait_impl.impl_trait.decl_generics in - name_with_generics_to_simple_name ctx trait_decl.llbc_name params args - in - let name = flatten_name name in - match !backend with - | FStar -> StringUtils.lowercase_first_letter name - | 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 *) - 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 = - 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 = - 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 - 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 : llbc_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 : llbc_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 - | TAdt (type_id, generics) -> ( - match type_id with - | TTuple -> - (* The "pair" case is frequent enough to have its special treatment *) - if List.length generics.types = 2 then "p" else "t" - | TAssumed TResult -> "r" - | TAssumed TError -> ConstStrings.error_basename - | TAssumed TFuel -> ConstStrings.fuel_basename - | TAssumed TArray -> "a" - | TAssumed TSlice -> "s" - | TAssumed TStr -> "s" - | TAssumed TState -> ConstStrings.state_basename - | TAssumed (TRawPtr _) -> "p" - | TAdtId 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 = Collections.List.last def.name in - name_from_type_ident (TypesUtils.as_ident cl)) - | TVar _ -> ( - (* TODO: use "t" also for F* *) - match !backend with - | FStar -> "x" (* lacking inspiration here... *) - | Coq | Lean | HOL4 -> "t" (* lacking inspiration here... *)) - | TLiteral lty -> ( - match lty with TBool -> "b" | TChar -> "c" | TInteger _ -> "i") - | TArrow _ -> "f" - | TTraitType (_, _, 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 - | VScalar sv -> ( - match !backend with - | FStar -> F.pp_print_string fmt (Z.to_string sv.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.int_ty); - F.pp_print_space fmt () - | _ -> raise (Failure "Unreachable")); - (* We need to add parentheses if the value is negative *) - if sv.value >= Z.of_int 0 then - F.pp_print_string fmt (Z.to_string sv.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.value) ^ ":Int))") - else F.pp_print_string fmt ("(" ^ Z.to_string sv.value ^ ")"); - (match !backend with - | Coq -> - let iname = int_name sv.int_ty in - F.pp_print_string fmt ("%" ^ iname) - | Lean -> - let iname = String.lowercase_ascii (int_name sv.int_ty) in - F.pp_print_string fmt ("#" ^ iname) - | HOL4 -> () - | _ -> raise (Failure "Unreachable")); - if print_brackets then F.pp_print_string fmt ")") - | VBool b -> - let b = - match !backend with - | HOL4 -> if b then "T" else "F" - | Coq | FStar | Lean -> if b then "true" else "false" - in - F.pp_print_string fmt b - | VChar 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_decl_constructor; - 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_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_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 @@ -1125,17 +353,17 @@ let extract_const_generic (ctx : extraction_ctx) (fmt : F.formatter) | CgGlobal id -> let s = ctx_get_global id ctx in F.pp_print_string fmt s - | CgValue v -> ctx.fmt.extract_literal fmt inside v + | CgValue v -> extract_literal fmt inside v | CgVar 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) +let extract_literal_type (_ctx : extraction_ctx) (fmt : F.formatter) (ty : literal_type) : unit = match ty with - | TBool -> F.pp_print_string fmt ctx.fmt.bool_name - | TChar -> F.pp_print_string fmt ctx.fmt.char_name - | TInteger int_ty -> F.pp_print_string fmt (ctx.fmt.int_name int_ty) + | TBool -> F.pp_print_string fmt (bool_name ()) + | TChar -> F.pp_print_string fmt (char_name ()) + | TInteger int_ty -> F.pp_print_string fmt (int_name int_ty) (** [inside] constrols whether we should add parentheses or not around type applications (if [true] we add parentheses). @@ -1446,7 +674,7 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : (* Compute and register the type def name *) let def_name = match info with - | None -> ctx.fmt.type_name def.llbc_name + | None -> ctx_compute_type_name ctx def.llbc_name | Some info -> info.extract_name in let ctx = ctx_add (TypeId (TAdtId def.def_id)) def_name ctx in @@ -1464,10 +692,14 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : let field_names = FieldId.mapi (fun fid (field : field) -> - (fid, ctx.fmt.field_name def.llbc_name fid field.field_name)) + ( fid, + ctx_compute_field_name ctx def.llbc_name fid + field.field_name )) fields in - let cons_name = ctx.fmt.struct_constructor def.llbc_name in + let cons_name = + ctx_compute_struct_constructor ctx def.llbc_name + in (field_names, cons_name) | Some { body_info = Some (Struct (cons_name, field_names)); _ } -> let field_names = @@ -1503,12 +735,13 @@ let extract_type_decl_register_names (ctx : extraction_ctx) (def : type_decl) : VariantId.mapi (fun variant_id (variant : variant) -> let name = - ctx.fmt.variant_name def.llbc_name variant.variant_name + ctx_compute_variant_name ctx def.llbc_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.llbc_name in + let type_name = ctx_compute_type_name ctx def.llbc_name in type_name ^ "." ^ name else name in @@ -1570,8 +803,7 @@ 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_maps.names_map.names_set - (Some field_name) f.field_ty + ctx_compute_var_basename ctx (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 ^ " :"); @@ -1652,7 +884,7 @@ let extract_type_decl_enum_body (ctx : extraction_ctx) (fmt : F.formatter) let print_variant _variant_id (v : variant) = (* We don't lookup the name, because it may have a prefix for the type id (in the case of Lean) *) - let cons_name = ctx.fmt.variant_name def.llbc_name v.variant_name in + let cons_name = ctx_compute_variant_name ctx def.llbc_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 @@ -2059,7 +1291,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* 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 + let qualif = 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); diff --git a/compiler/Main.ml b/compiler/Main.ml index 0daf454d..e350da8a 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -178,7 +178,10 @@ let () = log#error "The Lean backend doesn't support the -use-fuel option"; fail ()); (* Lean can disambiguate the field names *) - record_fields_short_names := true + record_fields_short_names := true; + (* We exploit the fact that the variant name should always be + prefixed with the type name to prevent collisions *) + variant_concatenate_type_name := false | HOL4 -> (* We don't support fuel for the HOL4 backend *) if !use_fuel then ( diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 271d19ad..05e48af5 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -993,20 +993,10 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : 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 - * language, as well as some primitive names ("u32", etc.) *) - let variant_concatenate_type_name = - (* For Lean, we exploit the fact that the variant name should always be - prefixed with the type name to prevent collisions *) - match !Config.backend with Coq | FStar | HOL4 -> true | Lean -> false - in - (* Initialize the names map (we insert the names of the "primitives" - declarations, and insert the names of the local declarations later) *) - let fmt, names_maps = - Extract.mk_formatter_and_names_maps trans_ctx crate.name - variant_concatenate_type_name - in + (* Initialize the names map by registering the keywords used in the + language, as well as some primitive names ("u32", etc.). + We insert the names of the local declarations later. *) + let names_maps = Extract.initialize_names_maps () in (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) @@ -1061,7 +1051,6 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : ExtractBase.crate; trans_ctx; names_maps; - fmt; indent_incr = 2; use_dep_ite = !Config.backend = Lean && !Config.extract_decreases_clauses; fun_name_info = PureUtils.RegularFunIdMap.empty; -- cgit v1.2.3 From 42a0a49621f661e19137236f32a9ee212e4343a5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 17:38:14 +0100 Subject: Update the generation of names for the parent trait clauses --- compiler/ExtractBase.ml | 33 +++++++++++++++++++++++++++++---- 1 file changed, 29 insertions(+), 4 deletions(-) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 0b9908b2..6f227003 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1510,10 +1510,35 @@ let ctx_compute_trait_decl_constructor (ctx : extraction_ctx) let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) (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 ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ clause + (* We derive the name of the clause from the trait instance. + For instance, if the clause gives us an instance of `Foo`, + we generate a name along the lines of "fooU32Inst". + *) + (* We need to lookup the LLBC definitions, to have the original instantiation *) + let clause = + let trait_decl = + TraitDeclId.Map.find trait_decl.def_id ctx.crate.trait_decls + in + let clause = + List.find + (fun (c : Types.trait_clause) -> c.clause_id = clause.clause_id) + trait_decl.parent_clauses + in + let trait_id = clause.trait_id in + let impl_trait_decl = TraitDeclId.Map.find trait_id ctx.crate.trait_decls in + let params = trait_decl.generics in + let args = clause.clause_generics in + name_with_generics_to_simple_name ctx.trans_ctx impl_trait_decl.name params + args + in + let clause = String.concat "" clause in + let clause = + if !Config.record_fields_short_names then clause + else ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ clause + in + match !backend with + | FStar -> StringUtils.lowercase_first_letter clause + | Coq | HOL4 | Lean -> clause let ctx_compute_trait_type_name (ctx : extraction_ctx) (trait_decl : trait_decl) (item : string) : string = -- cgit v1.2.3 From 66e05354d0b5669f010aa6ebcdcd65437d6e2e35 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 18:57:31 +0100 Subject: Improve the generation of parent clause names --- compiler/ExtractBase.ml | 23 +++++++++++++++++++---- compiler/ExtractName.ml | 24 ++++++++++++++++++++---- compiler/TranslateCore.ml | 9 ++++++--- 3 files changed, 45 insertions(+), 11 deletions(-) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 6f227003..cfba7324 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1495,8 +1495,8 @@ let ctx_compute_trait_impl_name (ctx : extraction_ctx) (trait_decl : trait_decl) in let params = trait_impl.generics in let args = trait_impl.impl_trait.decl_generics in - name_with_generics_to_simple_name ctx.trans_ctx trait_decl.llbc_name params - args + trait_name_with_generics_to_simple_name ctx.trans_ctx trait_decl.llbc_name + params args in let name = flatten_name name in match !backend with @@ -1516,6 +1516,21 @@ let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) *) (* We need to lookup the LLBC definitions, to have the original instantiation *) let clause = + (* If the current trait decl and the trait decl referenced by the clause + are in the same namespace, we try to simplify the names. We do so by + removing the common prefixes in their names. + + For instance, if we have: + {[ + // This is file traits.rs + trait Parent {} + + trait Child : Parent {} + ]} + For the parent clause of trait [Child] we would like to generate + the name: "ParentInst", rather than "traitParentInst". + *) + let prefix = Some trait_decl.llbc_name in let trait_decl = TraitDeclId.Map.find trait_decl.def_id ctx.crate.trait_decls in @@ -1528,8 +1543,8 @@ let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) let impl_trait_decl = TraitDeclId.Map.find trait_id ctx.crate.trait_decls in let params = trait_decl.generics in let args = clause.clause_generics in - name_with_generics_to_simple_name ctx.trans_ctx impl_trait_decl.name params - args + trait_name_with_generics_to_simple_name ctx.trans_ctx ~prefix + impl_trait_decl.name params args in let clause = String.concat "" clause in let clause = diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 6d50ed73..f7177223 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -82,14 +82,30 @@ let pattern_to_trait_impl_extract_name = pattern_to_extract_name true (* TODO: this is provisional. We just want to make sure that the extraction names we derive from the patterns (for the builtin definitions) are consistent with the extraction names we derive from the Rust names *) -let name_to_simple_name (ctx : ctx) (n : Types.name) : string list = +let name_to_simple_name (ctx : ctx) (is_trait_impl : bool) (n : Types.name) : + string list = let c : to_pat_config = { tgt = TkName } in - pattern_to_extract_name false (name_to_pattern ctx c n) + pattern_to_extract_name is_trait_impl (name_to_pattern ctx c n) -let name_with_generics_to_simple_name (ctx : ctx) (n : Types.name) +(** If the [prefix] is Some, we attempt to remove the common prefix + between [prefix] and [name] from [name] *) +let name_with_generics_to_simple_name (ctx : ctx) (is_trait_impl : bool) + ?(prefix : Types.name option = None) (name : Types.name) (p : Types.generic_params) (g : Types.generic_args) : string list = let c : to_pat_config = { tgt = TkName } in - pattern_to_extract_name true (name_with_generics_to_pattern ctx c n p g) + let name = name_with_generics_to_pattern ctx c name p g in + let name = + match prefix with + | None -> name + | Some prefix -> + let prefix = + name_with_generics_to_pattern ctx c prefix + TypesUtils.empty_generic_params TypesUtils.empty_generic_args + in + let _, _, name = pattern_common_prefix prefix name in + name + in + pattern_to_extract_name is_trait_impl name (* (* Prepare a name. diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index f251e169..abf4fcf7 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -65,9 +65,11 @@ let name_to_simple_name (ctx : trans_ctx) (n : Types.name) : string list = trait_decls = ctx.trait_decls_ctx.trait_decls; } in - name_to_simple_name mctx n + let is_trait_impl = false in + name_to_simple_name mctx is_trait_impl n -let name_with_generics_to_simple_name (ctx : trans_ctx) (n : Types.name) +let trait_name_with_generics_to_simple_name (ctx : trans_ctx) + ?(prefix : Types.name option = None) (n : Types.name) (p : Types.generic_params) (g : Types.generic_args) : string list = let mctx : Charon.NameMatcher.ctx = { @@ -76,4 +78,5 @@ let name_with_generics_to_simple_name (ctx : trans_ctx) (n : Types.name) trait_decls = ctx.trait_decls_ctx.trait_decls; } in - name_with_generics_to_simple_name mctx n p g + let is_trait_impl = true in + name_with_generics_to_simple_name mctx is_trait_impl ~prefix n p g -- cgit v1.2.3 From 184e27bce209f7a852c2adc7e0598ed75ac8452d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 21 Nov 2023 18:58:04 +0100 Subject: Regenerate the files --- tests/coq/traits/Traits.v | 58 +++++++++++++++++++++++-------------------- tests/fstar/traits/Traits.fst | 36 ++++++++++++++------------- tests/lean/Traits.lean | 38 +++++++++++++++------------- 3 files changed, 71 insertions(+), 61 deletions(-) diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index f0875a29..93ff9fe3 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -200,12 +200,12 @@ Definition h3 (** Trait declaration: [traits::OfTypeBis] Source: 'src/traits.rs', lines 109:0-109:36 *) Record OfTypeBis_t (Self T : Type) := mkOfTypeBis_t { - OfTypeBis_tOfTypeBis_t_parent_clause_0 : ToType_t T Self; + OfTypeBis_tOfTypeBis_t_ToTypeTSelfInst : ToType_t T Self; OfTypeBis_t_of_type : T -> result Self; }. Arguments mkOfTypeBis_t { _ _ }. -Arguments OfTypeBis_tOfTypeBis_t_parent_clause_0 { _ _ }. +Arguments OfTypeBis_tOfTypeBis_t_ToTypeTSelfInst { _ _ }. Arguments OfTypeBis_t_of_type { _ _ }. (** [traits::h4]: forward function @@ -395,19 +395,20 @@ Arguments mkParentTrait1_t { _ }. (** Trait declaration: [traits::ChildTrait] Source: 'src/traits.rs', lines 206:0-206:49 *) Record ChildTrait_t (Self : Type) := mkChildTrait_t { - ChildTrait_tChildTrait_t_parent_clause_0 : ParentTrait0_t Self; - ChildTrait_tChildTrait_t_parent_clause_1 : ParentTrait1_t Self; + ChildTrait_tChildTrait_t_ParentTrait0SelfInst : ParentTrait0_t Self; + ChildTrait_tChildTrait_t_ParentTrait1SelfInst : ParentTrait1_t Self; }. Arguments mkChildTrait_t { _ }. -Arguments ChildTrait_tChildTrait_t_parent_clause_0 { _ }. -Arguments ChildTrait_tChildTrait_t_parent_clause_1 { _ }. +Arguments ChildTrait_tChildTrait_t_ParentTrait0SelfInst { _ }. +Arguments ChildTrait_tChildTrait_t_ParentTrait1SelfInst { _ }. (** [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 *) Definition test_child_trait1 (T : Type) (inst : ChildTrait_t T) (x : T) : result alloc_string_String_t := - inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_name) x + inst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_name) + x . (** [traits::test_child_trait2]: forward function @@ -415,9 +416,9 @@ Definition test_child_trait1 Definition test_child_trait2 (T : Type) (inst : ChildTrait_t T) (x : T) : result - inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_tParentTrait0_t_W) + inst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_tParentTrait0_t_W) := - inst.(ChildTrait_tChildTrait_t_parent_clause_0).(ParentTrait0_t_get_w) x + inst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_w) x . (** [traits::order1]: forward function @@ -432,11 +433,11 @@ Definition order1 (** Trait declaration: [traits::ChildTrait1] Source: 'src/traits.rs', lines 222:0-222:35 *) Record ChildTrait1_t (Self : Type) := mkChildTrait1_t { - ChildTrait1_tChildTrait1_t_parent_clause_0 : ParentTrait1_t Self; + ChildTrait1_tChildTrait1_t_ParentTrait1SelfInst : ParentTrait1_t Self; }. Arguments mkChildTrait1_t { _ }. -Arguments ChildTrait1_tChildTrait1_t_parent_clause_0 { _ }. +Arguments ChildTrait1_tChildTrait1_t_ParentTrait1SelfInst { _ }. (** Trait implementation: [traits::{usize#9}] Source: 'src/traits.rs', lines 224:0-224:27 *) @@ -446,7 +447,8 @@ Definition traits_ParentTrait1UsizeInst : ParentTrait1_t usize (** Trait implementation: [traits::{usize#10}] Source: 'src/traits.rs', lines 225:0-225:26 *) Definition traits_ChildTrait1UsizeInst : ChildTrait1_t usize := {| - ChildTrait1_tChildTrait1_t_parent_clause_0 := traits_ParentTrait1UsizeInst; + ChildTrait1_tChildTrait1_t_ParentTrait1SelfInst := + traits_ParentTrait1UsizeInst; |}. (** Trait declaration: [traits::Iterator] @@ -485,12 +487,13 @@ Arguments mkFromResidual_t { _ _ }. Source: 'src/traits.rs', lines 246:0-246:48 *) Record Try_t (Self : Type) := mkTry_t { Try_tTry_t_Residual : Type; - Try_tTry_t_parent_clause_0 : FromResidual_t Self Try_tTry_t_Residual; + Try_tTry_t_FromResidualSelftraitsTrySelfResidualInst : FromResidual_t Self + Try_tTry_t_Residual; }. Arguments mkTry_t { _ }. Arguments Try_tTry_t_Residual { _ }. -Arguments Try_tTry_t_parent_clause_0 { _ }. +Arguments Try_tTry_t_FromResidualSelftraitsTrySelfResidualInst { _ }. (** Trait declaration: [traits::WithTarget] Source: 'src/traits.rs', lines 252:0-252:20 *) @@ -516,15 +519,15 @@ Arguments ParentTrait2_tParentTrait2_t_U_clause_0 { _ }. (** Trait declaration: [traits::ChildTrait2] Source: 'src/traits.rs', lines 260:0-260:35 *) Record ChildTrait2_t (Self : Type) := mkChildTrait2_t { - ChildTrait2_tChildTrait2_t_parent_clause_0 : ParentTrait2_t Self; + ChildTrait2_tChildTrait2_t_ParentTrait2SelfInst : ParentTrait2_t Self; ChildTrait2_t_convert : - (ChildTrait2_tChildTrait2_t_parent_clause_0).(ParentTrait2_tParentTrait2_t_U) + (ChildTrait2_tChildTrait2_t_ParentTrait2SelfInst).(ParentTrait2_tParentTrait2_t_U) -> result - (ChildTrait2_tChildTrait2_t_parent_clause_0).(ParentTrait2_tParentTrait2_t_U_clause_0).(WithTarget_tWithTarget_t_Target); + (ChildTrait2_tChildTrait2_t_ParentTrait2SelfInst).(ParentTrait2_tParentTrait2_t_U_clause_0).(WithTarget_tWithTarget_t_Target); }. Arguments mkChildTrait2_t { _ }. -Arguments ChildTrait2_tChildTrait2_t_parent_clause_0 { _ }. +Arguments ChildTrait2_tChildTrait2_t_ParentTrait2SelfInst { _ }. Arguments ChildTrait2_t_convert { _ }. (** Trait implementation: [traits::{u32#11}] @@ -548,7 +551,8 @@ Definition u32_convert (x : u32) : result u32 := (** Trait implementation: [traits::{u32#13}] Source: 'src/traits.rs', lines 272:0-272:24 *) Definition traits_ChildTrait2U32Inst : ChildTrait2_t u32 := {| - ChildTrait2_tChildTrait2_t_parent_clause_0 := traits_ParentTrait2U32Inst; + ChildTrait2_tChildTrait2_t_ParentTrait2SelfInst := + traits_ParentTrait2U32Inst; ChildTrait2_t_convert := u32_convert; |}. @@ -566,29 +570,29 @@ Arguments CFnOnce_t_call_once { _ _ }. (** Trait declaration: [traits::CFnMut] Source: 'src/traits.rs', lines 292:0-292:37 *) Record CFnMut_t (Self Args : Type) := mkCFnMut_t { - CFnMut_tCFnMut_t_parent_clause_0 : CFnOnce_t Self Args; + CFnMut_tCFnMut_t_CFnOnceSelfArgsInst : CFnOnce_t Self Args; CFnMut_t_call_mut : Self -> Args -> result - (CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output); + (CFnMut_tCFnMut_t_CFnOnceSelfArgsInst).(CFnOnce_tCFnOnce_t_Output); CFnMut_t_call_mut_back : Self -> Args -> - (CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output) -> result - Self; + (CFnMut_tCFnMut_t_CFnOnceSelfArgsInst).(CFnOnce_tCFnOnce_t_Output) -> + result Self; }. Arguments mkCFnMut_t { _ _ }. -Arguments CFnMut_tCFnMut_t_parent_clause_0 { _ _ }. +Arguments CFnMut_tCFnMut_t_CFnOnceSelfArgsInst { _ _ }. Arguments CFnMut_t_call_mut { _ _ }. Arguments CFnMut_t_call_mut_back { _ _ }. (** Trait declaration: [traits::CFn] Source: 'src/traits.rs', lines 296:0-296:33 *) Record CFn_t (Self Args : Type) := mkCFn_t { - CFn_tCFn_t_parent_clause_0 : CFnMut_t Self Args; + CFn_tCFn_t_CFnMutSelfArgsInst : CFnMut_t Self Args; CFn_t_call_mut : Self -> Args -> result - (CFn_tCFn_t_parent_clause_0).(CFnMut_tCFnMut_t_parent_clause_0).(CFnOnce_tCFnOnce_t_Output); + (CFn_tCFn_t_CFnMutSelfArgsInst).(CFnMut_tCFnMut_t_CFnOnceSelfArgsInst).(CFnOnce_tCFnOnce_t_Output); }. Arguments mkCFn_t { _ _ }. -Arguments CFn_tCFn_t_parent_clause_0 { _ _ }. +Arguments CFn_tCFn_t_CFnMutSelfArgsInst { _ _ }. Arguments CFn_t_call_mut { _ _ }. (** [traits::incr_u32]: forward function diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 669c1dff..63ac307f 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -157,7 +157,7 @@ let h3 (** Trait declaration: [traits::OfTypeBis] Source: 'src/traits.rs', lines 109:0-109:36 *) noeq type ofTypeBis_t (self t : Type0) = { - parent_clause_0 : toType_t t self; + toTypeTSelfInst : toType_t t self; of_type : t -> result self; } @@ -311,23 +311,23 @@ type parentTrait1_t (self : Type0) = unit (** Trait declaration: [traits::ChildTrait] Source: 'src/traits.rs', lines 206:0-206:49 *) noeq type childTrait_t (self : Type0) = { - parent_clause_0 : parentTrait0_t self; - parent_clause_1 : parentTrait1_t self; + parentTrait0SelfInst : parentTrait0_t self; + parentTrait1SelfInst : parentTrait1_t self; } (** [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 *) let test_child_trait1 (t : Type0) (inst : childTrait_t t) (x : t) : result alloc_string_String_t = - inst.parent_clause_0.get_name x + inst.parentTrait0SelfInst.get_name x (** [traits::test_child_trait2]: forward function Source: 'src/traits.rs', lines 213:0-213:54 *) let test_child_trait2 (t : Type0) (inst : childTrait_t t) (x : t) : - result inst.parent_clause_0.tW + result inst.parentTrait0SelfInst.tW = - inst.parent_clause_0.get_w x + inst.parentTrait0SelfInst.get_w x (** [traits::order1]: forward function Source: 'src/traits.rs', lines 219:0-219:59 *) @@ -340,7 +340,7 @@ let order1 (** Trait declaration: [traits::ChildTrait1] Source: 'src/traits.rs', lines 222:0-222:35 *) noeq type childTrait1_t (self : Type0) = { - parent_clause_0 : parentTrait1_t self; + parentTrait1SelfInst : parentTrait1_t self; } (** Trait implementation: [traits::{usize#9}] @@ -350,7 +350,7 @@ let traits_ParentTrait1UsizeInst : parentTrait1_t usize = () (** Trait implementation: [traits::{usize#10}] Source: 'src/traits.rs', lines 225:0-225:26 *) let traits_ChildTrait1UsizeInst : childTrait1_t usize = { - parent_clause_0 = traits_ParentTrait1UsizeInst; + parentTrait1SelfInst = traits_ParentTrait1UsizeInst; } (** Trait declaration: [traits::Iterator] @@ -374,7 +374,7 @@ type fromResidual_t (self t : Type0) = unit Source: 'src/traits.rs', lines 246:0-246:48 *) noeq type try_t (self : Type0) = { tResidual : Type0; - parent_clause_0 : fromResidual_t self tResidual; + fromResidualSelftraitsTrySelfResidualInst : fromResidual_t self tResidual; } (** Trait declaration: [traits::WithTarget] @@ -391,8 +391,9 @@ noeq type parentTrait2_t (self : Type0) = { (** Trait declaration: [traits::ChildTrait2] Source: 'src/traits.rs', lines 260:0-260:35 *) noeq type childTrait2_t (self : Type0) = { - parent_clause_0 : parentTrait2_t self; - convert : parent_clause_0.tU -> result parent_clause_0.tU_clause_0.tTarget; + parentTrait2SelfInst : parentTrait2_t self; + convert : parentTrait2SelfInst.tU -> result + parentTrait2SelfInst.tU_clause_0.tTarget; } (** Trait implementation: [traits::{u32#11}] @@ -414,7 +415,7 @@ let u32_convert (x : u32) : result u32 = (** Trait implementation: [traits::{u32#13}] Source: 'src/traits.rs', lines 272:0-272:24 *) let traits_ChildTrait2U32Inst : childTrait2_t u32 = { - parent_clause_0 = traits_ParentTrait2U32Inst; + parentTrait2SelfInst = traits_ParentTrait2U32Inst; convert = u32_convert; } @@ -428,16 +429,17 @@ noeq type cFnOnce_t (self args : Type0) = { (** Trait declaration: [traits::CFnMut] Source: 'src/traits.rs', lines 292:0-292:37 *) noeq type cFnMut_t (self args : Type0) = { - parent_clause_0 : cFnOnce_t self args; - call_mut : self -> args -> result parent_clause_0.tOutput; - call_mut_back : self -> args -> parent_clause_0.tOutput -> result self; + cFnOnceSelfArgsInst : cFnOnce_t self args; + call_mut : self -> args -> result cFnOnceSelfArgsInst.tOutput; + call_mut_back : self -> args -> cFnOnceSelfArgsInst.tOutput -> result self; } (** Trait declaration: [traits::CFn] Source: 'src/traits.rs', lines 296:0-296:33 *) noeq type cFn_t (self args : Type0) = { - parent_clause_0 : cFnMut_t self args; - call_mut : self -> args -> result parent_clause_0.parent_clause_0.tOutput; + cFnMutSelfArgsInst : cFnMut_t self args; + call_mut : self -> args -> result + cFnMutSelfArgsInst.cFnOnceSelfArgsInst.tOutput; } (** [traits::incr_u32]: forward function diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index f854da76..0aa68c5e 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -170,7 +170,7 @@ def h3 /- Trait declaration: [traits::OfTypeBis] Source: 'src/traits.rs', lines 109:0-109:36 -/ structure OfTypeBis (Self T : Type) where - parent_clause_0 : ToType T Self + ToTypeTSelfInst : ToType T Self of_type : T → Result Self /- [traits::h4]: forward function @@ -327,20 +327,22 @@ structure ParentTrait1 (Self : Type) where /- Trait declaration: [traits::ChildTrait] Source: 'src/traits.rs', lines 206:0-206:49 -/ structure ChildTrait (Self : Type) where - parent_clause_0 : ParentTrait0 Self - parent_clause_1 : ParentTrait1 Self + ParentTrait0SelfInst : ParentTrait0 Self + ParentTrait1SelfInst : ParentTrait1 Self /- [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 -/ def test_child_trait1 (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := - inst.parent_clause_0.get_name x + inst.ParentTrait0SelfInst.get_name x /- [traits::test_child_trait2]: forward function Source: 'src/traits.rs', lines 213:0-213:54 -/ def test_child_trait2 - (T : Type) (inst : ChildTrait T) (x : T) : Result inst.parent_clause_0.W := - inst.parent_clause_0.get_w x + (T : Type) (inst : ChildTrait T) (x : T) : + Result inst.ParentTrait0SelfInst.W + := + inst.ParentTrait0SelfInst.get_w x /- [traits::order1]: forward function Source: 'src/traits.rs', lines 219:0-219:59 -/ @@ -353,7 +355,7 @@ def order1 /- Trait declaration: [traits::ChildTrait1] Source: 'src/traits.rs', lines 222:0-222:35 -/ structure ChildTrait1 (Self : Type) where - parent_clause_0 : ParentTrait1 Self + ParentTrait1SelfInst : ParentTrait1 Self /- Trait implementation: [traits::{usize#9}] Source: 'src/traits.rs', lines 224:0-224:27 -/ @@ -363,7 +365,7 @@ def traits.ParentTrait1UsizeInst : ParentTrait1 Usize := { /- Trait implementation: [traits::{usize#10}] Source: 'src/traits.rs', lines 225:0-225:26 -/ def traits.ChildTrait1UsizeInst : ChildTrait1 Usize := { - parent_clause_0 := traits.ParentTrait1UsizeInst + ParentTrait1SelfInst := traits.ParentTrait1UsizeInst } /- Trait declaration: [traits::Iterator] @@ -387,7 +389,7 @@ structure FromResidual (Self T : Type) where Source: 'src/traits.rs', lines 246:0-246:48 -/ structure Try (Self : Type) where Residual : Type - parent_clause_0 : FromResidual Self Residual + FromResidualSelftraitsTrySelfResidualInst : FromResidual Self Residual /- Trait declaration: [traits::WithTarget] Source: 'src/traits.rs', lines 252:0-252:20 -/ @@ -403,8 +405,9 @@ structure ParentTrait2 (Self : Type) where /- Trait declaration: [traits::ChildTrait2] Source: 'src/traits.rs', lines 260:0-260:35 -/ structure ChildTrait2 (Self : Type) where - parent_clause_0 : ParentTrait2 Self - convert : parent_clause_0.U → Result parent_clause_0.U_clause_0.Target + ParentTrait2SelfInst : ParentTrait2 Self + convert : ParentTrait2SelfInst.U → Result + ParentTrait2SelfInst.U_clause_0.Target /- Trait implementation: [traits::{u32#11}] Source: 'src/traits.rs', lines 264:0-264:23 -/ @@ -427,7 +430,7 @@ def U32.convert (x : U32) : Result U32 := /- Trait implementation: [traits::{u32#13}] Source: 'src/traits.rs', lines 272:0-272:24 -/ def traits.ChildTrait2U32Inst : ChildTrait2 U32 := { - parent_clause_0 := traits.ParentTrait2U32Inst + ParentTrait2SelfInst := traits.ParentTrait2U32Inst convert := U32.convert } @@ -440,15 +443,16 @@ structure CFnOnce (Self Args : Type) where /- Trait declaration: [traits::CFnMut] Source: 'src/traits.rs', lines 292:0-292:37 -/ structure CFnMut (Self Args : Type) where - parent_clause_0 : CFnOnce Self Args - call_mut : Self → Args → Result parent_clause_0.Output - call_mut_back : Self → Args → parent_clause_0.Output → Result Self + CFnOnceSelfArgsInst : CFnOnce Self Args + call_mut : Self → Args → Result CFnOnceSelfArgsInst.Output + call_mut_back : Self → Args → CFnOnceSelfArgsInst.Output → Result Self /- Trait declaration: [traits::CFn] Source: 'src/traits.rs', lines 296:0-296:33 -/ structure CFn (Self Args : Type) where - parent_clause_0 : CFnMut Self Args - call_mut : Self → Args → Result parent_clause_0.parent_clause_0.Output + CFnMutSelfArgsInst : CFnMut Self Args + call_mut : Self → Args → Result + CFnMutSelfArgsInst.CFnOnceSelfArgsInst.Output /- [traits::incr_u32]: forward function Source: 'src/traits.rs', lines 300:0-300:30 -/ -- cgit v1.2.3 From ba66f35a0e196c17757e06187cf2563abec253e5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 09:09:46 +0100 Subject: Improve further the generation of parent clause/trait clause names --- compiler/Extract.ml | 33 +++++++++++--- compiler/ExtractBase.ml | 102 ++++++++++++++++++++++++++++++++------------ compiler/ExtractName.ml | 2 + compiler/ExtractTypes.ml | 5 ++- compiler/Pure.ml | 27 ++++++++++++ compiler/PureMicroPasses.ml | 8 +++- compiler/PureUtils.ml | 4 ++ compiler/SymbolicToPure.ml | 44 ++++++++++++++----- 8 files changed, 177 insertions(+), 48 deletions(-) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index 16262c91..c8c16c08 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -1044,7 +1044,8 @@ let extract_fun_parameters (space : bool ref) (ctx : extraction_ctx) (* 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 = - ctx_add_generic_params def.signature.generics ctx + ctx_add_generic_params def.llbc_name def.signature.llbc_generics + def.signature.generics ctx in (* Print the generics *) (* Open a box for the generics *) @@ -1578,7 +1579,10 @@ let extract_fun_decl_hol4_opaque (ctx : extraction_ctx) (fmt : F.formatter) 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_generic_params def.signature.generics ctx in + let ctx, _, _, _ = + ctx_add_generic_params def.llbc_name def.signature.llbc_generics + 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 *) @@ -2164,8 +2168,14 @@ let extract_trait_decl_method_items (ctx : extraction_ctx) (fmt : F.formatter) generic_params_drop_prefix ~drop_trait_clauses decl.generics f.signature.generics in + (* Note that we do not filter the LLBC generic parameters. + This is ok because: + - we only use them to find meaningful names for the trait clauses + - we only generate trait clauses for the clauses we find in the + pure generics *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params generics ctx + ctx_add_generic_params f.llbc_name f.signature.llbc_generics generics + ctx in let backend_uses_forall = match !backend with Coq | Lean -> true | FStar | HOL4 -> false @@ -2229,7 +2239,7 @@ let extract_trait_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params generics ctx + ctx_add_generic_params decl.llbc_name decl.llbc_generics generics ctx in extract_generic_params ctx fmt TypeDeclId.Set.empty generics type_params cg_params trait_clauses; @@ -2448,8 +2458,17 @@ let extract_trait_impl_method_items (ctx : extraction_ctx) (fmt : F.formatter) { 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 + (* Register and print the quantified generics. + + Note that we do not filter the LLBC generic parameters. + This is ok because: + - we only use them to find meaningful names for the trait clauses + - we only generate trait clauses for the clauses we find in the + pure generics *) + let ctx, f_tys, f_cgs, f_tcs = + ctx_add_generic_params f.llbc_name f.signature.llbc_generics 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 f_tys f_cgs f_tcs; @@ -2515,7 +2534,7 @@ let extract_trait_impl (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params impl.generics ctx + ctx_add_generic_params impl.llbc_name impl.llbc_generics impl.generics ctx in let all_generics = (type_params, cg_params, trait_clauses) in extract_generic_params ctx fmt TypeDeclId.Set.empty impl.generics type_params diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index cfba7324..c6158847 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1488,13 +1488,8 @@ let ctx_compute_trait_impl_name (ctx : extraction_ctx) (trait_decl : trait_decl) where the instance has been defined (it is indepedent of the file, etc.). *) let name = - (* We need to lookup the LLBC definitions, to have the original instantiation *) - let trait_impl = - TraitImplId.Map.find trait_impl.def_id - ctx.trans_ctx.trait_impls_ctx.trait_impls - in - let params = trait_impl.generics in - let args = trait_impl.impl_trait.decl_generics in + let params = trait_impl.llbc_generics in + let args = trait_impl.llbc_impl_trait.decl_generics in trait_name_with_generics_to_simple_name ctx.trans_ctx trait_decl.llbc_name params args in @@ -1508,15 +1503,29 @@ let ctx_compute_trait_decl_constructor (ctx : extraction_ctx) let name = ctx_compute_trait_decl_name ctx trait_decl in ExtractBuiltin.mk_struct_constructor name -let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) - (trait_decl : trait_decl) (clause : trait_clause) : string = +(** Helper to derive names for parent trait clauses and for variables + for trait instances. + + We derive the name from the type of the clause (i.e., the trait ref + the clause implements). + For instance, if a trait clause is for the trait ref "Trait", + we generate a name like "traitBoxUsizeInst". This is more meaningful + that giving it a generic name with an index (such as "parent_clause_1" + or "inst3"). + + Because we want to be precise when deriving the name, we use the + original LLBC types, that is the types from before the translation + to pure, which simplifies types like boxes and references. + *) +let ctx_compute_trait_clause_name (ctx : extraction_ctx) + (current_def_name : Types.name) (params : Types.generic_params) + (clauses : Types.trait_clause list) (clause_id : trait_clause_id) : string = (* We derive the name of the clause from the trait instance. For instance, if the clause gives us an instance of `Foo`, we generate a name along the lines of "fooU32Inst". *) - (* We need to lookup the LLBC definitions, to have the original instantiation *) let clause = - (* If the current trait decl and the trait decl referenced by the clause + (* If the current def and the trait decl referenced by the clause are in the same namespace, we try to simplify the names. We do so by removing the common prefixes in their names. @@ -1530,23 +1539,33 @@ let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) For the parent clause of trait [Child] we would like to generate the name: "ParentInst", rather than "traitParentInst". *) - let prefix = Some trait_decl.llbc_name in - let trait_decl = - TraitDeclId.Map.find trait_decl.def_id ctx.crate.trait_decls - in + let prefix = Some current_def_name in let clause = List.find - (fun (c : Types.trait_clause) -> c.clause_id = clause.clause_id) - trait_decl.parent_clauses + (fun (c : Types.trait_clause) -> c.clause_id = clause_id) + clauses in let trait_id = clause.trait_id in let impl_trait_decl = TraitDeclId.Map.find trait_id ctx.crate.trait_decls in - let params = trait_decl.generics in let args = clause.clause_generics in trait_name_with_generics_to_simple_name ctx.trans_ctx ~prefix impl_trait_decl.name params args in - let clause = String.concat "" clause in + String.concat "" clause + +let ctx_compute_trait_parent_clause_name (ctx : extraction_ctx) + (trait_decl : trait_decl) (clause : trait_clause) : string = + (* We derive the name of the clause from the trait instance. + For instance, if the clause gives us an instance of `Foo`, + we generate a name along the lines of "fooU32Inst". + *) + (* We need to lookup the LLBC definitions, to have the original instantiation *) + let clause = + let current_def_name = trait_decl.llbc_name in + let params = trait_decl.llbc_generics in + ctx_compute_trait_clause_name ctx current_def_name params + trait_decl.llbc_parent_clauses clause.clause_id + in let clause = if !Config.record_fields_short_names then clause else ctx_compute_trait_decl_name ctx trait_decl ^ "_" ^ clause @@ -1751,10 +1770,18 @@ let ctx_compute_const_generic_var_basename (_ctx : extraction_ctx) In the traduction we explicitely manipulate the trait clause instances, that is we introduce one input variable for each trait clause. *) -let ctx_compute_trait_clause_basename (_ctx : extraction_ctx) - (_clause : trait_clause) : string = - (* TODO: actually use the clause to derive the name *) - "inst" +let ctx_compute_trait_clause_basename (ctx : extraction_ctx) + (current_def_name : Types.name) (params : Types.generic_params) + (clause_id : trait_clause_id) : string = + (* This is similar to {!ctx_compute_trait_parent_clause_name}: we + derive the name from the trait reference (i.e., from the type) *) + let clause = + ctx_compute_trait_clause_name ctx current_def_name params + params.trait_clauses clause_id + in + match !backend with + | FStar | Coq | HOL4 -> StringUtils.lowercase_first_letter clause + | Lean -> clause let trait_self_clause_basename = "self_clause" @@ -1845,11 +1872,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_local_trait_clauses (clauses : trait_clause list) +(** Returns the lists of names for: + - the type variables + - the const generic variables + - the trait clauses + + For the [current_name_def] and the [llbc_generics]: we use them to derive + pretty names for the trait clauses. See {!ctx_compute_trait_clause_name} + for additional information. + *) +let ctx_add_local_trait_clauses (current_def_name : Types.name) + (llbc_generics : Types.generic_params) (clauses : trait_clause list) (ctx : extraction_ctx) : extraction_ctx * string list = List.fold_left_map (fun ctx (c : trait_clause) -> - let basename = ctx_compute_trait_clause_basename ctx c in + let basename = + ctx_compute_trait_clause_basename ctx current_def_name llbc_generics + c.clause_id + in ctx_add_local_trait_clause basename c.clause_id ctx) ctx clauses @@ -1857,13 +1897,21 @@ let ctx_add_local_trait_clauses (clauses : trait_clause list) - the type variables - the const generic variables - the trait clauses + + For the [current_name_def] and the [llbc_generics]: we use them to derive + pretty names for the trait clauses. See {!ctx_compute_trait_clause_name} + for additional information. *) -let ctx_add_generic_params (generics : generic_params) (ctx : extraction_ctx) : +let ctx_add_generic_params (current_def_name : Types.name) + (llbc_generics : Types.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_local_trait_clauses trait_clauses ctx in + let ctx, tcs = + ctx_add_local_trait_clauses current_def_name llbc_generics trait_clauses ctx + in (ctx, tys, cgs, tcs) let ctx_add_decreases_proof (def : fun_decl) (ctx : extraction_ctx) : diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index f7177223..0943aefe 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -2,6 +2,8 @@ open Charon.NameMatcher +let log = Logging.extract_log + module NameMatcherMap = struct type 'a t = (pattern * 'a) list diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index c9be5abe..c6212d31 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -1272,7 +1272,7 @@ let extract_type_decl_gen (ctx : extraction_ctx) (fmt : F.formatter) (* Add the type and const generic params - note that we need those bindings only for the * body translation (they are not top-level) *) let ctx_body, type_params, cg_params, trait_clauses = - ctx_add_generic_params def.generics ctx + ctx_add_generic_params def.llbc_name def.llbc_generics def.generics ctx in (* Add a break before *) if !backend <> HOL4 || not (decl_is_first_from_group kind) then @@ -1515,7 +1515,8 @@ let extract_type_decl_record_field_projectors (ctx : extraction_ctx) if is_rec then (* Add the type params *) let ctx, type_params, cg_params, trait_clauses = - ctx_add_generic_params decl.generics ctx + ctx_add_generic_params decl.llbc_name decl.llbc_generics 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 diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 42f51075..50849df9 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -395,6 +395,12 @@ type type_decl = { *) meta : meta; generics : generic_params; + llbc_generics : Types.generic_params; + (** We use the LLBC generics to generate "pretty" names, for instance + for the variables we introduce for the trait clauses: we derive + those names from the types, and when doing so it is more meaningful + to derive them from the original LLBC types from before the + simplification of types like boxes and references. *) kind : type_decl_kind; preds : predicates; } @@ -922,6 +928,12 @@ type fun_sig_info = { type fun_sig = { generics : generic_params; (** TODO: we should analyse the signature to make the type parameters implicit whenever possible *) + llbc_generics : Types.generic_params; + (** We use the LLBC generics to generate "pretty" names, for instance + for the variables we introduce for the trait clauses: we derive + those names from the types, and when doing so it is more meaningful + to derive them from the original LLBC types from before the + simplification of types like boxes and references. *) preds : predicates; inputs : ty list; (** The types of the inputs. @@ -1028,8 +1040,15 @@ type trait_decl = { name : string; meta : meta; generics : generic_params; + llbc_generics : Types.generic_params; + (** We use the LLBC generics to generate "pretty" names, for instance + for the variables we introduce for the trait clauses: we derive + those names from the types, and when doing so it is more meaningful + to derive them from the original LLBC types from before the + simplification of types like boxes and references. *) preds : predicates; parent_clauses : trait_clause list; + llbc_parent_clauses : Types.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; @@ -1044,7 +1063,15 @@ type trait_impl = { name : string; meta : meta; impl_trait : trait_decl_ref; + llbc_impl_trait : Types.trait_decl_ref; + (** Same remark as for {llbc_generics}. *) generics : generic_params; + llbc_generics : Types.generic_params; + (** We use the LLBC generics to generate "pretty" names, for instance + for the variables we introduce for the trait clauses: we derive + those names from the types, and when doing so it is more meaningful + to derive them from the original LLBC types from before the + simplification of types like boxes and references. *) preds : predicates; parent_trait_refs : trait_ref list; consts : (trait_item_name * (ty * global_decl_id)) list; diff --git a/compiler/PureMicroPasses.ml b/compiler/PureMicroPasses.ml index 8463f56c..d0741b29 100644 --- a/compiler/PureMicroPasses.ml +++ b/compiler/PureMicroPasses.ml @@ -1364,6 +1364,7 @@ let decompose_loops (def : fun_decl) : fun_decl * fun_decl list = let loop_sig = { generics = fun_sig.generics; + llbc_generics = fun_sig.llbc_generics; preds = fun_sig.preds; inputs = inputs_tys; output; @@ -2127,7 +2128,8 @@ let filter_loop_inputs (transl : pure_fun_translation list) : let num_filtered = List.length (List.filter (fun b -> not b) used_info) in - let { generics; preds; inputs; output; doutputs; info } = + let { generics; llbc_generics; preds; inputs; output; doutputs; info } + = decl.signature in let { @@ -2155,7 +2157,9 @@ let filter_loop_inputs (transl : pure_fun_translation list) : effect_info; } in - let signature = { generics; preds; inputs; output; doutputs; info } in + let signature = + { generics; llbc_generics; preds; inputs; output; doutputs; info } + in { decl with signature } in diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 992ea499..6b0deb73 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -651,8 +651,10 @@ let trait_decl_is_empty (trait_decl : trait_decl) : bool = llbc_name = _; meta = _; generics = _; + llbc_generics = _; preds = _; parent_clauses; + llbc_parent_clauses = _; consts; types; required_methods; @@ -671,7 +673,9 @@ let trait_impl_is_empty (trait_impl : trait_impl) : bool = llbc_name = _; meta = _; impl_trait = _; + llbc_impl_trait = _; generics = _; + llbc_generics = _; preds = _; parent_trait_refs; consts; diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 5dee23db..4df3ee73 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -497,7 +497,17 @@ let translate_type_decl (ctx : Contexts.decls_ctx) (def : T.type_decl) : let preds = translate_predicates def.preds in let is_local = def.is_local in let meta = def.meta in - { def_id; is_local; llbc_name; name; meta; generics; kind; preds } + { + def_id; + is_local; + llbc_name; + name; + meta; + generics; + llbc_generics = def.generics; + kind; + preds; + } let translate_type_id (id : T.type_id) : type_id = match id with @@ -1029,7 +1039,17 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) } in let preds = translate_predicates sg.preds in - let sg = { generics; preds; inputs; output; doutputs; info } in + let sg = + { + generics; + llbc_generics = sg.generics; + preds; + inputs; + output; + doutputs; + info; + } + in { sg; output_names } let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = @@ -3112,9 +3132,9 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) is_local; name = llbc_name; meta; - generics; + generics = llbc_generics; preds; - parent_clauses; + parent_clauses = llbc_parent_clauses; consts; types; required_methods; @@ -3128,9 +3148,9 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params generics in + let generics = translate_generic_params llbc_generics in let preds = translate_predicates preds in - let parent_clauses = List.map translate_trait_clause parent_clauses in + let parent_clauses = List.map translate_trait_clause llbc_parent_clauses in let consts = List.map (fun (name, (ty, id)) -> (name, (translate_fwd_ty type_infos ty, id))) @@ -3151,8 +3171,10 @@ let translate_trait_decl (ctx : Contexts.decls_ctx) (trait_decl : A.trait_decl) name; meta; generics; + llbc_generics; preds; parent_clauses; + llbc_parent_clauses; consts; types; required_methods; @@ -3166,8 +3188,8 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) is_local; name = llbc_name; meta; - impl_trait; - generics; + impl_trait = llbc_impl_trait; + generics = llbc_generics; preds; parent_trait_refs; consts; @@ -3179,14 +3201,14 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) in let type_infos = ctx.type_ctx.type_infos in let impl_trait = - translate_trait_decl_ref (translate_fwd_ty type_infos) impl_trait + translate_trait_decl_ref (translate_fwd_ty type_infos) llbc_impl_trait in let name = Print.Types.name_to_string (Print.Contexts.decls_ctx_to_fmt_env ctx) llbc_name in - let generics = translate_generic_params generics in + let generics = translate_generic_params llbc_generics in let preds = translate_predicates preds in let parent_trait_refs = List.map translate_strait_ref parent_trait_refs in let consts = @@ -3209,7 +3231,9 @@ let translate_trait_impl (ctx : Contexts.decls_ctx) (trait_impl : A.trait_impl) name; meta; impl_trait; + llbc_impl_trait; generics; + llbc_generics; preds; parent_trait_refs; consts; -- cgit v1.2.3 From 84a505ed9f193885175308ecc837922a41176b5b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 09:11:06 +0100 Subject: Regenerate the test files --- tests/coq/traits/Traits.v | 107 ++++++++++++++++++++++++------------------ tests/fstar/traits/Traits.fst | 106 ++++++++++++++++++++++++----------------- tests/lean/Traits.lean | 104 +++++++++++++++++++++++----------------- 3 files changed, 186 insertions(+), 131 deletions(-) diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index 93ff9fe3..0952a1df 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -67,8 +67,8 @@ Definition test_bool_trait_option (T : Type) (x : option T) : result bool := (** [traits::test_bool_trait]: forward function Source: 'src/traits.rs', lines 35:0-35:50 *) Definition test_bool_trait - (T : Type) (inst : BoolTrait_t T) (x : T) : result bool := - inst.(BoolTrait_t_get_bool) x + (T : Type) (boolTraitTInst : BoolTrait_t T) (x : T) : result bool := + boolTraitTInst.(BoolTrait_t_get_bool) x . (** Trait declaration: [traits::ToU64] @@ -94,30 +94,31 @@ Definition traits_ToU64U64Inst : ToU64_t u64 := {| (** [traits::{(A, A)#3}::to_u64]: forward function Source: 'src/traits.rs', lines 50:4-50:26 *) Definition pair_to_u64 - (A : Type) (inst : ToU64_t A) (self : (A * A)) : result u64 := + (A : Type) (toU64AInst : ToU64_t A) (self : (A * A)) : result u64 := let (t, t0) := self in - i <- inst.(ToU64_t_to_u64) t; - i0 <- inst.(ToU64_t_to_u64) t0; + i <- toU64AInst.(ToU64_t_to_u64) t; + i0 <- toU64AInst.(ToU64_t_to_u64) t0; u64_add i i0 . (** Trait implementation: [traits::{(A, A)#3}] Source: 'src/traits.rs', lines 49:0-49:31 *) -Definition traits_ToU64TupleAAInst (A : Type) (inst : ToU64_t A) : ToU64_t (A * - A) := {| - ToU64_t_to_u64 := pair_to_u64 A inst; +Definition traits_ToU64TupleAAInst (A : Type) (toU64AInst : ToU64_t A) : + ToU64_t (A * A) := {| + ToU64_t_to_u64 := pair_to_u64 A toU64AInst; |}. (** [traits::f]: forward function Source: 'src/traits.rs', lines 55:0-55:36 *) -Definition f (T : Type) (inst : ToU64_t T) (x : (T * T)) : result u64 := - pair_to_u64 T inst x +Definition f (T : Type) (toU64TInst : ToU64_t T) (x : (T * T)) : result u64 := + pair_to_u64 T toU64TInst x . (** [traits::g]: forward function Source: 'src/traits.rs', lines 59:0-61:18 *) -Definition g (T : Type) (inst : ToU64_t (T * T)) (x : (T * T)) : result u64 := - inst.(ToU64_t_to_u64) x +Definition g + (T : Type) (toU64TupleTTInst : ToU64_t (T * T)) (x : (T * T)) : result u64 := + toU64TupleTTInst.(ToU64_t_to_u64) x . (** [traits::h0]: forward function @@ -135,15 +136,15 @@ Arguments wrapper_x { _ }. (** [traits::{traits::Wrapper#4}::to_u64]: forward function Source: 'src/traits.rs', lines 75:4-75:26 *) Definition wrapper_to_u64 - (T : Type) (inst : ToU64_t T) (self : Wrapper_t T) : result u64 := - inst.(ToU64_t_to_u64) self.(wrapper_x) + (T : Type) (toU64TInst : ToU64_t T) (self : Wrapper_t T) : result u64 := + toU64TInst.(ToU64_t_to_u64) self.(wrapper_x) . (** Trait implementation: [traits::{traits::Wrapper#4}] Source: 'src/traits.rs', lines 74:0-74:35 *) -Definition traits_ToU64traitsWrapperTInst (T : Type) (inst : ToU64_t T) : +Definition traits_ToU64traitsWrapperTInst (T : Type) (toU64TInst : ToU64_t T) : ToU64_t (Wrapper_t T) := {| - ToU64_t_to_u64 := wrapper_to_u64 T inst; + ToU64_t_to_u64 := wrapper_to_u64 T toU64TInst; |}. (** [traits::h1]: forward function @@ -154,8 +155,9 @@ Definition h1 (x : Wrapper_t u64) : result u64 := (** [traits::h2]: forward function Source: 'src/traits.rs', lines 84:0-84:41 *) -Definition h2 (T : Type) (inst : ToU64_t T) (x : Wrapper_t T) : result u64 := - wrapper_to_u64 T inst x +Definition h2 + (T : Type) (toU64TInst : ToU64_t T) (x : Wrapper_t T) : result u64 := + wrapper_to_u64 T toU64TInst x . (** Trait declaration: [traits::ToType] @@ -181,8 +183,8 @@ Definition traits_ToTypeU64BoolInst : ToType_t u64 bool := {| (** Trait declaration: [traits::OfType] Source: 'src/traits.rs', lines 98:0-98:16 *) Record OfType_t (Self : Type) := mkOfType_t { - OfType_t_of_type : forall (T : Type) (inst : ToType_t T Self), T -> result - Self; + OfType_t_of_type : forall (T : Type) (toTypeTSelfInst : ToType_t T Self), T + -> result Self; }. Arguments mkOfType_t { _ }. @@ -191,10 +193,11 @@ Arguments OfType_t_of_type { _ }. (** [traits::h3]: forward function Source: 'src/traits.rs', lines 104:0-104:50 *) Definition h3 - (T1 T2 : Type) (inst : OfType_t T1) (inst0 : ToType_t T2 T1) (y : T2) : + (T1 T2 : Type) (ofTypeT1Inst : OfType_t T1) (toTypeT2T1Inst : ToType_t T2 T1) + (y : T2) : result T1 := - inst.(OfType_t_of_type) T2 inst0 y + ofTypeT1Inst.(OfType_t_of_type) T2 toTypeT2T1Inst y . (** Trait declaration: [traits::OfTypeBis] @@ -211,10 +214,11 @@ Arguments OfTypeBis_t_of_type { _ _ }. (** [traits::h4]: forward function Source: 'src/traits.rs', lines 118:0-118:57 *) Definition h4 - (T1 T2 : Type) (inst : OfTypeBis_t T1 T2) (inst0 : ToType_t T2 T1) (y : T2) : + (T1 T2 : Type) (ofTypeBisT1T2Inst : OfTypeBis_t T1 T2) (toTypeT2T1Inst : + ToType_t T2 T1) (y : T2) : result T1 := - inst.(OfTypeBis_t_of_type) y + ofTypeBisT1T2Inst.(OfTypeBis_t_of_type) y . (** [traits::TestType] @@ -258,8 +262,10 @@ Definition traits_TestType_test_TestTraittraitstraitsTestTypeTtestTestType1Inst (** [traits::{traits::TestType#6}::test]: forward function Source: 'src/traits.rs', lines 126:4-126:36 *) Definition testType_test - (T : Type) (inst : ToU64_t T) (self : TestType_t T) (x : T) : result bool := - x0 <- inst.(ToU64_t_to_u64) x; + (T : Type) (toU64TInst : ToU64_t T) (self : TestType_t T) (x : T) : + result bool + := + x0 <- toU64TInst.(ToU64_t_to_u64) x; if x0 s> 0%u64 then testType_test_TestType1_test {| testType_test_TestType1_0 := 0%u64 |} else Return false @@ -272,15 +278,17 @@ Record BoolWrapper_t := mkBoolWrapper_t { boolWrapper_0 : bool; }. (** [traits::{traits::BoolWrapper#7}::to_type]: forward function Source: 'src/traits.rs', lines 156:4-156:25 *) Definition boolWrapper_to_type - (T : Type) (inst : ToType_t bool T) (self : BoolWrapper_t) : result T := - inst.(ToType_t_to_type) self.(boolWrapper_0) + (T : Type) (toTypeBoolTInst : ToType_t bool T) (self : BoolWrapper_t) : + result T + := + toTypeBoolTInst.(ToType_t_to_type) self.(boolWrapper_0) . (** Trait implementation: [traits::{traits::BoolWrapper#7}] Source: 'src/traits.rs', lines 152:0-152:33 *) -Definition traits_ToTypetraitsBoolWrapperTInst (T : Type) (inst : ToType_t bool - T) : ToType_t BoolWrapper_t T := {| - ToType_t_to_type := boolWrapper_to_type T inst; +Definition traits_ToTypetraitsBoolWrapperTInst (T : Type) (toTypeBoolTInst : + ToType_t bool T) : ToType_t BoolWrapper_t T := {| + ToType_t_to_type := boolWrapper_to_type T toTypeBoolTInst; |}. (** [traits::WithConstTy::LEN2] @@ -333,15 +341,17 @@ Definition traits_WithConstTyBool32Inst : WithConstTy_t bool 32%usize := {| (** [traits::use_with_const_ty1]: forward function Source: 'src/traits.rs', lines 183:0-183:75 *) Definition use_with_const_ty1 - (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) : result usize := - let i := inst.(WithConstTy_tWithConstTy_t_LEN1) in Return i + (H : Type) (LEN : usize) (withConstTyHLENInst : WithConstTy_t H LEN) : + result usize + := + let i := withConstTyHLENInst.(WithConstTy_tWithConstTy_t_LEN1) in Return i . (** [traits::use_with_const_ty2]: forward function Source: 'src/traits.rs', lines 187:0-187:73 *) Definition use_with_const_ty2 - (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) - (w : inst.(WithConstTy_tWithConstTy_t_W)) : + (H : Type) (LEN : usize) (withConstTyHLENInst : WithConstTy_t H LEN) + (w : withConstTyHLENInst.(WithConstTy_tWithConstTy_t_W)) : result unit := Return tt @@ -350,11 +360,12 @@ Definition use_with_const_ty2 (** [traits::use_with_const_ty3]: forward function Source: 'src/traits.rs', lines 189:0-189:80 *) Definition use_with_const_ty3 - (H : Type) (LEN : usize) (inst : WithConstTy_t H LEN) - (x : inst.(WithConstTy_tWithConstTy_t_W)) : + (H : Type) (LEN : usize) (withConstTyHLENInst : WithConstTy_t H LEN) + (x : withConstTyHLENInst.(WithConstTy_tWithConstTy_t_W)) : result u64 := - inst.(WithConstTy_tWithConstTy_t_W_clause_0).(ToU64_t_to_u64) x + withConstTyHLENInst.(WithConstTy_tWithConstTy_t_W_clause_0).(ToU64_t_to_u64) + x . (** [traits::test_where1]: forward function @@ -365,7 +376,9 @@ Definition test_where1 (T : Type) (_x : T) : result unit := (** [traits::test_where2]: forward function Source: 'src/traits.rs', lines 194:0-194:57 *) Definition test_where2 - (T : Type) (inst : WithConstTy_t T 32%usize) (_x : u32) : result unit := + (T : Type) (withConstTyT32Inst : WithConstTy_t T 32%usize) (_x : u32) : + result unit + := Return tt . @@ -406,25 +419,29 @@ Arguments ChildTrait_tChildTrait_t_ParentTrait1SelfInst { _ }. (** [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 *) Definition test_child_trait1 - (T : Type) (inst : ChildTrait_t T) (x : T) : result alloc_string_String_t := - inst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_name) + (T : Type) (childTraitTInst : ChildTrait_t T) (x : T) : + result alloc_string_String_t + := + childTraitTInst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_name) x . (** [traits::test_child_trait2]: forward function Source: 'src/traits.rs', lines 213:0-213:54 *) Definition test_child_trait2 - (T : Type) (inst : ChildTrait_t T) (x : T) : + (T : Type) (childTraitTInst : ChildTrait_t T) (x : T) : result - inst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_tParentTrait0_t_W) + childTraitTInst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_tParentTrait0_t_W) := - inst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_w) x + childTraitTInst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_w) + x . (** [traits::order1]: forward function Source: 'src/traits.rs', lines 219:0-219:59 *) Definition order1 - (T U : Type) (inst : ParentTrait0_t T) (inst0 : ParentTrait0_t U) : + (T U : Type) (parentTrait0TInst : ParentTrait0_t T) (parentTrait0UInst : + ParentTrait0_t U) : result unit := Return tt diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 63ac307f..4cb9fbf1 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -54,8 +54,9 @@ let test_bool_trait_option (t : Type0) (x : option t) : result bool = (** [traits::test_bool_trait]: forward function Source: 'src/traits.rs', lines 35:0-35:50 *) -let test_bool_trait (t : Type0) (inst : boolTrait_t t) (x : t) : result bool = - inst.get_bool x +let test_bool_trait + (t : Type0) (boolTraitTInst : boolTrait_t t) (x : t) : result bool = + boolTraitTInst.get_bool x (** Trait declaration: [traits::ToU64] Source: 'src/traits.rs', lines 39:0-39:15 *) @@ -72,28 +73,30 @@ let traits_ToU64U64Inst : toU64_t u64 = { to_u64 = u64_to_u64; } (** [traits::{(A, A)#3}::to_u64]: forward function Source: 'src/traits.rs', lines 50:4-50:26 *) -let pair_to_u64 (a : Type0) (inst : toU64_t a) (self : (a & a)) : result u64 = +let pair_to_u64 + (a : Type0) (toU64AInst : toU64_t a) (self : (a & a)) : result u64 = let (x, x0) = self in - let* i = inst.to_u64 x in - let* i0 = inst.to_u64 x0 in + let* i = toU64AInst.to_u64 x in + let* i0 = toU64AInst.to_u64 x0 in u64_add i i0 (** Trait implementation: [traits::{(A, A)#3}] Source: 'src/traits.rs', lines 49:0-49:31 *) -let traits_ToU64TupleAAInst (a : Type0) (inst : toU64_t a) : toU64_t (a & a) - = { - to_u64 = pair_to_u64 a inst; +let traits_ToU64TupleAAInst (a : Type0) (toU64AInst : toU64_t a) : toU64_t (a & + a) = { + to_u64 = pair_to_u64 a toU64AInst; } (** [traits::f]: forward function Source: 'src/traits.rs', lines 55:0-55:36 *) -let f (t : Type0) (inst : toU64_t t) (x : (t & t)) : result u64 = - pair_to_u64 t inst x +let f (t : Type0) (toU64TInst : toU64_t t) (x : (t & t)) : result u64 = + pair_to_u64 t toU64TInst x (** [traits::g]: forward function Source: 'src/traits.rs', lines 59:0-61:18 *) -let g (t : Type0) (inst : toU64_t (t & t)) (x : (t & t)) : result u64 = - inst.to_u64 x +let g + (t : Type0) (toU64TupleTTInst : toU64_t (t & t)) (x : (t & t)) : result u64 = + toU64TupleTTInst.to_u64 x (** [traits::h0]: forward function Source: 'src/traits.rs', lines 66:0-66:24 *) @@ -107,14 +110,14 @@ type wrapper_t (t : Type0) = { x : t; } (** [traits::{traits::Wrapper#4}::to_u64]: forward function Source: 'src/traits.rs', lines 75:4-75:26 *) let wrapper_to_u64 - (t : Type0) (inst : toU64_t t) (self : wrapper_t t) : result u64 = - inst.to_u64 self.x + (t : Type0) (toU64TInst : toU64_t t) (self : wrapper_t t) : result u64 = + toU64TInst.to_u64 self.x (** Trait implementation: [traits::{traits::Wrapper#4}] Source: 'src/traits.rs', lines 74:0-74:35 *) -let traits_ToU64traitsWrapperTInst (t : Type0) (inst : toU64_t t) : toU64_t - (wrapper_t t) = { - to_u64 = wrapper_to_u64 t inst; +let traits_ToU64traitsWrapperTInst (t : Type0) (toU64TInst : toU64_t t) : + toU64_t (wrapper_t t) = { + to_u64 = wrapper_to_u64 t toU64TInst; } (** [traits::h1]: forward function @@ -124,8 +127,8 @@ let h1 (x : wrapper_t u64) : result u64 = (** [traits::h2]: forward function Source: 'src/traits.rs', lines 84:0-84:41 *) -let h2 (t : Type0) (inst : toU64_t t) (x : wrapper_t t) : result u64 = - wrapper_to_u64 t inst x +let h2 (t : Type0) (toU64TInst : toU64_t t) (x : wrapper_t t) : result u64 = + wrapper_to_u64 t toU64TInst x (** Trait declaration: [traits::ToType] Source: 'src/traits.rs', lines 88:0-88:19 *) @@ -143,16 +146,18 @@ let traits_ToTypeU64BoolInst : toType_t u64 bool = { to_type = u64_to_type; } (** Trait declaration: [traits::OfType] Source: 'src/traits.rs', lines 98:0-98:16 *) noeq type ofType_t (self : Type0) = { - of_type : (t : Type0) -> (inst : toType_t t self) -> t -> result self; + of_type : (t : Type0) -> (toTypeTSelfInst : toType_t t self) -> t -> result + self; } (** [traits::h3]: forward function Source: 'src/traits.rs', lines 104:0-104:50 *) let h3 - (t1 t2 : Type0) (inst : ofType_t t1) (inst0 : toType_t t2 t1) (y : t2) : + (t1 t2 : Type0) (ofTypeT1Inst : ofType_t t1) (toTypeT2T1Inst : toType_t t2 + t1) (y : t2) : result t1 = - inst.of_type t2 inst0 y + ofTypeT1Inst.of_type t2 toTypeT2T1Inst y (** Trait declaration: [traits::OfTypeBis] Source: 'src/traits.rs', lines 109:0-109:36 *) @@ -164,11 +169,11 @@ noeq type ofTypeBis_t (self t : Type0) = { (** [traits::h4]: forward function Source: 'src/traits.rs', lines 118:0-118:57 *) let h4 - (t1 t2 : Type0) (inst : ofTypeBis_t t1 t2) (inst0 : toType_t t2 t1) - (y : t2) : + (t1 t2 : Type0) (ofTypeBisT1T2Inst : ofTypeBis_t t1 t2) (toTypeT2T1Inst : + toType_t t2 t1) (y : t2) : result t1 = - inst.of_type y + ofTypeBisT1T2Inst.of_type y (** [traits::TestType] Source: 'src/traits.rs', lines 122:0-122:22 *) @@ -200,8 +205,10 @@ let traits_TestType_test_TestTraittraitstraitsTestTypeTtestTestType1Inst : (** [traits::{traits::TestType#6}::test]: forward function Source: 'src/traits.rs', lines 126:4-126:36 *) let testType_test - (t : Type0) (inst : toU64_t t) (self : testType_t t) (x : t) : result bool = - let* x0 = inst.to_u64 x in + (t : Type0) (toU64TInst : toU64_t t) (self : testType_t t) (x : t) : + result bool + = + let* x0 = toU64TInst.to_u64 x in if x0 > 0 then testType_test_TestType1_test { _0 = 0 } else Return false (** [traits::BoolWrapper] @@ -211,14 +218,16 @@ type boolWrapper_t = { _0 : bool; } (** [traits::{traits::BoolWrapper#7}::to_type]: forward function Source: 'src/traits.rs', lines 156:4-156:25 *) let boolWrapper_to_type - (t : Type0) (inst : toType_t bool t) (self : boolWrapper_t) : result t = - inst.to_type self._0 + (t : Type0) (toTypeBoolTInst : toType_t bool t) (self : boolWrapper_t) : + result t + = + toTypeBoolTInst.to_type self._0 (** Trait implementation: [traits::{traits::BoolWrapper#7}] Source: 'src/traits.rs', lines 152:0-152:33 *) -let traits_ToTypetraitsBoolWrapperTInst (t : Type0) (inst : toType_t bool t) : - toType_t boolWrapper_t t = { - to_type = boolWrapper_to_type t inst; +let traits_ToTypetraitsBoolWrapperTInst (t : Type0) (toTypeBoolTInst : toType_t + bool t) : toType_t boolWrapper_t t = { + to_type = boolWrapper_to_type t toTypeBoolTInst; } (** [traits::WithConstTy::LEN2] @@ -262,13 +271,16 @@ let traits_WithConstTyBool32Inst : withConstTy_t bool 32 = { (** [traits::use_with_const_ty1]: forward function Source: 'src/traits.rs', lines 183:0-183:75 *) let use_with_const_ty1 - (h : Type0) (len : usize) (inst : withConstTy_t h len) : result usize = - let i = inst.cLEN1 in Return i + (h : Type0) (len : usize) (withConstTyHLENInst : withConstTy_t h len) : + result usize + = + let i = withConstTyHLENInst.cLEN1 in Return i (** [traits::use_with_const_ty2]: forward function Source: 'src/traits.rs', lines 187:0-187:73 *) let use_with_const_ty2 - (h : Type0) (len : usize) (inst : withConstTy_t h len) (w : inst.tW) : + (h : Type0) (len : usize) (withConstTyHLENInst : withConstTy_t h len) + (w : withConstTyHLENInst.tW) : result unit = Return () @@ -276,10 +288,11 @@ let use_with_const_ty2 (** [traits::use_with_const_ty3]: forward function Source: 'src/traits.rs', lines 189:0-189:80 *) let use_with_const_ty3 - (h : Type0) (len : usize) (inst : withConstTy_t h len) (x : inst.tW) : + (h : Type0) (len : usize) (withConstTyHLENInst : withConstTy_t h len) + (x : withConstTyHLENInst.tW) : result u64 = - inst.tW_clause_0.to_u64 x + withConstTyHLENInst.tW_clause_0.to_u64 x (** [traits::test_where1]: forward function Source: 'src/traits.rs', lines 193:0-193:40 *) @@ -289,7 +302,9 @@ let test_where1 (t : Type0) (_x : t) : result unit = (** [traits::test_where2]: forward function Source: 'src/traits.rs', lines 194:0-194:57 *) let test_where2 - (t : Type0) (inst : withConstTy_t t 32) (_x : u32) : result unit = + (t : Type0) (withConstTyT32Inst : withConstTy_t t 32) (_x : u32) : + result unit + = Return () (** [alloc::string::String] @@ -318,21 +333,24 @@ noeq type childTrait_t (self : Type0) = { (** [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 *) let test_child_trait1 - (t : Type0) (inst : childTrait_t t) (x : t) : result alloc_string_String_t = - inst.parentTrait0SelfInst.get_name x + (t : Type0) (childTraitTInst : childTrait_t t) (x : t) : + result alloc_string_String_t + = + childTraitTInst.parentTrait0SelfInst.get_name x (** [traits::test_child_trait2]: forward function Source: 'src/traits.rs', lines 213:0-213:54 *) let test_child_trait2 - (t : Type0) (inst : childTrait_t t) (x : t) : - result inst.parentTrait0SelfInst.tW + (t : Type0) (childTraitTInst : childTrait_t t) (x : t) : + result childTraitTInst.parentTrait0SelfInst.tW = - inst.parentTrait0SelfInst.get_w x + childTraitTInst.parentTrait0SelfInst.get_w x (** [traits::order1]: forward function Source: 'src/traits.rs', lines 219:0-219:59 *) let order1 - (t u : Type0) (inst : parentTrait0_t t) (inst0 : parentTrait0_t u) : + (t u : Type0) (parentTrait0TInst : parentTrait0_t t) (parentTrait0UInst : + parentTrait0_t u) : result unit = Return () diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index 0aa68c5e..9ac4736c 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -61,8 +61,9 @@ def test_bool_trait_option (T : Type) (x : Option T) : Result Bool := /- [traits::test_bool_trait]: forward function Source: 'src/traits.rs', lines 35:0-35:50 -/ -def test_bool_trait (T : Type) (inst : BoolTrait T) (x : T) : Result Bool := - inst.get_bool x +def test_bool_trait + (T : Type) (BoolTraitTInst : BoolTrait T) (x : T) : Result Bool := + BoolTraitTInst.get_bool x /- Trait declaration: [traits::ToU64] Source: 'src/traits.rs', lines 39:0-39:15 -/ @@ -82,28 +83,31 @@ def traits.ToU64U64Inst : ToU64 U64 := { /- [traits::{(A, A)#3}::to_u64]: forward function Source: 'src/traits.rs', lines 50:4-50:26 -/ -def Pair.to_u64 (A : Type) (inst : ToU64 A) (self : (A × A)) : Result U64 := +def Pair.to_u64 + (A : Type) (ToU64AInst : ToU64 A) (self : (A × A)) : Result U64 := do let (t, t0) := self - let i ← inst.to_u64 t - let i0 ← inst.to_u64 t0 + let i ← ToU64AInst.to_u64 t + let i0 ← ToU64AInst.to_u64 t0 i + i0 /- Trait implementation: [traits::{(A, A)#3}] Source: 'src/traits.rs', lines 49:0-49:31 -/ -def traits.ToU64TupleAAInst (A : Type) (inst : ToU64 A) : ToU64 (A × A) := { - to_u64 := Pair.to_u64 A inst +def traits.ToU64TupleAAInst (A : Type) (ToU64AInst : ToU64 A) : ToU64 (A × A) + := { + to_u64 := Pair.to_u64 A ToU64AInst } /- [traits::f]: forward function Source: 'src/traits.rs', lines 55:0-55:36 -/ -def f (T : Type) (inst : ToU64 T) (x : (T × T)) : Result U64 := - Pair.to_u64 T inst x +def f (T : Type) (ToU64TInst : ToU64 T) (x : (T × T)) : Result U64 := + Pair.to_u64 T ToU64TInst x /- [traits::g]: forward function Source: 'src/traits.rs', lines 59:0-61:18 -/ -def g (T : Type) (inst : ToU64 (T × T)) (x : (T × T)) : Result U64 := - inst.to_u64 x +def g + (T : Type) (ToU64TupleTTInst : ToU64 (T × T)) (x : (T × T)) : Result U64 := + ToU64TupleTTInst.to_u64 x /- [traits::h0]: forward function Source: 'src/traits.rs', lines 66:0-66:24 -/ @@ -118,14 +122,14 @@ structure Wrapper (T : Type) where /- [traits::{traits::Wrapper#4}::to_u64]: forward function Source: 'src/traits.rs', lines 75:4-75:26 -/ def Wrapper.to_u64 - (T : Type) (inst : ToU64 T) (self : Wrapper T) : Result U64 := - inst.to_u64 self.x + (T : Type) (ToU64TInst : ToU64 T) (self : Wrapper T) : Result U64 := + ToU64TInst.to_u64 self.x /- Trait implementation: [traits::{traits::Wrapper#4}] Source: 'src/traits.rs', lines 74:0-74:35 -/ -def traits.ToU64traitsWrapperTInst (T : Type) (inst : ToU64 T) : ToU64 (Wrapper - T) := { - to_u64 := Wrapper.to_u64 T inst +def traits.ToU64traitsWrapperTInst (T : Type) (ToU64TInst : ToU64 T) : ToU64 + (Wrapper T) := { + to_u64 := Wrapper.to_u64 T ToU64TInst } /- [traits::h1]: forward function @@ -135,8 +139,8 @@ def h1 (x : Wrapper U64) : Result U64 := /- [traits::h2]: forward function Source: 'src/traits.rs', lines 84:0-84:41 -/ -def h2 (T : Type) (inst : ToU64 T) (x : Wrapper T) : Result U64 := - Wrapper.to_u64 T inst x +def h2 (T : Type) (ToU64TInst : ToU64 T) (x : Wrapper T) : Result U64 := + Wrapper.to_u64 T ToU64TInst x /- Trait declaration: [traits::ToType] Source: 'src/traits.rs', lines 88:0-88:19 -/ @@ -157,15 +161,17 @@ def traits.ToTypeU64BoolInst : ToType U64 Bool := { /- Trait declaration: [traits::OfType] Source: 'src/traits.rs', lines 98:0-98:16 -/ structure OfType (Self : Type) where - of_type : forall (T : Type) (inst : ToType T Self), T → Result Self + of_type : forall (T : Type) (ToTypeTSelfInst : ToType T Self), T → Result + Self /- [traits::h3]: forward function Source: 'src/traits.rs', lines 104:0-104:50 -/ def h3 - (T1 T2 : Type) (inst : OfType T1) (inst0 : ToType T2 T1) (y : T2) : + (T1 T2 : Type) (OfTypeT1Inst : OfType T1) (ToTypeT2T1Inst : ToType T2 T1) + (y : T2) : Result T1 := - inst.of_type T2 inst0 y + OfTypeT1Inst.of_type T2 ToTypeT2T1Inst y /- Trait declaration: [traits::OfTypeBis] Source: 'src/traits.rs', lines 109:0-109:36 -/ @@ -176,10 +182,11 @@ structure OfTypeBis (Self T : Type) where /- [traits::h4]: forward function Source: 'src/traits.rs', lines 118:0-118:57 -/ def h4 - (T1 T2 : Type) (inst : OfTypeBis T1 T2) (inst0 : ToType T2 T1) (y : T2) : + (T1 T2 : Type) (OfTypeBisT1T2Inst : OfTypeBis T1 T2) (ToTypeT2T1Inst : ToType + T2 T1) (y : T2) : Result T1 := - inst.of_type y + OfTypeBisT1T2Inst.of_type y /- [traits::TestType] Source: 'src/traits.rs', lines 122:0-122:22 -/ @@ -212,9 +219,11 @@ def traits.TestType.test.TestTraittraitstraitsTestTypeTtestTestType1Inst : /- [traits::{traits::TestType#6}::test]: forward function Source: 'src/traits.rs', lines 126:4-126:36 -/ def TestType.test - (T : Type) (inst : ToU64 T) (self : TestType T) (x : T) : Result Bool := + (T : Type) (ToU64TInst : ToU64 T) (self : TestType T) (x : T) : + Result Bool + := do - let x0 ← inst.to_u64 x + let x0 ← ToU64TInst.to_u64 x if x0 > 0#u64 then TestType.test.TestType1.test { _0 := 0#u64 } else Result.ret false @@ -227,14 +236,16 @@ structure BoolWrapper where /- [traits::{traits::BoolWrapper#7}::to_type]: forward function Source: 'src/traits.rs', lines 156:4-156:25 -/ def BoolWrapper.to_type - (T : Type) (inst : ToType Bool T) (self : BoolWrapper) : Result T := - inst.to_type self._0 + (T : Type) (ToTypeBoolTInst : ToType Bool T) (self : BoolWrapper) : + Result T + := + ToTypeBoolTInst.to_type self._0 /- Trait implementation: [traits::{traits::BoolWrapper#7}] Source: 'src/traits.rs', lines 152:0-152:33 -/ -def traits.ToTypetraitsBoolWrapperTInst (T : Type) (inst : ToType Bool T) : - ToType BoolWrapper T := { - to_type := BoolWrapper.to_type T inst +def traits.ToTypetraitsBoolWrapperTInst (T : Type) (ToTypeBoolTInst : ToType + Bool T) : ToType BoolWrapper T := { + to_type := BoolWrapper.to_type T ToTypeBoolTInst } /- [traits::WithConstTy::LEN2] @@ -278,14 +289,17 @@ def traits.WithConstTyBool32Inst : WithConstTy Bool 32#usize := { /- [traits::use_with_const_ty1]: forward function Source: 'src/traits.rs', lines 183:0-183:75 -/ def use_with_const_ty1 - (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) : Result Usize := - let i := inst.LEN1 + (H : Type) (LEN : Usize) (WithConstTyHLENInst : WithConstTy H LEN) : + Result Usize + := + let i := WithConstTyHLENInst.LEN1 Result.ret i /- [traits::use_with_const_ty2]: forward function Source: 'src/traits.rs', lines 187:0-187:73 -/ def use_with_const_ty2 - (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (w : inst.W) : + (H : Type) (LEN : Usize) (WithConstTyHLENInst : WithConstTy H LEN) + (w : WithConstTyHLENInst.W) : Result Unit := Result.ret () @@ -293,10 +307,11 @@ def use_with_const_ty2 /- [traits::use_with_const_ty3]: forward function Source: 'src/traits.rs', lines 189:0-189:80 -/ def use_with_const_ty3 - (H : Type) (LEN : Usize) (inst : WithConstTy H LEN) (x : inst.W) : + (H : Type) (LEN : Usize) (WithConstTyHLENInst : WithConstTy H LEN) + (x : WithConstTyHLENInst.W) : Result U64 := - inst.W_clause_0.to_u64 x + WithConstTyHLENInst.W_clause_0.to_u64 x /- [traits::test_where1]: forward function Source: 'src/traits.rs', lines 193:0-193:40 -/ @@ -306,7 +321,9 @@ def test_where1 (T : Type) (_x : T) : Result Unit := /- [traits::test_where2]: forward function Source: 'src/traits.rs', lines 194:0-194:57 -/ def test_where2 - (T : Type) (inst : WithConstTy T 32#usize) (_x : U32) : Result Unit := + (T : Type) (WithConstTyT32Inst : WithConstTy T 32#usize) (_x : U32) : + Result Unit + := Result.ret () /- [alloc::string::String] @@ -333,21 +350,24 @@ structure ChildTrait (Self : Type) where /- [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 -/ def test_child_trait1 - (T : Type) (inst : ChildTrait T) (x : T) : Result alloc.string.String := - inst.ParentTrait0SelfInst.get_name x + (T : Type) (ChildTraitTInst : ChildTrait T) (x : T) : + Result alloc.string.String + := + ChildTraitTInst.ParentTrait0SelfInst.get_name x /- [traits::test_child_trait2]: forward function Source: 'src/traits.rs', lines 213:0-213:54 -/ def test_child_trait2 - (T : Type) (inst : ChildTrait T) (x : T) : - Result inst.ParentTrait0SelfInst.W + (T : Type) (ChildTraitTInst : ChildTrait T) (x : T) : + Result ChildTraitTInst.ParentTrait0SelfInst.W := - inst.ParentTrait0SelfInst.get_w x + ChildTraitTInst.ParentTrait0SelfInst.get_w x /- [traits::order1]: forward function Source: 'src/traits.rs', lines 219:0-219:59 -/ def order1 - (T U : Type) (inst : ParentTrait0 T) (inst0 : ParentTrait0 U) : + (T U : Type) (ParentTrait0TInst : ParentTrait0 T) (ParentTrait0UInst : + ParentTrait0 U) : Result Unit := Result.ret () -- cgit v1.2.3 From 724ff98309444537cf03ba7ccab06d432e2eb376 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 11:14:13 +0100 Subject: Use NameMatcher.NameMatcherMap instead of associative lists --- compiler/ExtractBuiltin.ml | 19 ++++++++++++++----- compiler/ExtractName.ml | 21 ++++++++------------- 2 files changed, 22 insertions(+), 18 deletions(-) diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index ef746ddf..6de47920 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -299,10 +299,15 @@ let builtin_funs () : (pattern * bool list option * builtin_fun_info list) list ] let mk_builtin_funs_map () = - NameMatcherMap.of_list - (List.map - (fun (name, filter, info) -> (name, (filter, info))) - (builtin_funs ())) + let m = + NameMatcherMap.of_list + (List.map + (fun (name, filter, info) -> (name, (filter, info))) + (builtin_funs ())) + in + log#ldebug + (lazy ("builtin_funs_map:\n" ^ NameMatcherMap.to_string (fun _ -> "") m)); + m let builtin_funs_map = mk_memoized mk_builtin_funs_map @@ -555,6 +560,10 @@ let builtin_trait_impls_info () : (pattern * (bool list option * string)) list = ] let mk_builtin_trait_impls_map () = - NameMatcherMap.of_list (builtin_trait_impls_info ()) + let m = NameMatcherMap.of_list (builtin_trait_impls_info ()) in + log#ldebug + (lazy + ("builtin_trait_impls_map:\n" ^ NameMatcherMap.to_string (fun _ -> "") m)); + m let builtin_trait_impls_map = mk_memoized mk_builtin_trait_impls_map diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 0943aefe..94222ae1 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -5,29 +5,24 @@ open Charon.NameMatcher let log = Logging.extract_log module NameMatcherMap = struct - type 'a t = (pattern * 'a) list + module NMM = NameMatcherMap + + type 'a t = 'a NMM.t let config = { map_vars_to_vars = true } let find_opt (ctx : ctx) (name : Types.name) (m : 'a t) : 'a option = - match List.find_opt (fun (pat, _) -> match_name ctx config pat name) m with - | None -> None - | Some (_, v) -> Some v + NMM.find_opt ctx config name m let find_with_generics_opt (ctx : ctx) (name : Types.name) (g : Types.generic_args) (m : 'a t) : 'a option = - match - List.find_opt - (fun (pat, _) -> match_name_with_generics ctx config pat name g) - m - with - | None -> None - | Some (_, v) -> Some v + NMM.find_with_generics_opt ctx config name g m let mem (ctx : ctx) (name : Types.name) (m : 'a t) : bool = - find_opt ctx name m <> None + NMM.mem ctx config name m - let of_list (ls : (pattern * 'a) list) : 'a t = ls + let of_list (ls : (pattern * 'a) list) : 'a t = NMM.of_list ls + let to_string = NMM.to_string end (** Helper to convert name patterns to names for extraction. -- cgit v1.2.3 From 4caed6d6e7c4eb85762da373a2e8ab599cb1b440 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 11:21:18 +0100 Subject: Make a minor modification --- compiler/ExtractBuiltin.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 6de47920..30ec7c19 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -306,7 +306,7 @@ let mk_builtin_funs_map () = (builtin_funs ())) in log#ldebug - (lazy ("builtin_funs_map:\n" ^ NameMatcherMap.to_string (fun _ -> "") m)); + (lazy ("builtin_funs_map:\n" ^ NameMatcherMap.to_string (fun _ -> "...") m)); m let builtin_funs_map = mk_memoized mk_builtin_funs_map @@ -563,7 +563,8 @@ let mk_builtin_trait_impls_map () = let m = NameMatcherMap.of_list (builtin_trait_impls_info ()) in log#ldebug (lazy - ("builtin_trait_impls_map:\n" ^ NameMatcherMap.to_string (fun _ -> "") m)); + ("builtin_trait_impls_map:\n" + ^ NameMatcherMap.to_string (fun _ -> "...") m)); m let builtin_trait_impls_map = mk_memoized mk_builtin_trait_impls_map -- cgit v1.2.3 From 5c3a7986a818446cbf008a87f57b2eb51e0bf861 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 11:47:48 +0100 Subject: Cleanup a bit --- compiler/ExtractName.ml | 87 ------------------------------------------------- 1 file changed, 87 deletions(-) diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 94222ae1..41c81207 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -103,90 +103,3 @@ let name_with_generics_to_simple_name (ctx : ctx) (is_trait_impl : bool) name in pattern_to_extract_name is_trait_impl name - -(* - (* Prepare a name. - The first id elem is always the crate: if it is the local crate, - we remove it. We ignore disambiguators (there may be collisions, but we - check if there are). - *) - let rec name_to_simple_name (name : llbc_name) : string list = - (* Rmk.: initially we only filtered the disambiguators equal to 0 *) - match name with - | (PeIdent (crate, _) as id) :: name -> - let name = if crate = crate_name then name else id :: name in - let open Types in - let name = - List.map - (function - | PeIdent (s, _) -> s - | PeImpl impl -> impl_elem_to_simple_name impl) - name - in - name - | _ -> - raise - (Failure - ("Unexpected name shape: " ^ TranslateCore.name_to_string ctx name)) - and impl_elem_to_simple_name (impl : Types.impl_elem) : string = - (* We do something simple for now. - TODO: we might want to do something different for impl elements which are - actually trait implementations, in order to prevent name collisions (it - is possible to define several times the same trait for the same type, - but with different instantiations of the type, or different trait - requirements *) - ty_to_simple_name impl.generics impl.ty - and ty_to_simple_name (generics : Types.generic_params) (ty : Types.ty) : - string = - (* We do something simple for now. - TODO: find a more principled way of converting types to names. - In particular, we might want to do something different for impl elements which are - actually trait implementations, in order to prevent name collisions (it - is possible to define several times the same trait for the same type, - but with different instantiations of the type, or different trait - requirements *) - match ty with - | TAdt (id, args) -> ( - match id with - | TAdtId id -> - let def = TypeDeclId.Map.find id ctx.type_ctx.type_decls in - name_last_elem_as_ident def.name - | TTuple -> - (* TODO *) - "Tuple" - ^ String.concat "" - (List.map (ty_to_simple_name generics) args.types) - | TAssumed id -> ( - match id with - | Types.TBox -> "Box" - | Types.TArray -> "Array" - | Types.TSlice -> "Slice" - | Types.TStr -> "Str")) - | TVar vid -> - (* Use the variable name *) - (List.find (fun (v : type_var) -> v.index = vid) generics.types).name - | TLiteral lty -> - StringUtils.capitalize_first_letter - (Print.Types.literal_type_to_string lty) - | TNever -> raise (Failure "Unreachable") - | TRef (_, rty, rk) -> ( - let rty = ty_to_simple_name generics rty in - match rk with - | RMut -> "MutBorrow" ^ rty - | RShared -> "SharedBorrow" ^ rty) - | TRawPtr (rty, rk) -> ( - let rty = ty_to_simple_name generics rty in - match rk with RMut -> "MutPtr" ^ rty | RShared -> "ConstPtr" ^ rty) - | TTraitType (tr, _, name) -> - (* TODO: this is way too simple *) - let trait_decl = - TraitDeclId.Map.find tr.trait_decl_ref.trait_decl_id - ctx.trait_decls_ctx.trait_decls - in - name_last_elem_as_ident trait_decl.name ^ name - | TArrow (inputs, output) -> - "Arrow" - ^ String.concat "" - (List.map (ty_to_simple_name generics) (inputs @ [ output ])) - in -*) -- cgit v1.2.3 From 138ba20120c288ecef706d4d7babaaafdd0a161b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 11:53:59 +0100 Subject: Update the flake.lock --- flake.lock | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/flake.lock b/flake.lock index e637bc27..c85c619c 100644 --- a/flake.lock +++ b/flake.lock @@ -8,11 +8,11 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1699619324, - "narHash": "sha256-QscTkSBWlmKhODEOavw29MIxOhue9oHdoDXkOmCOgnk=", + "lastModified": 1700650378, + "narHash": "sha256-ZqQFeCsAySM13Qkj2Sz6eMTvw0HtNaq2cth/rfKHYUg=", "owner": "aeneasverif", "repo": "charon", - "rev": "7de1d1e7131f20e56b37ce50adbeb7c947f72f44", + "rev": "aa0d5227d86f8d3a42b443424bf48c98ef8387cd", "type": "github" }, "original": { @@ -131,11 +131,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1699558636, - "narHash": "sha256-N4fyP0An2JBC3PRI0/zSeAapDG4gOYH2D40eHXCOemQ=", + "lastModified": 1700586754, + "narHash": "sha256-SfzRprm7aIqT4RYaOt5k/I0tCJwoCbdjRzr//2omX60=", "owner": "fstarlang", "repo": "fstar", - "rev": "9b60a5b758581edb32488a13e11039db199f89e1", + "rev": "71f2d632e318996f227063bf9d31ee91a4f48dfe", "type": "github" }, "original": { @@ -164,11 +164,11 @@ ] }, "locked": { - "lastModified": 1699550761, - "narHash": "sha256-BNjPd2DuxNCZBeRwcIJH3SZ9/q7+Ny3j8gZDmOvuENs=", + "lastModified": 1700602420, + "narHash": "sha256-RqTzTPk4c3hs9Z4IODcw/73L77Mo2tIPWw2KQzLv/O4=", "owner": "hacl-star", "repo": "hacl-star", - "rev": "e1a785f7e88bb6668c9beabd4dc292a03c68bb2e", + "rev": "a5604d1b255e54cd32a104616c4b01808d46d809", "type": "github" }, "original": { @@ -194,11 +194,11 @@ ] }, "locked": { - "lastModified": 1699578804, - "narHash": "sha256-ss+mguIO6C1DBiKkw/5C5M2N3TiNirBagQ0CUZxlt1I=", + "lastModified": 1700615900, + "narHash": "sha256-dnhIrg55enqH2KteebnDoRRi4CRXX3y8UNorGzf1ofE=", "owner": "hacl-star", "repo": "hacl-nix", - "rev": "19d0224fffa227ca6374d173f5dfeb7c2b61cf4a", + "rev": "7363c6f54bf89ccd5c968f4766c6ea19079b2661", "type": "github" }, "original": { @@ -265,11 +265,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1699614992, - "narHash": "sha256-eSxx1UA47oBzpZGc4tIp6YP2qti1Hrc36Yo77XFnXH0=", + "lastModified": 1700591212, + "narHash": "sha256-87IXaQdBge+18Da7sd+mX39/g8Ibbqq7dGI/S+GByY4=", "owner": "leanprover", "repo": "lean4", - "rev": "5189578a488572b39d102b2e8825bf2a1d2c2b76", + "rev": "fb30932ca7a88cb713e15e4557205dfff8a1a9da", "type": "github" }, "original": { @@ -318,11 +318,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1699614992, - "narHash": "sha256-eSxx1UA47oBzpZGc4tIp6YP2qti1Hrc36Yo77XFnXH0=", + "lastModified": 1700591212, + "narHash": "sha256-87IXaQdBge+18Da7sd+mX39/g8Ibbqq7dGI/S+GByY4=", "owner": "leanprover", "repo": "lean4", - "rev": "5189578a488572b39d102b2e8825bf2a1d2c2b76", + "rev": "fb30932ca7a88cb713e15e4557205dfff8a1a9da", "type": "github" }, "original": { -- cgit v1.2.3 From d163bb804f3418ea8e2c89fe6e8d1c0587fd544b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 14:52:15 +0100 Subject: Fix an issue with the nix flake and update the flake.lock --- compiler/dune | 2 +- flake.lock | 19 ++++++++++--------- flake.nix | 29 +++++++---------------------- 3 files changed, 18 insertions(+), 32 deletions(-) diff --git a/compiler/dune b/compiler/dune index 0d0a8017..3a40e086 100644 --- a/compiler/dune +++ b/compiler/dune @@ -1,6 +1,6 @@ (executable (name main) - (public_name aeneas_main) + (public_name aeneas) (package aeneas) (libraries aeneas) (modules Main)) diff --git a/flake.lock b/flake.lock index c85c619c..d32ac689 100644 --- a/flake.lock +++ b/flake.lock @@ -8,15 +8,16 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1700650378, - "narHash": "sha256-ZqQFeCsAySM13Qkj2Sz6eMTvw0HtNaq2cth/rfKHYUg=", + "lastModified": 1700660953, + "narHash": "sha256-vsMlaH7A5S7+uQGIYtu7Zt81s177X/xWbj2wdu54mtI=", "owner": "aeneasverif", "repo": "charon", - "rev": "aa0d5227d86f8d3a42b443424bf48c98ef8387cd", + "rev": "6760bf9d1dcf3314f2eb15999582d3b486cea6eb", "type": "github" }, "original": { "owner": "aeneasverif", + "ref": "son_fix_nix", "repo": "charon", "type": "github" } @@ -265,11 +266,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1700591212, - "narHash": "sha256-87IXaQdBge+18Da7sd+mX39/g8Ibbqq7dGI/S+GByY4=", + "lastModified": 1700650599, + "narHash": "sha256-AK9AO8COmeBpBFmhM9YLrAz/S7XknokCdXLIDC7tfQc=", "owner": "leanprover", "repo": "lean4", - "rev": "fb30932ca7a88cb713e15e4557205dfff8a1a9da", + "rev": "9efdde23e0858f0925f0d3b4a6df842670b626c9", "type": "github" }, "original": { @@ -318,11 +319,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1700591212, - "narHash": "sha256-87IXaQdBge+18Da7sd+mX39/g8Ibbqq7dGI/S+GByY4=", + "lastModified": 1700650599, + "narHash": "sha256-AK9AO8COmeBpBFmhM9YLrAz/S7XknokCdXLIDC7tfQc=", "owner": "leanprover", "repo": "lean4", - "rev": "fb30932ca7a88cb713e15e4557205dfff8a1a9da", + "rev": "9efdde23e0858f0925f0d3b4a6df842670b626c9", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index e2b7a796..8263174d 100644 --- a/flake.nix +++ b/flake.nix @@ -33,37 +33,22 @@ }; buildInputs = [ ocamlPackages.calendar ]; }; - ocamlgraph = ocamlPackages.buildDunePackage rec { - pname = "ocamlgraph"; - version = "2.0.0"; - src = pkgs.fetchurl { - url = "https://github.com/backtracking/ocamlgraph/releases/download/2.0.0/ocamlgraph-2.0.0.tbz"; - sha256 = "20fe267797de5322088a4dfb52389b2ea051787952a8a4f6ed70fcb697482609"; - }; - buildInputs = [ ocamlPackages.stdlib-shims ocamlPackages.graphics ]; - }; - unionFind = ocamlPackages.buildDunePackage rec { - pname = "unionFind"; - version = "20220122"; - src = pkgs.fetchurl { - url = "https://gitlab.inria.fr/fpottier/unionFind/-/archive/20220122/archive.tar.gz"; - sha512 = "c49dd3f9a6689f6a5efe39c26efe2c137f8812b4be6ee76c2cc20068cf86ad73c0ac97ec9a543245dddb63792ce8c1904576b3435bf419cc7837bc5e368eee6d"; - }; - buildInputs = []; - }; aeneas = ocamlPackages.buildDunePackage { pname = "aeneas"; version = "0.1.0"; duneVersion = "3"; src = ./compiler; - buildInputs = [ easy_logging ocamlgraph unionFind charon.packages.${system}.charon-ml ] - ++ (with ocamlPackages; [ + propagatedBuildInputs = [ + easy_logging charon.packages.${system}.charon-ml + ] ++ (with ocamlPackages; [ calendar core_unix ppx_deriving visitors yojson zarith + ocamlgraph + unionFind ]); afterBuild = '' echo charon.packages.${system}.tests @@ -89,8 +74,8 @@ export CHARON_TESTS_POLONIUS_DIR=${charon.checks.${system}.tests-polonius} # Copy the Aeneas executable, and update the path to it - cp ${aeneas}/bin/aeneas_driver aeneas.exe - export AENEAS_EXE=./aeneas.exe + cp ${aeneas}/bin/aeneas aeneas + export AENEAS_EXE=./aeneas # Copy the tests mkdir tests-copy -- cgit v1.2.3 From 01cfd899119174ef7c5941c99dd251711f4ee701 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 22 Nov 2023 14:57:11 +0100 Subject: Update the flake.lock --- flake.lock | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/flake.lock b/flake.lock index d32ac689..3457101c 100644 --- a/flake.lock +++ b/flake.lock @@ -8,16 +8,15 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1700660953, + "lastModified": 1700661241, "narHash": "sha256-vsMlaH7A5S7+uQGIYtu7Zt81s177X/xWbj2wdu54mtI=", "owner": "aeneasverif", "repo": "charon", - "rev": "6760bf9d1dcf3314f2eb15999582d3b486cea6eb", + "rev": "a3b93d7b6546f1501d5376f7c8bdc0d95d289eb6", "type": "github" }, "original": { "owner": "aeneasverif", - "ref": "son_fix_nix", "repo": "charon", "type": "github" } -- cgit v1.2.3 From 1b446285bbbe356ead7c0e521799b35020f08147 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:04:26 +0100 Subject: Make a minor update in ExtractName.pattern_to_extract_name --- compiler/ExtractName.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 41c81207..c0a23080 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -61,7 +61,10 @@ let pattern_to_extract_name (is_trait_impl : bool) (name : pattern) : | TArray -> "Array" | TSlice -> "Slice" else expr_to_string c ty - | ERef _ | EVar _ -> raise (Failure "")) + | ERef _ | EVar _ -> + (* We simply convert the pattern to a string. This is not very + satisfying but we should rarely get there. *) + expr_to_string c ty) in let rec pattern_to_string (n : pattern) : string list = match n with -- cgit v1.2.3 From 5b9f8de676829817d2b776166fda66bfb5128d6c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:10:05 +0100 Subject: Improve the error messages for some name collisions --- compiler/ExtractBase.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index c6158847..dffe1ea3 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -634,11 +634,13 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | TypeId id -> "type name: " ^ type_id_to_string ctx id | StructId id -> "struct constructor of: " ^ type_id_to_string ctx id | VariantId (id, variant_id) -> + let type_name = type_id_to_string ctx id in let variant_name = adt_variant_to_string ctx id (Some variant_id) in - "variant name: " ^ variant_name + "type name: " ^ type_name ^ ", variant name: " ^ variant_name | FieldId (id, field_id) -> + let type_name = type_id_to_string ctx id in let field_name = adt_field_to_string ctx id field_id in - "field name: " ^ field_name + "type name: " ^ type_name ^ ", field name: " ^ field_name | UnknownId -> "keyword" | TypeVarId id -> "type_var_id: " ^ TypeVarId.to_string id | ConstGenericVarId id -> -- cgit v1.2.3 From feb10e653131716698205f0b77b9623cdd1712b0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:22:33 +0100 Subject: Update some assumed type names/variants --- compiler/Extract.ml | 7 +---- compiler/ExtractBase.ml | 68 +++++++++++++++++++++++++++++-------------------- 2 files changed, 41 insertions(+), 34 deletions(-) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index c8c16c08..a4319482 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -173,12 +173,7 @@ let extract_adt_g_value *) let cons = 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, TAssumed _ -> - ctx_get_type adt_id ctx ^ "." ^ ctx_get_variant adt_id vid ctx - | _ -> ctx_get_variant adt_id vid ctx) + | Some vid -> ctx_get_variant adt_id vid ctx | None -> ctx_get_struct adt_id ctx in let use_parentheses = inside && field_values <> [] in diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index dffe1ea3..b7fa7788 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -960,31 +960,40 @@ let keywords () = List.concat [ named_unops; named_binops; misc ] let assumed_adts () : (assumed_ty * string) list = - match !backend with - | Lean -> - [ - (TState, "State"); - (TResult, "Result"); - (TError, "Error"); - (TFuel, "Nat"); - (TArray, "Array"); - (TSlice, "Slice"); - (TStr, "Str"); - (TRawPtr Mut, "MutRawPtr"); - (TRawPtr Const, "ConstRawPtr"); - ] - | Coq | FStar | HOL4 -> - [ - (TState, "state"); - (TResult, "result"); - (TError, "error"); - (TFuel, if !backend = HOL4 then "num" else "nat"); - (TArray, "array"); - (TSlice, "slice"); - (TStr, "str"); - (TRawPtr Mut, "mut_raw_ptr"); - (TRawPtr Const, "const_raw_ptr"); - ] + let state = + if !use_state then + match !backend with + | Lean -> [ (TState, "State") ] + | Coq | FStar | HOL4 -> [ (TState, "state") ] + else [] + in + (* We voluntarily omit the type [Error]: it is never directly + referenced in the generated translation, and easily collides + with user-defined types *) + let adts = + match !backend with + | Lean -> + [ + (TResult, "Result"); + (TFuel, "Nat"); + (TArray, "Array"); + (TSlice, "Slice"); + (TStr, "Str"); + (TRawPtr Mut, "MutRawPtr"); + (TRawPtr Const, "ConstRawPtr"); + ] + | Coq | FStar | HOL4 -> + [ + (TResult, "result"); + (TFuel, if !backend = HOL4 then "num" else "nat"); + (TArray, "array"); + (TSlice, "slice"); + (TStr, "str"); + (TRawPtr Mut, "mut_raw_ptr"); + (TRawPtr Const, "const_raw_ptr"); + ] + in + state @ adts let assumed_struct_constructors () : (assumed_ty * string) list = match !backend with @@ -1015,9 +1024,12 @@ let assumed_variants () : (assumed_ty * VariantId.id * string) list = ] | Lean -> [ - (TResult, result_return_id, "ret"); - (TResult, result_fail_id, "fail"); - (TError, error_failure_id, "panic"); + (TResult, result_return_id, "Result.ret"); + (TResult, result_fail_id, "Result.fail"); + (* For panic: we omit the prefix "Error." because the type is always + clear from the context. Also, "Error" is often used by user-defined + types (when we omit the crate as a prefix). *) + (TError, error_failure_id, ".panic"); (* No Fuel::Zero on purpose *) (* No Fuel::Succ on purpose *) ] -- cgit v1.2.3 From 4d5d2a8628cfb002267be9a13982aa4ef24a2651 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:29:08 +0100 Subject: Make a minor fix --- compiler/Extract.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/Extract.ml b/compiler/Extract.ml index a4319482..e48e6ae6 100644 --- a/compiler/Extract.ml +++ b/compiler/Extract.ml @@ -2718,7 +2718,7 @@ let extract_unit_test_if_unit_fun (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt "=="; F.pp_print_space fmt (); let success = ctx_get_variant (TAssumed TResult) result_return_id ctx in - F.pp_print_string fmt ("." ^ success ^ " ())") + F.pp_print_string fmt (success ^ " ())") | HOL4 -> F.pp_print_string fmt "val _ = assert_return ("; F.pp_print_string fmt "“"; -- cgit v1.2.3 From 3fb8105afe1d43beb326906f124d7e0e7cefe7bc Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:30:56 +0100 Subject: Update a comment --- compiler/ExtractBase.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index b7fa7788..43e7f158 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1419,9 +1419,10 @@ let default_fun_suffix (num_loops : int) (loop_id : LoopId.id option) - we add "_fwd" - [rg] is [None]: this is a backward function: - this function has one extracted backward function: - - if the forward function has been filtered, we add "_fwd_back": + - if the forward function has been filtered, we add nothing: the forward function is useless, so the unique backward function - takes its place, in a way + takes its place, in a way (in effect, we "merge" the forward + and the backward functions). - otherwise we add "_back" - this function has several backward functions: we add "_back" and an additional suffix to identify the precise backward function -- cgit v1.2.3 From 1c8187d7f4129e09f23d3b5caf33938a0c91ea77 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:38:44 +0100 Subject: Add the alloc::string::String type in the builtins --- compiler/ExtractBase.ml | 5 +++-- compiler/ExtractBuiltin.ml | 15 ++++++++++++--- compiler/ExtractName.ml | 1 + 3 files changed, 16 insertions(+), 5 deletions(-) diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 43e7f158..1ca68120 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1109,8 +1109,9 @@ let initialize_names_maps () : names_maps = let init = names_map_init () in let int_names = List.map int_name T.all_int_types in let keywords = - List.concat - [ [ bool_name (); char_name (); str_name () ]; int_names; init.keywords ] + (* Remark: we don't put "str_name()" below because it clashes with + "alloc::string::String", which we register elsewhere. *) + List.concat [ [ bool_name (); char_name () ]; int_names; init.keywords ] in let names_set = StringSet.empty in let name_to_id = StringMap.empty in diff --git a/compiler/ExtractBuiltin.ml b/compiler/ExtractBuiltin.ml index 30ec7c19..24d16dca 100644 --- a/compiler/ExtractBuiltin.ml +++ b/compiler/ExtractBuiltin.ml @@ -127,9 +127,15 @@ let mk_struct_constructor (type_name : string) : string = 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) ?(keep_params : bool list option = None) + let mk_type (rust_name : string) ?(custom_name : string option = None) + ?(keep_params : bool list option = None) ?(kind : type_variant_kind = KOpaque) () : builtin_type_info = - let extract_name = flatten_name (split_on_separator rust_name) in + let rust_name = parse_pattern rust_name in + let extract_name = + match custom_name with + | None -> flatten_name (pattern_to_type_extract_name rust_name) + | Some name -> flatten_name (split_on_separator name) + in let body_info : builtin_type_body_info option = match kind with | KOpaque -> None @@ -147,13 +153,16 @@ let builtin_types () : builtin_type_info list = Some (Struct (constructor, fields)) | KEnum -> raise (Failure "TODO") in - let rust_name = parse_pattern rust_name in { rust_name; extract_name; keep_params; body_info } in [ (* Alloc *) mk_type "alloc::alloc::Global" (); + (* String *) + mk_type "alloc::string::String" + ~custom_name:(Some (backend_choice "string" "String")) + (); (* Vec *) mk_type "alloc::vec::Vec" ~keep_params:(Some [ true; false ]) (); (* Range *) diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index c0a23080..a916bffb 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -76,6 +76,7 @@ let pattern_to_extract_name (is_trait_impl : bool) (name : pattern) : in pattern_to_string name +let pattern_to_type_extract_name = pattern_to_extract_name false let pattern_to_fun_extract_name = pattern_to_extract_name false let pattern_to_trait_impl_extract_name = pattern_to_extract_name true -- cgit v1.2.3 From d84040e000333d6d2a212fb849a38fb73a65eb48 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 Nov 2023 17:41:42 +0100 Subject: Regenerate the files --- tests/coq/traits/Traits.v | 10 +-- tests/fstar/traits/Traits.fst | 10 +-- tests/lean/Array.lean | 26 +++--- tests/lean/BetreeMain/Funs.lean | 42 ++++----- tests/lean/External/Funs.lean | 8 +- tests/lean/Hashmap/Funs.lean | 40 ++++----- tests/lean/HashmapMain/Funs.lean | 38 ++++---- tests/lean/Loops.lean | 184 +++++++++++++++++++-------------------- tests/lean/NoNestedBorrows.lean | 133 ++++++++++++++-------------- tests/lean/Paper.lean | 32 +++---- tests/lean/PoloniusList.lean | 8 +- tests/lean/Traits.lean | 10 +-- 12 files changed, 259 insertions(+), 282 deletions(-) diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index 0952a1df..50eaf848 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -382,15 +382,11 @@ Definition test_where2 Return tt . -(** [alloc::string::String] - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/alloc/src/string.rs', lines 365:0-365:17 *) -Axiom alloc_string_String_t : Type. - (** Trait declaration: [traits::ParentTrait0] Source: 'src/traits.rs', lines 200:0-200:22 *) Record ParentTrait0_t (Self : Type) := mkParentTrait0_t { ParentTrait0_tParentTrait0_t_W : Type; - ParentTrait0_t_get_name : Self -> result alloc_string_String_t; + ParentTrait0_t_get_name : Self -> result string; ParentTrait0_t_get_w : Self -> result ParentTrait0_tParentTrait0_t_W; }. @@ -419,9 +415,7 @@ Arguments ChildTrait_tChildTrait_t_ParentTrait1SelfInst { _ }. (** [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 *) Definition test_child_trait1 - (T : Type) (childTraitTInst : ChildTrait_t T) (x : T) : - result alloc_string_String_t - := + (T : Type) (childTraitTInst : ChildTrait_t T) (x : T) : result string := childTraitTInst.(ChildTrait_tChildTrait_t_ParentTrait0SelfInst).(ParentTrait0_t_get_name) x . diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 4cb9fbf1..895a1cac 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -307,15 +307,11 @@ let test_where2 = Return () -(** [alloc::string::String] - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/alloc/src/string.rs', lines 365:0-365:17 *) -assume type alloc_string_String_t : Type0 - (** Trait declaration: [traits::ParentTrait0] Source: 'src/traits.rs', lines 200:0-200:22 *) noeq type parentTrait0_t (self : Type0) = { tW : Type0; - get_name : self -> result alloc_string_String_t; + get_name : self -> result string; get_w : self -> result tW; } @@ -333,9 +329,7 @@ noeq type childTrait_t (self : Type0) = { (** [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 *) let test_child_trait1 - (t : Type0) (childTraitTInst : childTrait_t t) (x : t) : - result alloc_string_String_t - = + (t : Type0) (childTraitTInst : childTrait_t t) (x : t) : result string = childTraitTInst.parentTrait0SelfInst.get_name x (** [traits::test_child_trait2]: forward function diff --git a/tests/lean/Array.lean b/tests/lean/Array.lean index 4832f469..b49add96 100644 --- a/tests/lean/Array.lean +++ b/tests/lean/Array.lean @@ -31,10 +31,10 @@ def array_to_mut_slice_ (T : Type) (s : Array T 32#usize) : Result (Slice T) := /- [array::array_to_mut_slice_]: backward function 0 Source: 'src/array.rs', lines 21:0-21:58 -/ def array_to_mut_slice__back - (T : Type) (s : Array T 32#usize) (ret0 : Slice T) : + (T : Type) (s : Array T 32#usize) (ret : Slice T) : Result (Array T 32#usize) := - Array.from_slice T 32#usize s ret0 + Array.from_slice T 32#usize s ret /- [array::array_len]: forward function Source: 'src/array.rs', lines 25:0-25:40 -/ @@ -82,10 +82,10 @@ def index_mut_array (T : Type) (s : Array T 32#usize) (i : Usize) : Result T := /- [array::index_mut_array]: backward function 0 Source: 'src/array.rs', lines 52:0-52:62 -/ def index_mut_array_back - (T : Type) (s : Array T 32#usize) (i : Usize) (ret0 : T) : + (T : Type) (s : Array T 32#usize) (i : Usize) (ret : T) : Result (Array T 32#usize) := - Array.update_usize T 32#usize s i ret0 + Array.update_usize T 32#usize s i ret /- [array::index_slice]: forward function Source: 'src/array.rs', lines 56:0-56:46 -/ @@ -100,8 +100,8 @@ def index_mut_slice (T : Type) (s : Slice T) (i : Usize) : Result T := /- [array::index_mut_slice]: backward function 0 Source: 'src/array.rs', lines 60:0-60:58 -/ def index_mut_slice_back - (T : Type) (s : Slice T) (i : Usize) (ret0 : T) : Result (Slice T) := - Slice.update_usize T s i ret0 + (T : Type) (s : Slice T) (i : Usize) (ret : T) : Result (Slice T) := + Slice.update_usize T s i ret /- [array::slice_subslice_shared_]: forward function Source: 'src/array.rs', lines 64:0-64:70 -/ @@ -122,12 +122,12 @@ def slice_subslice_mut_ /- [array::slice_subslice_mut_]: backward function 0 Source: 'src/array.rs', lines 68:0-68:75 -/ def slice_subslice_mut__back - (x : Slice U32) (y : Usize) (z : Usize) (ret0 : Slice U32) : + (x : Slice U32) (y : Usize) (z : Usize) (ret : Slice U32) : Result (Slice U32) := core.slice.index.Slice.index_mut_back U32 (core.ops.range.Range Usize) (core.slice.index.SliceIndexRangeUsizeSliceTInst U32) x - { start := y, end_ := z } ret0 + { start := y, end_ := z } ret /- [array::array_to_slice_shared_]: forward function Source: 'src/array.rs', lines 72:0-72:54 -/ @@ -142,8 +142,8 @@ def array_to_slice_mut_ (x : Array U32 32#usize) : Result (Slice U32) := /- [array::array_to_slice_mut_]: backward function 0 Source: 'src/array.rs', lines 76:0-76:59 -/ def array_to_slice_mut__back - (x : Array U32 32#usize) (ret0 : Slice U32) : Result (Array U32 32#usize) := - Array.from_slice U32 32#usize x ret0 + (x : Array U32 32#usize) (ret : Slice U32) : Result (Array U32 32#usize) := + Array.from_slice U32 32#usize x ret /- [array::array_subslice_shared_]: forward function Source: 'src/array.rs', lines 80:0-80:74 -/ @@ -166,13 +166,13 @@ def array_subslice_mut_ /- [array::array_subslice_mut_]: backward function 0 Source: 'src/array.rs', lines 84:0-84:79 -/ def array_subslice_mut__back - (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret0 : Slice U32) : + (x : Array U32 32#usize) (y : Usize) (z : Usize) (ret : Slice U32) : Result (Array U32 32#usize) := core.array.Array.index_mut_back U32 (core.ops.range.Range Usize) 32#usize (core.ops.index.IndexMutSliceTIInst U32 (core.ops.range.Range Usize) (core.slice.index.SliceIndexRangeUsizeSliceTInst U32)) x - { start := y, end_ := z } ret0 + { start := y, end_ := z } ret /- [array::index_slice_0]: forward function Source: 'src/array.rs', lines 88:0-88:38 -/ @@ -417,7 +417,7 @@ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := let i := Slice.len U32 s let i0 := Slice.len U32 s2 if not (i = i0) - then Result.fail Error.panic + then Result.fail .panic else sum2_loop s s2 0#u32 0#usize /- [array::f0]: forward function diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 45548884..4c862225 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -121,7 +121,7 @@ divergent def betree.List.split_at let (ls0, ls1) := p let l := ls0 Result.ret (betree.List.Cons hd l, ls1) - | betree.List.Nil => Result.fail Error.panic + | betree.List.Nil => Result.fail .panic /- [betree_main::betree::{betree_main::betree::List#1}::push_front]: merged forward/backward function (there is a single backward function, and the forward function returns ()) @@ -138,7 +138,7 @@ def betree.List.pop_front (T : Type) (self : betree.List T) : Result T := let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret x - | betree.List.Nil => Result.fail Error.panic + | betree.List.Nil => Result.fail .panic /- [betree_main::betree::{betree_main::betree::List#1}::pop_front]: backward function 0 Source: 'src/betree.rs', lines 306:4-306:32 -/ @@ -147,14 +147,14 @@ def betree.List.pop_front_back let ls := core.mem.replace (betree.List T) self betree.List.Nil match ls with | betree.List.Cons x tl => Result.ret tl - | betree.List.Nil => Result.fail Error.panic + | betree.List.Nil => Result.fail .panic /- [betree_main::betree::{betree_main::betree::List#1}::hd]: forward function Source: 'src/betree.rs', lines 318:4-318:22 -/ def betree.List.hd (T : Type) (self : betree.List T) : Result T := match self with | betree.List.Cons hd l => Result.ret hd - | betree.List.Nil => Result.fail Error.panic + | betree.List.Nil => Result.fail .panic /- [betree_main::betree::{betree_main::betree::List<(u64, T)>#2}::head_has_key]: forward function Source: 'src/betree.rs', lines 327:4-327:44 -/ @@ -241,20 +241,20 @@ divergent def betree.Node.lookup_first_message_for_key Source: 'src/betree.rs', lines 789:4-792:34 -/ divergent def betree.Node.lookup_first_message_for_key_back (key : U64) (msgs : betree.List (U64 × betree.Message)) - (ret0 : betree.List (U64 × betree.Message)) : + (ret : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) := match msgs with | betree.List.Cons x next_msgs => let (i, m) := x if i >= key - then Result.ret ret0 + then Result.ret ret else do let next_msgs0 ← - betree.Node.lookup_first_message_for_key_back key next_msgs ret0 + betree.Node.lookup_first_message_for_key_back key next_msgs ret Result.ret (betree.List.Cons (i, m) next_msgs0) - | betree.List.Nil => Result.ret ret0 + | betree.List.Nil => Result.ret ret /- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function Source: 'src/betree.rs', lines 819:4-819:90 -/ @@ -271,8 +271,8 @@ divergent def betree.Node.apply_upserts let msg ← betree.List.pop_front (U64 × betree.Message) msgs let (_, m) := msg match m with - | betree.Message.Insert i => Result.fail Error.panic - | betree.Message.Delete => Result.fail Error.panic + | betree.Message.Insert i => Result.fail .panic + | betree.Message.Delete => Result.fail .panic | betree.Message.Upsert s => do let v ← betree.upsert_update prev s @@ -302,8 +302,8 @@ divergent def betree.Node.apply_upserts_back let msg ← betree.List.pop_front (U64 × betree.Message) msgs let (_, m) := msg match m with - | betree.Message.Insert i => Result.fail Error.panic - | betree.Message.Delete => Result.fail Error.panic + | betree.Message.Insert i => Result.fail .panic + | betree.Message.Delete => Result.fail .panic | betree.Message.Upsert s => do let v ← betree.upsert_update prev s @@ -542,7 +542,7 @@ divergent def betree.Node.lookup_first_message_after_key Source: 'src/betree.rs', lines 689:4-692:34 -/ divergent def betree.Node.lookup_first_message_after_key_back (key : U64) (msgs : betree.List (U64 × betree.Message)) - (ret0 : betree.List (U64 × betree.Message)) : + (ret : betree.List (U64 × betree.Message)) : Result (betree.List (U64 × betree.Message)) := match msgs with @@ -552,10 +552,10 @@ divergent def betree.Node.lookup_first_message_after_key_back then do let next_msgs0 ← - betree.Node.lookup_first_message_after_key_back key next_msgs ret0 + betree.Node.lookup_first_message_after_key_back key next_msgs ret Result.ret (betree.List.Cons (k, m) next_msgs0) - else Result.ret ret0 - | betree.List.Nil => Result.ret ret0 + else Result.ret ret + | betree.List.Nil => Result.ret ret /- [betree_main::betree::{betree_main::betree::Node#5}::apply_to_internal]: merged forward/backward function (there is a single backward function, and the forward function returns ()) @@ -658,19 +658,19 @@ divergent def betree.Node.lookup_mut_in_bindings Source: 'src/betree.rs', lines 653:4-656:32 -/ divergent def betree.Node.lookup_mut_in_bindings_back (key : U64) (bindings : betree.List (U64 × U64)) - (ret0 : betree.List (U64 × U64)) : + (ret : betree.List (U64 × U64)) : Result (betree.List (U64 × U64)) := match bindings with | betree.List.Cons hd tl => let (i, i0) := hd if i >= key - then Result.ret ret0 + then Result.ret ret else do - let tl0 ← betree.Node.lookup_mut_in_bindings_back key tl ret0 + let tl0 ← betree.Node.lookup_mut_in_bindings_back key tl ret Result.ret (betree.List.Cons (i, i0) tl0) - | betree.List.Nil => Result.ret ret0 + | betree.List.Nil => Result.ret ret /- [betree_main::betree::{betree_main::betree::Node#5}::apply_to_leaf]: merged forward/backward function (there is a single backward function, and the forward function returns ()) @@ -1069,6 +1069,6 @@ def main : Result Unit := Result.ret () /- Unit test for [betree_main::main] -/ -#assert (main == .ret ()) +#assert (main == Result.ret ()) end betree_main diff --git a/tests/lean/External/Funs.lean b/tests/lean/External/Funs.lean index e5655c7e..48ec6ad5 100644 --- a/tests/lean/External/Funs.lean +++ b/tests/lean/External/Funs.lean @@ -45,7 +45,7 @@ def test_vec : Result Unit := Result.ret () /- Unit test for [external::test_vec] -/ -#assert (test_vec == .ret ()) +#assert (test_vec == Result.ret ()) /- [external::custom_swap]: forward function Source: 'src/external.rs', lines 24:0-24:66 -/ @@ -60,14 +60,14 @@ def custom_swap /- [external::custom_swap]: backward function 0 Source: 'src/external.rs', lines 24:0-24:66 -/ def custom_swap_back - (T : Type) (x : T) (y : T) (st : State) (ret0 : T) (st0 : State) : + (T : Type) (x : T) (y : T) (st : State) (ret : T) (st0 : State) : Result (State × (T × T)) := do let (st1, _) ← core.mem.swap T x y st let (st2, _) ← core.mem.swap_back0 T x y st st1 let (_, y0) ← core.mem.swap_back1 T x y st st2 - Result.ret (st0, (ret0, y0)) + Result.ret (st0, (ret, y0)) /- [external::test_custom_swap]: forward function Source: 'src/external.rs', lines 29:0-29:59 -/ @@ -92,7 +92,7 @@ def test_swap_non_zero (x : U32) (st : State) : Result (State × U32) := let (st0, _) ← swap U32 x 0#u32 st let (st1, (x0, _)) ← swap_back U32 x 0#u32 st st0 if x0 = 0#u32 - then Result.fail Error.panic + then Result.fail .panic else Result.ret (st1, x0) end external diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index 95c501f6..e03981a2 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -295,7 +295,7 @@ divergent def HashMap.get_in_list_loop if ckey = key then Result.ret cvalue else HashMap.get_in_list_loop T key tl - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [hashmap::{hashmap::HashMap}::get_in_list]: forward function Source: 'src/hashmap.rs', lines 224:4-224:70 -/ @@ -324,7 +324,7 @@ divergent def HashMap.get_mut_in_list_loop if ckey = key then Result.ret cvalue else HashMap.get_mut_in_list_loop T tl key - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [hashmap::{hashmap::HashMap}::get_mut_in_list]: forward function Source: 'src/hashmap.rs', lines 245:4-245:86 -/ @@ -335,22 +335,22 @@ def HashMap.get_mut_in_list /- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 Source: 'src/hashmap.rs', lines 245:4-254:5 -/ divergent def HashMap.get_mut_in_list_loop_back - (T : Type) (ls : List T) (key : Usize) (ret0 : T) : Result (List T) := + (T : Type) (ls : List T) (key : Usize) (ret : T) : Result (List T) := match ls with | List.Cons ckey cvalue tl => if ckey = key - then Result.ret (List.Cons ckey ret0 tl) + then Result.ret (List.Cons ckey ret tl) else do - let tl0 ← HashMap.get_mut_in_list_loop_back T tl key ret0 + let tl0 ← HashMap.get_mut_in_list_loop_back T tl key ret Result.ret (List.Cons ckey cvalue tl0) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [hashmap::{hashmap::HashMap}::get_mut_in_list]: backward function 0 Source: 'src/hashmap.rs', lines 245:4-245:86 -/ def HashMap.get_mut_in_list_back - (T : Type) (ls : List T) (key : Usize) (ret0 : T) : Result (List T) := - HashMap.get_mut_in_list_loop_back T ls key ret0 + (T : Type) (ls : List T) (key : Usize) (ret : T) : Result (List T) := + HashMap.get_mut_in_list_loop_back T ls key ret /- [hashmap::{hashmap::HashMap}::get_mut]: forward function Source: 'src/hashmap.rs', lines 257:4-257:67 -/ @@ -368,9 +368,7 @@ def HashMap.get_mut (T : Type) (self : HashMap T) (key : Usize) : Result T := /- [hashmap::{hashmap::HashMap}::get_mut]: backward function 0 Source: 'src/hashmap.rs', lines 257:4-257:67 -/ def HashMap.get_mut_back - (T : Type) (self : HashMap T) (key : Usize) (ret0 : T) : - Result (HashMap T) - := + (T : Type) (self : HashMap T) (key : Usize) (ret : T) : Result (HashMap T) := do let hash ← hash_key key let i := alloc.vec.Vec.len (List T) self.slots @@ -379,7 +377,7 @@ def HashMap.get_mut_back alloc.vec.Vec.index_mut (List T) Usize (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots hash_mod - let l0 ← HashMap.get_mut_in_list_back T l key ret0 + let l0 ← HashMap.get_mut_in_list_back T l key ret let v ← alloc.vec.Vec.index_mut_back (List T) Usize (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots @@ -397,7 +395,7 @@ divergent def HashMap.remove_from_list_loop let mv_ls := core.mem.replace (List T) (List.Cons ckey t tl) List.Nil match mv_ls with | List.Cons i cvalue tl0 => Result.ret (some cvalue) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic else HashMap.remove_from_list_loop T key tl | List.Nil => Result.ret none @@ -418,7 +416,7 @@ divergent def HashMap.remove_from_list_loop_back let mv_ls := core.mem.replace (List T) (List.Cons ckey t tl) List.Nil match mv_ls with | List.Cons i cvalue tl0 => Result.ret tl0 - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic else do let tl0 ← HashMap.remove_from_list_loop_back T key tl @@ -493,37 +491,37 @@ def test1 : Result Unit := let hm3 ← HashMap.insert U64 hm2 1056#usize 256#u64 let i ← HashMap.get U64 hm3 128#usize if not (i = 18#u64) - then Result.fail Error.panic + then Result.fail .panic else do let hm4 ← HashMap.get_mut_back U64 hm3 1024#usize 56#u64 let i0 ← HashMap.get U64 hm4 1024#usize if not (i0 = 56#u64) - then Result.fail Error.panic + then Result.fail .panic else do let x ← HashMap.remove U64 hm4 1024#usize match x with - | none => Result.fail Error.panic + | none => Result.fail .panic | some x0 => if not (x0 = 56#u64) - then Result.fail Error.panic + then Result.fail .panic else do let hm5 ← HashMap.remove_back U64 hm4 1024#usize let i1 ← HashMap.get U64 hm5 0#usize if not (i1 = 42#u64) - then Result.fail Error.panic + then Result.fail .panic else do let i2 ← HashMap.get U64 hm5 128#usize if not (i2 = 18#u64) - then Result.fail Error.panic + then Result.fail .panic else do let i3 ← HashMap.get U64 hm5 1056#usize if not (i3 = 256#u64) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () end hashmap diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index abe84bbf..f87ad355 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -309,7 +309,7 @@ divergent def hashmap.HashMap.get_in_list_loop if ckey = key then Result.ret cvalue else hashmap.HashMap.get_in_list_loop T key tl - | hashmap.List.Nil => Result.fail Error.panic + | hashmap.List.Nil => Result.fail .panic /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: forward function Source: 'src/hashmap.rs', lines 224:4-224:70 -/ @@ -340,7 +340,7 @@ divergent def hashmap.HashMap.get_mut_in_list_loop if ckey = key then Result.ret cvalue else hashmap.HashMap.get_mut_in_list_loop T tl key - | hashmap.List.Nil => Result.fail Error.panic + | hashmap.List.Nil => Result.fail .panic /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: forward function Source: 'src/hashmap.rs', lines 245:4-245:86 -/ @@ -351,26 +351,26 @@ def hashmap.HashMap.get_mut_in_list /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: backward function 0 Source: 'src/hashmap.rs', lines 245:4-254:5 -/ divergent def hashmap.HashMap.get_mut_in_list_loop_back - (T : Type) (ls : hashmap.List T) (key : Usize) (ret0 : T) : + (T : Type) (ls : hashmap.List T) (key : Usize) (ret : T) : Result (hashmap.List T) := match ls with | hashmap.List.Cons ckey cvalue tl => if ckey = key - then Result.ret (hashmap.List.Cons ckey ret0 tl) + then Result.ret (hashmap.List.Cons ckey ret tl) else do - let tl0 ← hashmap.HashMap.get_mut_in_list_loop_back T tl key ret0 + let tl0 ← hashmap.HashMap.get_mut_in_list_loop_back T tl key ret Result.ret (hashmap.List.Cons ckey cvalue tl0) - | hashmap.List.Nil => Result.fail Error.panic + | hashmap.List.Nil => Result.fail .panic /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: backward function 0 Source: 'src/hashmap.rs', lines 245:4-245:86 -/ def hashmap.HashMap.get_mut_in_list_back - (T : Type) (ls : hashmap.List T) (key : Usize) (ret0 : T) : + (T : Type) (ls : hashmap.List T) (key : Usize) (ret : T) : Result (hashmap.List T) := - hashmap.HashMap.get_mut_in_list_loop_back T ls key ret0 + hashmap.HashMap.get_mut_in_list_loop_back T ls key ret /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: forward function Source: 'src/hashmap.rs', lines 257:4-257:67 -/ @@ -389,7 +389,7 @@ def hashmap.HashMap.get_mut /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: backward function 0 Source: 'src/hashmap.rs', lines 257:4-257:67 -/ def hashmap.HashMap.get_mut_back - (T : Type) (self : hashmap.HashMap T) (key : Usize) (ret0 : T) : + (T : Type) (self : hashmap.HashMap T) (key : Usize) (ret : T) : Result (hashmap.HashMap T) := do @@ -400,7 +400,7 @@ def hashmap.HashMap.get_mut_back alloc.vec.Vec.index_mut (hashmap.List T) Usize (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) self.slots hash_mod - let l0 ← hashmap.HashMap.get_mut_in_list_back T l key ret0 + let l0 ← hashmap.HashMap.get_mut_in_list_back T l key ret let v ← alloc.vec.Vec.index_mut_back (hashmap.List T) Usize (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) @@ -420,7 +420,7 @@ divergent def hashmap.HashMap.remove_from_list_loop hashmap.List.Nil match mv_ls with | hashmap.List.Cons i cvalue tl0 => Result.ret (some cvalue) - | hashmap.List.Nil => Result.fail Error.panic + | hashmap.List.Nil => Result.fail .panic else hashmap.HashMap.remove_from_list_loop T key tl | hashmap.List.Nil => Result.ret none @@ -443,7 +443,7 @@ divergent def hashmap.HashMap.remove_from_list_loop_back hashmap.List.Nil match mv_ls with | hashmap.List.Cons i cvalue tl0 => Result.ret tl0 - | hashmap.List.Nil => Result.fail Error.panic + | hashmap.List.Nil => Result.fail .panic else do let tl0 ← hashmap.HashMap.remove_from_list_loop_back T key tl @@ -520,37 +520,37 @@ def hashmap.test1 : Result Unit := let hm3 ← hashmap.HashMap.insert U64 hm2 1056#usize 256#u64 let i ← hashmap.HashMap.get U64 hm3 128#usize if not (i = 18#u64) - then Result.fail Error.panic + then Result.fail .panic else do let hm4 ← hashmap.HashMap.get_mut_back U64 hm3 1024#usize 56#u64 let i0 ← hashmap.HashMap.get U64 hm4 1024#usize if not (i0 = 56#u64) - then Result.fail Error.panic + then Result.fail .panic else do let x ← hashmap.HashMap.remove U64 hm4 1024#usize match x with - | none => Result.fail Error.panic + | none => Result.fail .panic | some x0 => if not (x0 = 56#u64) - then Result.fail Error.panic + then Result.fail .panic else do let hm5 ← hashmap.HashMap.remove_back U64 hm4 1024#usize let i1 ← hashmap.HashMap.get U64 hm5 0#usize if not (i1 = 42#u64) - then Result.fail Error.panic + then Result.fail .panic else do let i2 ← hashmap.HashMap.get U64 hm5 128#usize if not (i2 = 18#u64) - then Result.fail Error.panic + then Result.fail .panic else do let i3 ← hashmap.HashMap.get U64 hm5 1056#usize if not (i3 = 256#u64) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- [hashmap_main::insert_on_disk]: forward function diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index ae1d87aa..08aa08a5 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -107,7 +107,7 @@ divergent def list_nth_mut_loop_loop else do let i0 ← i - 1#u32 list_nth_mut_loop_loop T tl i0 - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop]: forward function Source: 'src/loops.rs', lines 78:0-78:71 -/ @@ -117,23 +117,23 @@ def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result T := /- [loops::list_nth_mut_loop]: loop 0: backward function 0 Source: 'src/loops.rs', lines 78:0-88:1 -/ divergent def list_nth_mut_loop_loop_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + (T : Type) (ls : List T) (i : U32) (ret : T) : Result (List T) := match ls with | List.Cons x tl => if i = 0#u32 - then Result.ret (List.Cons ret0 tl) + then Result.ret (List.Cons ret tl) else do let i0 ← i - 1#u32 - let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret0 + let tl0 ← list_nth_mut_loop_loop_back T tl i0 ret Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop]: backward function 0 Source: 'src/loops.rs', lines 78:0-78:71 -/ def list_nth_mut_loop_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := - list_nth_mut_loop_loop_back T ls i ret0 + (T : Type) (ls : List T) (i : U32) (ret : T) : Result (List T) := + list_nth_mut_loop_loop_back T ls i ret /- [loops::list_nth_shared_loop]: loop 0: forward function Source: 'src/loops.rs', lines 91:0-101:1 -/ @@ -146,7 +146,7 @@ divergent def list_nth_shared_loop_loop else do let i0 ← i - 1#u32 list_nth_shared_loop_loop T tl i0 - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop]: forward function Source: 'src/loops.rs', lines 91:0-91:66 -/ @@ -160,7 +160,7 @@ divergent def get_elem_mut_loop (x : Usize) (ls : List Usize) : Result Usize := | List.Cons y tl => if y = x then Result.ret y else get_elem_mut_loop x tl - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::get_elem_mut]: forward function Source: 'src/loops.rs', lines 103:0-103:73 -/ @@ -175,28 +175,28 @@ def get_elem_mut /- [loops::get_elem_mut]: loop 0: backward function 0 Source: 'src/loops.rs', lines 103:0-117:1 -/ divergent def get_elem_mut_loop_back - (x : Usize) (ls : List Usize) (ret0 : Usize) : Result (List Usize) := + (x : Usize) (ls : List Usize) (ret : Usize) : Result (List Usize) := match ls with | List.Cons y tl => if y = x - then Result.ret (List.Cons ret0 tl) + then Result.ret (List.Cons ret tl) else do - let tl0 ← get_elem_mut_loop_back x tl ret0 + let tl0 ← get_elem_mut_loop_back x tl ret Result.ret (List.Cons y tl0) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::get_elem_mut]: backward function 0 Source: 'src/loops.rs', lines 103:0-103:73 -/ def get_elem_mut_back - (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret0 : Usize) : + (slots : alloc.vec.Vec (List Usize)) (x : Usize) (ret : Usize) : Result (alloc.vec.Vec (List Usize)) := do let l ← alloc.vec.Vec.index_mut (List Usize) Usize (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize - let l0 ← get_elem_mut_loop_back x l ret0 + let l0 ← get_elem_mut_loop_back x l ret alloc.vec.Vec.index_mut_back (List Usize) Usize (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize l0 @@ -209,7 +209,7 @@ divergent def get_elem_shared_loop | List.Cons y tl => if y = x then Result.ret y else get_elem_shared_loop x tl - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::get_elem_shared]: forward function Source: 'src/loops.rs', lines 119:0-119:68 -/ @@ -228,8 +228,8 @@ def id_mut (T : Type) (ls : List T) : Result (List T) := /- [loops::id_mut]: backward function 0 Source: 'src/loops.rs', lines 135:0-135:50 -/ -def id_mut_back (T : Type) (ls : List T) (ret0 : List T) : Result (List T) := - Result.ret ret0 +def id_mut_back (T : Type) (ls : List T) (ret : List T) : Result (List T) := + Result.ret ret /- [loops::id_shared]: forward function Source: 'src/loops.rs', lines 139:0-139:45 -/ @@ -247,7 +247,7 @@ divergent def list_nth_mut_loop_with_id_loop else do let i0 ← i - 1#u32 list_nth_mut_loop_with_id_loop T i0 tl - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_with_id]: forward function Source: 'src/loops.rs', lines 144:0-144:75 -/ @@ -259,25 +259,25 @@ def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := /- [loops::list_nth_mut_loop_with_id]: loop 0: backward function 0 Source: 'src/loops.rs', lines 144:0-155:1 -/ divergent def list_nth_mut_loop_with_id_loop_back - (T : Type) (i : U32) (ls : List T) (ret0 : T) : Result (List T) := + (T : Type) (i : U32) (ls : List T) (ret : T) : Result (List T) := match ls with | List.Cons x tl => if i = 0#u32 - then Result.ret (List.Cons ret0 tl) + then Result.ret (List.Cons ret tl) else do let i0 ← i - 1#u32 - let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret0 + let tl0 ← list_nth_mut_loop_with_id_loop_back T i0 tl ret Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_with_id]: backward function 0 Source: 'src/loops.rs', lines 144:0-144:75 -/ def list_nth_mut_loop_with_id_back - (T : Type) (ls : List T) (i : U32) (ret0 : T) : Result (List T) := + (T : Type) (ls : List T) (i : U32) (ret : T) : Result (List T) := do let ls0 ← id_mut T ls - let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret0 + let l ← list_nth_mut_loop_with_id_loop_back T i ls0 ret id_mut_back T ls l /- [loops::list_nth_shared_loop_with_id]: loop 0: forward function @@ -291,7 +291,7 @@ divergent def list_nth_shared_loop_with_id_loop else do let i0 ← i - 1#u32 list_nth_shared_loop_with_id_loop T i0 tl - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop_with_id]: forward function Source: 'src/loops.rs', lines 158:0-158:70 -/ @@ -314,8 +314,8 @@ divergent def list_nth_mut_loop_pair_loop else do let i0 ← i - 1#u32 list_nth_mut_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair]: forward function Source: 'src/loops.rs', lines 174:0-178:27 -/ @@ -326,7 +326,7 @@ def list_nth_mut_loop_pair /- [loops::list_nth_mut_loop_pair]: loop 0: backward function 0 Source: 'src/loops.rs', lines 174:0-195:1 -/ divergent def list_nth_mut_loop_pair_loop_back'a - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := match ls0 with @@ -334,27 +334,27 @@ divergent def list_nth_mut_loop_pair_loop_back'a match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then Result.ret (List.Cons ret0 tl0) + then Result.ret (List.Cons ret tl0) else do let i0 ← i - 1#u32 - let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret0 + let tl00 ← list_nth_mut_loop_pair_loop_back'a T tl0 tl1 i0 ret Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair]: backward function 0 Source: 'src/loops.rs', lines 174:0-178:27 -/ def list_nth_mut_loop_pair_back'a - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := - list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret0 + list_nth_mut_loop_pair_loop_back'a T ls0 ls1 i ret /- [loops::list_nth_mut_loop_pair]: loop 0: backward function 1 Source: 'src/loops.rs', lines 174:0-195:1 -/ divergent def list_nth_mut_loop_pair_loop_back'b - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := match ls0 with @@ -362,22 +362,22 @@ divergent def list_nth_mut_loop_pair_loop_back'b match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then Result.ret (List.Cons ret0 tl1) + then Result.ret (List.Cons ret tl1) else do let i0 ← i - 1#u32 - let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret0 + let tl10 ← list_nth_mut_loop_pair_loop_back'b T tl0 tl1 i0 ret Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair]: backward function 1 Source: 'src/loops.rs', lines 174:0-178:27 -/ def list_nth_mut_loop_pair_back'b - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := - list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret0 + list_nth_mut_loop_pair_loop_back'b T ls0 ls1 i ret /- [loops::list_nth_shared_loop_pair]: loop 0: forward function Source: 'src/loops.rs', lines 198:0-219:1 -/ @@ -392,8 +392,8 @@ divergent def list_nth_shared_loop_pair_loop else do let i0 ← i - 1#u32 list_nth_shared_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop_pair]: forward function Source: 'src/loops.rs', lines 198:0-202:19 -/ @@ -415,8 +415,8 @@ divergent def list_nth_mut_loop_pair_merge_loop do let i0 ← i - 1#u32 list_nth_mut_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair_merge]: forward function Source: 'src/loops.rs', lines 223:0-227:27 -/ @@ -427,7 +427,7 @@ def list_nth_mut_loop_pair_merge /- [loops::list_nth_mut_loop_pair_merge]: loop 0: backward function 0 Source: 'src/loops.rs', lines 223:0-238:1 -/ divergent def list_nth_mut_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : (T × T)) : Result ((List T) × (List T)) := match ls0 with @@ -435,24 +435,24 @@ divergent def list_nth_mut_loop_pair_merge_loop_back match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then let (t, t0) := ret0 + then let (t, t0) := ret Result.ret (List.Cons t tl0, List.Cons t0 tl1) else do let i0 ← i - 1#u32 let (tl00, tl10) ← - list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + list_nth_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret Result.ret (List.Cons x0 tl00, List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair_merge]: backward function 0 Source: 'src/loops.rs', lines 223:0-227:27 -/ def list_nth_mut_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : (T × T)) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : (T × T)) : Result ((List T) × (List T)) := - list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 + list_nth_mut_loop_pair_merge_loop_back T ls0 ls1 i ret /- [loops::list_nth_shared_loop_pair_merge]: loop 0: forward function Source: 'src/loops.rs', lines 241:0-256:1 -/ @@ -468,8 +468,8 @@ divergent def list_nth_shared_loop_pair_merge_loop do let i0 ← i - 1#u32 list_nth_shared_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop_pair_merge]: forward function Source: 'src/loops.rs', lines 241:0-245:19 -/ @@ -491,8 +491,8 @@ divergent def list_nth_mut_shared_loop_pair_loop do let i0 ← i - 1#u32 list_nth_mut_shared_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_shared_loop_pair]: forward function Source: 'src/loops.rs', lines 259:0-263:23 -/ @@ -503,7 +503,7 @@ def list_nth_mut_shared_loop_pair /- [loops::list_nth_mut_shared_loop_pair]: loop 0: backward function 0 Source: 'src/loops.rs', lines 259:0-274:1 -/ divergent def list_nth_mut_shared_loop_pair_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := match ls0 with @@ -511,23 +511,22 @@ divergent def list_nth_mut_shared_loop_pair_loop_back match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then Result.ret (List.Cons ret0 tl0) + then Result.ret (List.Cons ret tl0) else do let i0 ← i - 1#u32 - let tl00 ← - list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret0 + let tl00 ← list_nth_mut_shared_loop_pair_loop_back T tl0 tl1 i0 ret Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_shared_loop_pair]: backward function 0 Source: 'src/loops.rs', lines 259:0-263:23 -/ def list_nth_mut_shared_loop_pair_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := - list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret0 + list_nth_mut_shared_loop_pair_loop_back T ls0 ls1 i ret /- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: forward function Source: 'src/loops.rs', lines 278:0-293:1 -/ @@ -543,8 +542,8 @@ divergent def list_nth_mut_shared_loop_pair_merge_loop do let i0 ← i - 1#u32 list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_shared_loop_pair_merge]: forward function Source: 'src/loops.rs', lines 278:0-282:23 -/ @@ -555,7 +554,7 @@ def list_nth_mut_shared_loop_pair_merge /- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: backward function 0 Source: 'src/loops.rs', lines 278:0-293:1 -/ divergent def list_nth_mut_shared_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := match ls0 with @@ -563,23 +562,23 @@ divergent def list_nth_mut_shared_loop_pair_merge_loop_back match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then Result.ret (List.Cons ret0 tl0) + then Result.ret (List.Cons ret tl0) else do let i0 ← i - 1#u32 let tl00 ← - list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + list_nth_mut_shared_loop_pair_merge_loop_back T tl0 tl1 i0 ret Result.ret (List.Cons x0 tl00) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_shared_loop_pair_merge]: backward function 0 Source: 'src/loops.rs', lines 278:0-282:23 -/ def list_nth_mut_shared_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := - list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret0 + list_nth_mut_shared_loop_pair_merge_loop_back T ls0 ls1 i ret /- [loops::list_nth_shared_mut_loop_pair]: loop 0: forward function Source: 'src/loops.rs', lines 297:0-312:1 -/ @@ -595,8 +594,8 @@ divergent def list_nth_shared_mut_loop_pair_loop do let i0 ← i - 1#u32 list_nth_shared_mut_loop_pair_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_mut_loop_pair]: forward function Source: 'src/loops.rs', lines 297:0-301:23 -/ @@ -607,7 +606,7 @@ def list_nth_shared_mut_loop_pair /- [loops::list_nth_shared_mut_loop_pair]: loop 0: backward function 1 Source: 'src/loops.rs', lines 297:0-312:1 -/ divergent def list_nth_shared_mut_loop_pair_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := match ls0 with @@ -615,23 +614,22 @@ divergent def list_nth_shared_mut_loop_pair_loop_back match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then Result.ret (List.Cons ret0 tl1) + then Result.ret (List.Cons ret tl1) else do let i0 ← i - 1#u32 - let tl10 ← - list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret0 + let tl10 ← list_nth_shared_mut_loop_pair_loop_back T tl0 tl1 i0 ret Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_mut_loop_pair]: backward function 1 Source: 'src/loops.rs', lines 297:0-301:23 -/ def list_nth_shared_mut_loop_pair_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := - list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret0 + list_nth_shared_mut_loop_pair_loop_back T ls0 ls1 i ret /- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: forward function Source: 'src/loops.rs', lines 316:0-331:1 -/ @@ -647,8 +645,8 @@ divergent def list_nth_shared_mut_loop_pair_merge_loop do let i0 ← i - 1#u32 list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i0 - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_mut_loop_pair_merge]: forward function Source: 'src/loops.rs', lines 316:0-320:23 -/ @@ -659,7 +657,7 @@ def list_nth_shared_mut_loop_pair_merge /- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: backward function 0 Source: 'src/loops.rs', lines 316:0-331:1 -/ divergent def list_nth_shared_mut_loop_pair_merge_loop_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := match ls0 with @@ -667,22 +665,22 @@ divergent def list_nth_shared_mut_loop_pair_merge_loop_back match ls1 with | List.Cons x1 tl1 => if i = 0#u32 - then Result.ret (List.Cons ret0 tl1) + then Result.ret (List.Cons ret tl1) else do let i0 ← i - 1#u32 let tl10 ← - list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret0 + list_nth_shared_mut_loop_pair_merge_loop_back T tl0 tl1 i0 ret Result.ret (List.Cons x1 tl10) - | List.Nil => Result.fail Error.panic - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_mut_loop_pair_merge]: backward function 0 Source: 'src/loops.rs', lines 316:0-320:23 -/ def list_nth_shared_mut_loop_pair_merge_back - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret0 : T) : + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) (ret : T) : Result (List T) := - list_nth_shared_mut_loop_pair_merge_loop_back T ls0 ls1 i ret0 + list_nth_shared_mut_loop_pair_merge_loop_back T ls0 ls1 i ret end loops diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index 3b1c3f9f..ca66c628 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -101,7 +101,7 @@ def test2 : Result Unit := Result.ret () /- Unit test for [no_nested_borrows::test2] -/ -#assert (test2 == .ret ()) +#assert (test2 == Result.ret ()) /- [no_nested_borrows::get_max]: forward function Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 -/ @@ -118,11 +118,11 @@ def test3 : Result Unit := let y ← get_max 10#u32 11#u32 let z ← x + y if not (z = 15#u32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test3] -/ -#assert (test3 == .ret ()) +#assert (test3 == Result.ret ()) /- [no_nested_borrows::test_neg1]: forward function Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 -/ @@ -130,40 +130,39 @@ def test_neg1 : Result Unit := do let y ← - 3#i32 if not (y = (-(3:Int))#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_neg1] -/ -#assert (test_neg1 == .ret ()) +#assert (test_neg1 == Result.ret ()) /- [no_nested_borrows::refs_test1]: forward function Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 -/ def refs_test1 : Result Unit := if not (1#i32 = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::refs_test1] -/ -#assert (refs_test1 == .ret ()) +#assert (refs_test1 == Result.ret ()) /- [no_nested_borrows::refs_test2]: forward function Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 -/ def refs_test2 : Result Unit := if not (2#i32 = 2#i32) - then Result.fail Error.panic + then Result.fail .panic else if not (0#i32 = 0#i32) - then Result.fail Error.panic + then Result.fail .panic else if not (2#i32 = 2#i32) - then Result.fail Error.panic - else - if not (2#i32 = 2#i32) - then Result.fail Error.panic - else Result.ret () + then Result.fail .panic + else if not (2#i32 = 2#i32) + then Result.fail .panic + else Result.ret () /- Unit test for [no_nested_borrows::refs_test2] -/ -#assert (refs_test2 == .ret ()) +#assert (refs_test2 == Result.ret ()) /- [no_nested_borrows::test_list1]: forward function Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 -/ @@ -171,7 +170,7 @@ def test_list1 : Result Unit := Result.ret () /- Unit test for [no_nested_borrows::test_list1] -/ -#assert (test_list1 == .ret ()) +#assert (test_list1 == Result.ret ()) /- [no_nested_borrows::test_box1]: forward function Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 -/ @@ -181,11 +180,11 @@ def test_box1 : Result Unit := let b0 ← alloc.boxed.Box.deref_mut_back I32 b 1#i32 let x ← alloc.boxed.Box.deref I32 b0 if not (x = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_box1] -/ -#assert (test_box1 == .ret ()) +#assert (test_box1 == Result.ret ()) /- [no_nested_borrows::copy_int]: forward function Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 -/ @@ -196,14 +195,14 @@ def copy_int (x : I32) : Result I32 := Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 -/ def test_unreachable (b : Bool) : Result Unit := if b - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- [no_nested_borrows::test_panic]: forward function Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 -/ def test_panic (b : Bool) : Result Unit := if b - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- [no_nested_borrows::test_copy_int]: forward function @@ -212,11 +211,11 @@ def test_copy_int : Result Unit := do let y ← copy_int 0#i32 if not (0#i32 = y) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_copy_int] -/ -#assert (test_copy_int == .ret ()) +#assert (test_copy_int == Result.ret ()) /- [no_nested_borrows::is_cons]: forward function Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 -/ @@ -232,18 +231,18 @@ def test_is_cons : Result Unit := let l := List.Nil let b ← is_cons I32 (List.Cons 0#i32 l) if not b - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_is_cons] -/ -#assert (test_is_cons == .ret ()) +#assert (test_is_cons == Result.ret ()) /- [no_nested_borrows::split_list]: forward function Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 -/ def split_list (T : Type) (l : List T) : Result (T × (List T)) := match l with | List.Cons hd tl => Result.ret (hd, tl) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [no_nested_borrows::test_split_list]: forward function Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 -/ @@ -253,11 +252,11 @@ def test_split_list : Result Unit := let p ← split_list I32 (List.Cons 0#i32 l) let (hd, _) := p if not (hd = 0#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_split_list] -/ -#assert (test_split_list == .ret ()) +#assert (test_split_list == Result.ret ()) /- [no_nested_borrows::choose]: forward function Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 -/ @@ -269,10 +268,10 @@ def choose (T : Type) (b : Bool) (x : T) (y : T) : Result T := /- [no_nested_borrows::choose]: backward function 0 Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 -/ def choose_back - (T : Type) (b : Bool) (x : T) (y : T) (ret0 : T) : Result (T × T) := + (T : Type) (b : Bool) (x : T) (y : T) (ret : T) : Result (T × T) := if b - then Result.ret (ret0, y) - else Result.ret (x, ret0) + then Result.ret (ret, y) + else Result.ret (x, ret) /- [no_nested_borrows::choose_test]: forward function Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 -/ @@ -281,18 +280,18 @@ def choose_test : Result Unit := let z ← choose I32 true 0#i32 0#i32 let z0 ← z + 1#i32 if not (z0 = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else do let (x, y) ← choose_back I32 true 0#i32 0#i32 z0 if not (x = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else if not (y = 0#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::choose_test] -/ -#assert (choose_test == .ret ()) +#assert (choose_test == Result.ret ()) /- [no_nested_borrows::test_char]: forward function Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 -/ @@ -334,7 +333,7 @@ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := else do let i0 ← i - 1#u32 list_nth_shared T tl i0 - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [no_nested_borrows::list_nth_mut]: forward function Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 -/ @@ -346,22 +345,22 @@ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := else do let i0 ← i - 1#u32 list_nth_mut T tl i0 - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [no_nested_borrows::list_nth_mut]: backward function 0 Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 -/ divergent def list_nth_mut_back - (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := + (T : Type) (l : List T) (i : U32) (ret : T) : Result (List T) := match l with | List.Cons x tl => if i = 0#u32 - then Result.ret (List.Cons ret0 tl) + then Result.ret (List.Cons ret tl) else do let i0 ← i - 1#u32 - let tl0 ← list_nth_mut_back T tl i0 ret0 + let tl0 ← list_nth_mut_back T tl i0 ret Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [no_nested_borrows::list_rev_aux]: forward function Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 -/ @@ -387,43 +386,43 @@ def test_list_functions : Result Unit := let l1 := List.Cons 1#i32 l0 let i ← list_length I32 (List.Cons 0#i32 l1) if not (i = 3#u32) - then Result.fail Error.panic + then Result.fail .panic else do let i0 ← list_nth_shared I32 (List.Cons 0#i32 l1) 0#u32 if not (i0 = 0#i32) - then Result.fail Error.panic + then Result.fail .panic else do let i1 ← list_nth_shared I32 (List.Cons 0#i32 l1) 1#u32 if not (i1 = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else do let i2 ← list_nth_shared I32 (List.Cons 0#i32 l1) 2#u32 if not (i2 = 2#i32) - then Result.fail Error.panic + then Result.fail .panic else do let ls ← list_nth_mut_back I32 (List.Cons 0#i32 l1) 1#u32 3#i32 let i3 ← list_nth_shared I32 ls 0#u32 if not (i3 = 0#i32) - then Result.fail Error.panic + then Result.fail .panic else do let i4 ← list_nth_shared I32 ls 1#u32 if not (i4 = 3#i32) - then Result.fail Error.panic + then Result.fail .panic else do let i5 ← list_nth_shared I32 ls 2#u32 if not (i5 = 2#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_list_functions] -/ -#assert (test_list_functions == .ret ()) +#assert (test_list_functions == Result.ret ()) /- [no_nested_borrows::id_mut_pair1]: forward function Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 -/ @@ -433,8 +432,8 @@ def id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : Result (T1 × T2) := /- [no_nested_borrows::id_mut_pair1]: backward function 0 Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 -/ def id_mut_pair1_back - (T1 T2 : Type) (x : T1) (y : T2) (ret0 : (T1 × T2)) : Result (T1 × T2) := - let (t, t0) := ret0 + (T1 T2 : Type) (x : T1) (y : T2) (ret : (T1 × T2)) : Result (T1 × T2) := + let (t, t0) := ret Result.ret (t, t0) /- [no_nested_borrows::id_mut_pair2]: forward function @@ -446,8 +445,8 @@ def id_mut_pair2 (T1 T2 : Type) (p : (T1 × T2)) : Result (T1 × T2) := /- [no_nested_borrows::id_mut_pair2]: backward function 0 Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 -/ def id_mut_pair2_back - (T1 T2 : Type) (p : (T1 × T2)) (ret0 : (T1 × T2)) : Result (T1 × T2) := - let (t, t0) := ret0 + (T1 T2 : Type) (p : (T1 × T2)) (ret : (T1 × T2)) : Result (T1 × T2) := + let (t, t0) := ret Result.ret (t, t0) /- [no_nested_borrows::id_mut_pair3]: forward function @@ -458,14 +457,14 @@ def id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : Result (T1 × T2) := /- [no_nested_borrows::id_mut_pair3]: backward function 0 Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ def id_mut_pair3_back'a - (T1 T2 : Type) (x : T1) (y : T2) (ret0 : T1) : Result T1 := - Result.ret ret0 + (T1 T2 : Type) (x : T1) (y : T2) (ret : T1) : Result T1 := + Result.ret ret /- [no_nested_borrows::id_mut_pair3]: backward function 1 Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ def id_mut_pair3_back'b - (T1 T2 : Type) (x : T1) (y : T2) (ret0 : T2) : Result T2 := - Result.ret ret0 + (T1 T2 : Type) (x : T1) (y : T2) (ret : T2) : Result T2 := + Result.ret ret /- [no_nested_borrows::id_mut_pair4]: forward function Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ @@ -476,14 +475,14 @@ def id_mut_pair4 (T1 T2 : Type) (p : (T1 × T2)) : Result (T1 × T2) := /- [no_nested_borrows::id_mut_pair4]: backward function 0 Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ def id_mut_pair4_back'a - (T1 T2 : Type) (p : (T1 × T2)) (ret0 : T1) : Result T1 := - Result.ret ret0 + (T1 T2 : Type) (p : (T1 × T2)) (ret : T1) : Result T1 := + Result.ret ret /- [no_nested_borrows::id_mut_pair4]: backward function 1 Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ def id_mut_pair4_back'b - (T1 T2 : Type) (p : (T1 × T2)) (ret0 : T2) : Result T2 := - Result.ret ret0 + (T1 T2 : Type) (p : (T1 × T2)) (ret : T2) : Result T2 := + Result.ret ret /- [no_nested_borrows::StructWithTuple] Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 -/ @@ -522,28 +521,28 @@ def test_constants : Result Unit := let swt ← new_tuple1 let (i, _) := swt.p if not (i = 1#u32) - then Result.fail Error.panic + then Result.fail .panic else do let swt0 ← new_tuple2 let (i0, _) := swt0.p if not (i0 = 1#i16) - then Result.fail Error.panic + then Result.fail .panic else do let swt1 ← new_tuple3 let (i1, _) := swt1.p if not (i1 = 1#u64) - then Result.fail Error.panic + then Result.fail .panic else do let swp ← new_pair1 if not (swp.p.x = 1#u32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [no_nested_borrows::test_constants] -/ -#assert (test_constants == .ret ()) +#assert (test_constants == Result.ret ()) /- [no_nested_borrows::test_weird_borrows1]: forward function Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 -/ @@ -551,7 +550,7 @@ def test_weird_borrows1 : Result Unit := Result.ret () /- Unit test for [no_nested_borrows::test_weird_borrows1] -/ -#assert (test_weird_borrows1 == .ret ()) +#assert (test_weird_borrows1 == Result.ret ()) /- [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) @@ -559,7 +558,7 @@ def test_weird_borrows1 : Result Unit := def test_mem_replace (px : U32) : Result U32 := let y := core.mem.replace U32 px 1#u32 if not (y = 0#u32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret 2#u32 /- [no_nested_borrows::test_shared_borrow_bool1]: forward function diff --git a/tests/lean/Paper.lean b/tests/lean/Paper.lean index 37e0e70e..08386bb7 100644 --- a/tests/lean/Paper.lean +++ b/tests/lean/Paper.lean @@ -17,11 +17,11 @@ def test_incr : Result Unit := do let x ← ref_incr 0#i32 if not (x = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [paper::test_incr] -/ -#assert (test_incr == .ret ()) +#assert (test_incr == Result.ret ()) /- [paper::choose]: forward function Source: 'src/paper.rs', lines 15:0-15:70 -/ @@ -33,10 +33,10 @@ def choose (T : Type) (b : Bool) (x : T) (y : T) : Result T := /- [paper::choose]: backward function 0 Source: 'src/paper.rs', lines 15:0-15:70 -/ def choose_back - (T : Type) (b : Bool) (x : T) (y : T) (ret0 : T) : Result (T × T) := + (T : Type) (b : Bool) (x : T) (y : T) (ret : T) : Result (T × T) := if b - then Result.ret (ret0, y) - else Result.ret (x, ret0) + then Result.ret (ret, y) + else Result.ret (x, ret) /- [paper::test_choose]: forward function Source: 'src/paper.rs', lines 23:0-23:20 -/ @@ -45,18 +45,18 @@ def test_choose : Result Unit := let z ← choose I32 true 0#i32 0#i32 let z0 ← z + 1#i32 if not (z0 = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else do let (x, y) ← choose_back I32 true 0#i32 0#i32 z0 if not (x = 1#i32) - then Result.fail Error.panic + then Result.fail .panic else if not (y = 0#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [paper::test_choose] -/ -#assert (test_choose == .ret ()) +#assert (test_choose == Result.ret ()) /- [paper::List] Source: 'src/paper.rs', lines 35:0-35:16 -/ @@ -74,22 +74,22 @@ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := else do let i0 ← i - 1#u32 list_nth_mut T tl i0 - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [paper::list_nth_mut]: backward function 0 Source: 'src/paper.rs', lines 42:0-42:67 -/ divergent def list_nth_mut_back - (T : Type) (l : List T) (i : U32) (ret0 : T) : Result (List T) := + (T : Type) (l : List T) (i : U32) (ret : T) : Result (List T) := match l with | List.Cons x tl => if i = 0#u32 - then Result.ret (List.Cons ret0 tl) + then Result.ret (List.Cons ret tl) else do let i0 ← i - 1#u32 - let tl0 ← list_nth_mut_back T tl i0 ret0 + let tl0 ← list_nth_mut_back T tl i0 ret Result.ret (List.Cons x tl0) - | List.Nil => Result.fail Error.panic + | List.Nil => Result.fail .panic /- [paper::sum]: forward function Source: 'src/paper.rs', lines 57:0-57:32 -/ @@ -112,11 +112,11 @@ def test_nth : Result Unit := let l2 ← list_nth_mut_back I32 (List.Cons 1#i32 l1) 2#u32 x0 let i ← sum l2 if not (i = 7#i32) - then Result.fail Error.panic + then Result.fail .panic else Result.ret () /- Unit test for [paper::test_nth] -/ -#assert (test_nth == .ret ()) +#assert (test_nth == Result.ret ()) /- [paper::call_choose]: forward function Source: 'src/paper.rs', lines 76:0-76:44 -/ diff --git a/tests/lean/PoloniusList.lean b/tests/lean/PoloniusList.lean index 0ef71791..37f0dffb 100644 --- a/tests/lean/PoloniusList.lean +++ b/tests/lean/PoloniusList.lean @@ -24,15 +24,15 @@ divergent def get_list_at_x (ls : List U32) (x : U32) : Result (List U32) := /- [polonius_list::get_list_at_x]: backward function 0 Source: 'src/polonius_list.rs', lines 13:0-13:76 -/ divergent def get_list_at_x_back - (ls : List U32) (x : U32) (ret0 : List U32) : Result (List U32) := + (ls : List U32) (x : U32) (ret : List U32) : Result (List U32) := match ls with | List.Cons hd tl => if hd = x - then Result.ret ret0 + then Result.ret ret else do - let tl0 ← get_list_at_x_back tl x ret0 + let tl0 ← get_list_at_x_back tl x ret Result.ret (List.Cons hd tl0) - | List.Nil => Result.ret ret0 + | List.Nil => Result.ret ret end polonius_list diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index 9ac4736c..e7795d9c 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -326,15 +326,11 @@ def test_where2 := Result.ret () -/- [alloc::string::String] - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/alloc/src/string.rs', lines 365:0-365:17 -/ -axiom alloc.string.String : Type - /- Trait declaration: [traits::ParentTrait0] Source: 'src/traits.rs', lines 200:0-200:22 -/ structure ParentTrait0 (Self : Type) where W : Type - get_name : Self → Result alloc.string.String + get_name : Self → Result String get_w : Self → Result W /- Trait declaration: [traits::ParentTrait1] @@ -350,9 +346,7 @@ structure ChildTrait (Self : Type) where /- [traits::test_child_trait1]: forward function Source: 'src/traits.rs', lines 209:0-209:56 -/ def test_child_trait1 - (T : Type) (ChildTraitTInst : ChildTrait T) (x : T) : - Result alloc.string.String - := + (T : Type) (ChildTraitTInst : ChildTrait T) (x : T) : Result String := ChildTraitTInst.ParentTrait0SelfInst.get_name x /- [traits::test_child_trait2]: forward function -- cgit v1.2.3 From 959d6fce38c8d8ca6eaed3ad6f458b87f91a9abc Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 09:37:31 +0100 Subject: Update the generation of files for external definitions and regenerate the tests --- compiler/Translate.ml | 23 ++++++----- tests/coq/betree/BetreeMain_Funs.v | 4 +- tests/coq/betree/BetreeMain_FunsExternal.v | 46 ++++++++++++++++++++++ .../coq/betree/BetreeMain_FunsExternal_Template.v | 46 ++++++++++++++++++++++ tests/coq/betree/BetreeMain_Opaque.v | 45 --------------------- tests/coq/betree/_CoqProject | 3 +- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 4 +- .../coq/hashmap_on_disk/HashmapMain_FunsExternal.v | 25 ++++++++++++ .../HashmapMain_FunsExternal_Template.v | 26 ++++++++++++ tests/coq/hashmap_on_disk/HashmapMain_Opaque.v | 25 ------------ tests/coq/hashmap_on_disk/_CoqProject | 3 +- tests/coq/misc/External_Funs.v | 4 +- tests/coq/misc/External_FunsExternal.v | 43 ++++++++++++++++++++ tests/coq/misc/External_FunsExternal_Template.v | 44 +++++++++++++++++++++ tests/coq/misc/External_Opaque.v | 43 -------------------- tests/coq/misc/_CoqProject | 3 +- tests/fstar/betree/BetreeMain.Funs.fst | 2 +- tests/fstar/betree/BetreeMain.FunsExternal.fsti | 35 ++++++++++++++++ tests/fstar/betree/BetreeMain.Opaque.fsti | 35 ---------------- .../fstar/betree_back_stateful/BetreeMain.Funs.fst | 2 +- .../BetreeMain.FunsExternal.fsti | 35 ++++++++++++++++ .../betree_back_stateful/BetreeMain.Opaque.fsti | 35 ---------------- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 2 +- .../hashmap_on_disk/HashmapMain.FunsExternal.fsti | 18 +++++++++ .../fstar/hashmap_on_disk/HashmapMain.Opaque.fsti | 18 --------- tests/fstar/misc/External.Funs.fst | 2 +- tests/fstar/misc/External.FunsExternal.fsti | 32 +++++++++++++++ tests/fstar/misc/External.Opaque.fsti | 32 --------------- 28 files changed, 380 insertions(+), 255 deletions(-) create mode 100644 tests/coq/betree/BetreeMain_FunsExternal.v create mode 100644 tests/coq/betree/BetreeMain_FunsExternal_Template.v delete mode 100644 tests/coq/betree/BetreeMain_Opaque.v create mode 100644 tests/coq/hashmap_on_disk/HashmapMain_FunsExternal.v create mode 100644 tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v delete mode 100644 tests/coq/hashmap_on_disk/HashmapMain_Opaque.v create mode 100644 tests/coq/misc/External_FunsExternal.v create mode 100644 tests/coq/misc/External_FunsExternal_Template.v delete mode 100644 tests/coq/misc/External_Opaque.v create mode 100644 tests/fstar/betree/BetreeMain.FunsExternal.fsti delete mode 100644 tests/fstar/betree/BetreeMain.Opaque.fsti create mode 100644 tests/fstar/betree_back_stateful/BetreeMain.FunsExternal.fsti delete mode 100644 tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti create mode 100644 tests/fstar/hashmap_on_disk/HashmapMain.FunsExternal.fsti delete mode 100644 tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti create mode 100644 tests/fstar/misc/External.FunsExternal.fsti delete mode 100644 tests/fstar/misc/External.Opaque.fsti diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 05e48af5..31cb4b32 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -977,7 +977,7 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) | FStar -> () | Lean -> if fi.in_namespace then Printf.fprintf out "end %s\n" fi.namespace | HOL4 -> Printf.fprintf out "val _ = export_theory ()\n" - | Coq -> Printf.fprintf out "End %s .\n" fi.module_name); + | Coq -> Printf.fprintf out "End %s.\n" fi.module_name); (* Some logging *) log#linfo (lazy ("Generated: " ^ fi.filename)); @@ -1320,13 +1320,20 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : (* 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 *) + (* For F*, we generate an .fsti, and let the user write the .fst. + For the other backends, we generate a template file as a model + for the file the user has to provide. *) let module_suffix, opaque_imported_suffix, custom_msg = match !Config.backend with - | FStar | Coq | HOL4 -> - ("Opaque", "Opaque", ": external function declarations") - | Lean -> - ( "FunsExternal_Template", + | FStar -> + ( "FunsExternal", + "FunsExternal", + ": external function declarations" ) + | HOL4 | Coq | Lean -> + ( (* The name of the file we generate *) + "FunsExternal_Template", + (* The name of the file that will be imported by the Funs + module, and that the user has to provide. *) "FunsExternal", ": external functions.\n\ -- This is a template file: rename it to \ @@ -1337,9 +1344,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : in let opaque_module = crate_name ^ module_delimiter ^ module_suffix in let opaque_imported_module = - if !Config.backend = Lean then - crate_name ^ module_delimiter ^ opaque_imported_suffix - else opaque_module + crate_name ^ module_delimiter ^ opaque_imported_suffix in let opaque_config = { diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index 8e48b17d..ede82492 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -8,8 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Require Export BetreeMain_Types. Import BetreeMain_Types. -Require Export BetreeMain_Opaque. -Import BetreeMain_Opaque. +Require Export BetreeMain_FunsExternal. +Import BetreeMain_FunsExternal. Module BetreeMain_Funs. (** [betree_main::betree::load_internal_node]: forward function diff --git a/tests/coq/betree/BetreeMain_FunsExternal.v b/tests/coq/betree/BetreeMain_FunsExternal.v new file mode 100644 index 00000000..07dba263 --- /dev/null +++ b/tests/coq/betree/BetreeMain_FunsExternal.v @@ -0,0 +1,46 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external functions. +-- This is a template file: rename it to "FunsExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Require Export BetreeMain_Types. +Import BetreeMain_Types. +Module BetreeMain_FunsExternal. + +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) +Axiom betree_utils_load_internal_node + : u64 -> state -> result (state * (betree_List_t (u64 * betree_Message_t))) +. + +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) +Axiom betree_utils_store_internal_node + : + u64 -> betree_List_t (u64 * betree_Message_t) -> state -> result (state * + unit) +. + +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) +Axiom betree_utils_load_leaf_node + : u64 -> state -> result (state * (betree_List_t (u64 * u64))) +. + +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) +Axiom betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) +. + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +Axiom core_option_Option_unwrap : + forall(T : Type), option T -> state -> result (state * T) +. + +End BetreeMain_FunsExternal. diff --git a/tests/coq/betree/BetreeMain_FunsExternal_Template.v b/tests/coq/betree/BetreeMain_FunsExternal_Template.v new file mode 100644 index 00000000..4898acd4 --- /dev/null +++ b/tests/coq/betree/BetreeMain_FunsExternal_Template.v @@ -0,0 +1,46 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external functions. +-- This is a template file: rename it to "FunsExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Require Export BetreeMain_Types. +Import BetreeMain_Types. +Module BetreeMain_FunsExternal_Template. + +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) +Axiom betree_utils_load_internal_node + : u64 -> state -> result (state * (betree_List_t (u64 * betree_Message_t))) +. + +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) +Axiom betree_utils_store_internal_node + : + u64 -> betree_List_t (u64 * betree_Message_t) -> state -> result (state * + unit) +. + +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) +Axiom betree_utils_load_leaf_node + : u64 -> state -> result (state * (betree_List_t (u64 * u64))) +. + +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) +Axiom betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) +. + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +Axiom core_option_Option_unwrap : + forall(T : Type), option T -> state -> result (state * T) +. + +End BetreeMain_FunsExternal_Template . diff --git a/tests/coq/betree/BetreeMain_Opaque.v b/tests/coq/betree/BetreeMain_Opaque.v deleted file mode 100644 index a065c8a3..00000000 --- a/tests/coq/betree/BetreeMain_Opaque.v +++ /dev/null @@ -1,45 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [betree_main]: external function declarations *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Require Export BetreeMain_Types. -Import BetreeMain_Types. -Module BetreeMain_Opaque. - -(** [betree_main::betree_utils::load_internal_node]: forward function - Source: 'src/betree_utils.rs', lines 98:0-98:63 *) -Axiom betree_utils_load_internal_node - : u64 -> state -> result (state * (betree_List_t (u64 * betree_Message_t))) -. - -(** [betree_main::betree_utils::store_internal_node]: forward function - Source: 'src/betree_utils.rs', lines 115:0-115:71 *) -Axiom betree_utils_store_internal_node - : - u64 -> betree_List_t (u64 * betree_Message_t) -> state -> result (state * - unit) -. - -(** [betree_main::betree_utils::load_leaf_node]: forward function - Source: 'src/betree_utils.rs', lines 132:0-132:55 *) -Axiom betree_utils_load_leaf_node - : u64 -> state -> result (state * (betree_List_t (u64 * u64))) -. - -(** [betree_main::betree_utils::store_leaf_node]: forward function - Source: 'src/betree_utils.rs', lines 145:0-145:63 *) -Axiom betree_utils_store_leaf_node - : u64 -> betree_List_t (u64 * u64) -> state -> result (state * unit) -. - -(** [core::option::{core::option::Option}::unwrap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) -Axiom core_option_Option_unwrap : - forall(T : Type), option T -> state -> result (state * T) -. - -End BetreeMain_Opaque . diff --git a/tests/coq/betree/_CoqProject b/tests/coq/betree/_CoqProject index 42c62421..9ab8ea9f 100644 --- a/tests/coq/betree/_CoqProject +++ b/tests/coq/betree/_CoqProject @@ -5,5 +5,6 @@ BetreeMain_Types.v Primitives.v +BetreeMain_FunsExternal_Template.v BetreeMain_Funs.v -BetreeMain_Opaque.v +BetreeMain_FunsExternal.v diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index 46d3ee29..188c98b3 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -8,8 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Require Export HashmapMain_Types. Import HashmapMain_Types. -Require Export HashmapMain_Opaque. -Import HashmapMain_Opaque. +Require Export HashmapMain_FunsExternal. +Import HashmapMain_FunsExternal. Module HashmapMain_Funs. (** [hashmap_main::hashmap::hash_key]: forward function diff --git a/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal.v b/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal.v new file mode 100644 index 00000000..a03dc407 --- /dev/null +++ b/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal.v @@ -0,0 +1,25 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: external function declarations *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Require Export HashmapMain_Types. +Import HashmapMain_Types. +Module HashmapMain_FunsExternal. + +(** [hashmap_main::hashmap_utils::deserialize]: forward function + Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) +Axiom hashmap_utils_deserialize + : state -> result (state * (hashmap_HashMap_t u64)) +. + +(** [hashmap_main::hashmap_utils::serialize]: forward function + Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) +Axiom hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state * unit) +. + +End HashmapMain_FunsExternal. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v b/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v new file mode 100644 index 00000000..b5a4a101 --- /dev/null +++ b/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v @@ -0,0 +1,26 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: external functions. +-- This is a template file: rename it to "FunsExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Require Export HashmapMain_Types. +Import HashmapMain_Types. +Module HashmapMain_FunsExternal_Template. + +(** [hashmap_main::hashmap_utils::deserialize]: forward function + Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) +Axiom hashmap_utils_deserialize + : state -> result (state * (hashmap_HashMap_t u64)) +. + +(** [hashmap_main::hashmap_utils::serialize]: forward function + Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) +Axiom hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state * unit) +. + +End HashmapMain_FunsExternal_Template . diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v b/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v deleted file mode 100644 index a0e9003d..00000000 --- a/tests/coq/hashmap_on_disk/HashmapMain_Opaque.v +++ /dev/null @@ -1,25 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [hashmap_main]: external function declarations *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Require Export HashmapMain_Types. -Import HashmapMain_Types. -Module HashmapMain_Opaque. - -(** [hashmap_main::hashmap_utils::deserialize]: forward function - Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) -Axiom hashmap_utils_deserialize - : state -> result (state * (hashmap_HashMap_t u64)) -. - -(** [hashmap_main::hashmap_utils::serialize]: forward function - Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) -Axiom hashmap_utils_serialize - : hashmap_HashMap_t u64 -> state -> result (state * unit) -. - -End HashmapMain_Opaque . diff --git a/tests/coq/hashmap_on_disk/_CoqProject b/tests/coq/hashmap_on_disk/_CoqProject index b78c7b5f..a85fa1fe 100644 --- a/tests/coq/hashmap_on_disk/_CoqProject +++ b/tests/coq/hashmap_on_disk/_CoqProject @@ -6,4 +6,5 @@ HashmapMain_Types.v Primitives.v HashmapMain_Funs.v -HashmapMain_Opaque.v +HashmapMain_FunsExternal_Template.v +HashmapMain_FunsExternal.v diff --git a/tests/coq/misc/External_Funs.v b/tests/coq/misc/External_Funs.v index 0a14c7d1..8a3360bb 100644 --- a/tests/coq/misc/External_Funs.v +++ b/tests/coq/misc/External_Funs.v @@ -8,8 +8,8 @@ Import ListNotations. Local Open Scope Primitives_scope. Require Export External_Types. Import External_Types. -Require Export External_Opaque. -Import External_Opaque. +Require Export External_FunsExternal. +Import External_FunsExternal. Module External_Funs. (** [external::swap]: forward function diff --git a/tests/coq/misc/External_FunsExternal.v b/tests/coq/misc/External_FunsExternal.v new file mode 100644 index 00000000..07d43061 --- /dev/null +++ b/tests/coq/misc/External_FunsExternal.v @@ -0,0 +1,43 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: external function declarations *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Require Export External_Types. +Import External_Types. +Module External_FunsExternal. + +(** [core::mem::swap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +Axiom core_mem_swap : + forall(T : Type), T -> T -> state -> result (state * unit) +. + +(** [core::mem::swap]: backward function 0 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +Axiom core_mem_swap_back0 : + forall(T : Type), T -> T -> state -> state -> result (state * T) +. + +(** [core::mem::swap]: backward function 1 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +Axiom core_mem_swap_back1 : + forall(T : Type), T -> T -> state -> state -> result (state * T) +. + +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) +Axiom core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) +. + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +Axiom core_option_Option_unwrap : + forall(T : Type), option T -> state -> result (state * T) +. + +End External_FunsExternal. diff --git a/tests/coq/misc/External_FunsExternal_Template.v b/tests/coq/misc/External_FunsExternal_Template.v new file mode 100644 index 00000000..0977c3ae --- /dev/null +++ b/tests/coq/misc/External_FunsExternal_Template.v @@ -0,0 +1,44 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: external functions. +-- This is a template file: rename it to "FunsExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Require Export External_Types. +Import External_Types. +Module External_FunsExternal_Template. + +(** [core::mem::swap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +Axiom core_mem_swap : + forall(T : Type), T -> T -> state -> result (state * unit) +. + +(** [core::mem::swap]: backward function 0 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +Axiom core_mem_swap_back0 : + forall(T : Type), T -> T -> state -> state -> result (state * T) +. + +(** [core::mem::swap]: backward function 1 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +Axiom core_mem_swap_back1 : + forall(T : Type), T -> T -> state -> state -> result (state * T) +. + +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) +Axiom core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) +. + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +Axiom core_option_Option_unwrap : + forall(T : Type), option T -> state -> result (state * T) +. + +End External_FunsExternal_Template . diff --git a/tests/coq/misc/External_Opaque.v b/tests/coq/misc/External_Opaque.v deleted file mode 100644 index b482431f..00000000 --- a/tests/coq/misc/External_Opaque.v +++ /dev/null @@ -1,43 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [external]: external function declarations *) -Require Import Primitives. -Import Primitives. -Require Import Coq.ZArith.ZArith. -Require Import List. -Import ListNotations. -Local Open Scope Primitives_scope. -Require Export External_Types. -Import External_Types. -Module External_Opaque. - -(** [core::mem::swap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) -Axiom core_mem_swap : - forall(T : Type), T -> T -> state -> result (state * unit) -. - -(** [core::mem::swap]: backward function 0 - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) -Axiom core_mem_swap_back0 : - forall(T : Type), T -> T -> state -> state -> result (state * T) -. - -(** [core::mem::swap]: backward function 1 - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) -Axiom core_mem_swap_back1 : - forall(T : Type), T -> T -> state -> state -> result (state * T) -. - -(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) -Axiom core_num_nonzero_NonZeroU32_new - : u32 -> state -> result (state * (option core_num_nonzero_NonZeroU32_t)) -. - -(** [core::option::{core::option::Option}::unwrap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) -Axiom core_option_Option_unwrap : - forall(T : Type), option T -> state -> result (state * T) -. - -End External_Opaque . diff --git a/tests/coq/misc/_CoqProject b/tests/coq/misc/_CoqProject index db6c2742..6884d5d9 100644 --- a/tests/coq/misc/_CoqProject +++ b/tests/coq/misc/_CoqProject @@ -10,5 +10,6 @@ Constants.v PoloniusList.v External_Types.v NoNestedBorrows.v -External_Opaque.v +External_FunsExternal.v +External_FunsExternal_Template.v Paper.v diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index 537ec32e..fef8a8e1 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -3,7 +3,7 @@ module BetreeMain.Funs open Primitives include BetreeMain.Types -include BetreeMain.Opaque +include BetreeMain.FunsExternal include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" diff --git a/tests/fstar/betree/BetreeMain.FunsExternal.fsti b/tests/fstar/betree/BetreeMain.FunsExternal.fsti new file mode 100644 index 00000000..cd2f956f --- /dev/null +++ b/tests/fstar/betree/BetreeMain.FunsExternal.fsti @@ -0,0 +1,35 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external function declarations *) +module BetreeMain.FunsExternal +open Primitives +include BetreeMain.Types + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) +val betree_utils_load_internal_node + : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) + +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) +val betree_utils_store_internal_node + : + u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & + unit) + +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) +val betree_utils_load_leaf_node + : u64 -> state -> result (state & (betree_List_t (u64 & u64))) + +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) +val betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +val core_option_Option_unwrap + (t : Type0) : option t -> state -> result (state & t) + diff --git a/tests/fstar/betree/BetreeMain.Opaque.fsti b/tests/fstar/betree/BetreeMain.Opaque.fsti deleted file mode 100644 index b89c8718..00000000 --- a/tests/fstar/betree/BetreeMain.Opaque.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [betree_main]: external function declarations *) -module BetreeMain.Opaque -open Primitives -include BetreeMain.Types - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [betree_main::betree_utils::load_internal_node]: forward function - Source: 'src/betree_utils.rs', lines 98:0-98:63 *) -val betree_utils_load_internal_node - : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) - -(** [betree_main::betree_utils::store_internal_node]: forward function - Source: 'src/betree_utils.rs', lines 115:0-115:71 *) -val betree_utils_store_internal_node - : - u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & - unit) - -(** [betree_main::betree_utils::load_leaf_node]: forward function - Source: 'src/betree_utils.rs', lines 132:0-132:55 *) -val betree_utils_load_leaf_node - : u64 -> state -> result (state & (betree_List_t (u64 & u64))) - -(** [betree_main::betree_utils::store_leaf_node]: forward function - Source: 'src/betree_utils.rs', lines 145:0-145:63 *) -val betree_utils_store_leaf_node - : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) - -(** [core::option::{core::option::Option}::unwrap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) -val core_option_Option_unwrap - (t : Type0) : option t -> state -> result (state & t) - diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index a2586431..b912a316 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -3,7 +3,7 @@ module BetreeMain.Funs open Primitives include BetreeMain.Types -include BetreeMain.Opaque +include BetreeMain.FunsExternal include BetreeMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" diff --git a/tests/fstar/betree_back_stateful/BetreeMain.FunsExternal.fsti b/tests/fstar/betree_back_stateful/BetreeMain.FunsExternal.fsti new file mode 100644 index 00000000..cd2f956f --- /dev/null +++ b/tests/fstar/betree_back_stateful/BetreeMain.FunsExternal.fsti @@ -0,0 +1,35 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external function declarations *) +module BetreeMain.FunsExternal +open Primitives +include BetreeMain.Types + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [betree_main::betree_utils::load_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 98:0-98:63 *) +val betree_utils_load_internal_node + : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) + +(** [betree_main::betree_utils::store_internal_node]: forward function + Source: 'src/betree_utils.rs', lines 115:0-115:71 *) +val betree_utils_store_internal_node + : + u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & + unit) + +(** [betree_main::betree_utils::load_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 132:0-132:55 *) +val betree_utils_load_leaf_node + : u64 -> state -> result (state & (betree_List_t (u64 & u64))) + +(** [betree_main::betree_utils::store_leaf_node]: forward function + Source: 'src/betree_utils.rs', lines 145:0-145:63 *) +val betree_utils_store_leaf_node + : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +val core_option_Option_unwrap + (t : Type0) : option t -> state -> result (state & t) + diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti deleted file mode 100644 index b89c8718..00000000 --- a/tests/fstar/betree_back_stateful/BetreeMain.Opaque.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [betree_main]: external function declarations *) -module BetreeMain.Opaque -open Primitives -include BetreeMain.Types - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [betree_main::betree_utils::load_internal_node]: forward function - Source: 'src/betree_utils.rs', lines 98:0-98:63 *) -val betree_utils_load_internal_node - : u64 -> state -> result (state & (betree_List_t (u64 & betree_Message_t))) - -(** [betree_main::betree_utils::store_internal_node]: forward function - Source: 'src/betree_utils.rs', lines 115:0-115:71 *) -val betree_utils_store_internal_node - : - u64 -> betree_List_t (u64 & betree_Message_t) -> state -> result (state & - unit) - -(** [betree_main::betree_utils::load_leaf_node]: forward function - Source: 'src/betree_utils.rs', lines 132:0-132:55 *) -val betree_utils_load_leaf_node - : u64 -> state -> result (state & (betree_List_t (u64 & u64))) - -(** [betree_main::betree_utils::store_leaf_node]: forward function - Source: 'src/betree_utils.rs', lines 145:0-145:63 *) -val betree_utils_store_leaf_node - : u64 -> betree_List_t (u64 & u64) -> state -> result (state & unit) - -(** [core::option::{core::option::Option}::unwrap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) -val core_option_Option_unwrap - (t : Type0) : option t -> state -> result (state & t) - diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index fa570309..f2d09a38 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -3,7 +3,7 @@ module HashmapMain.Funs open Primitives include HashmapMain.Types -include HashmapMain.Opaque +include HashmapMain.FunsExternal include HashmapMain.Clauses #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.FunsExternal.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.FunsExternal.fsti new file mode 100644 index 00000000..b00bbcde --- /dev/null +++ b/tests/fstar/hashmap_on_disk/HashmapMain.FunsExternal.fsti @@ -0,0 +1,18 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: external function declarations *) +module HashmapMain.FunsExternal +open Primitives +include HashmapMain.Types + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [hashmap_main::hashmap_utils::deserialize]: forward function + Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) +val hashmap_utils_deserialize + : state -> result (state & (hashmap_HashMap_t u64)) + +(** [hashmap_main::hashmap_utils::serialize]: forward function + Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) +val hashmap_utils_serialize + : hashmap_HashMap_t u64 -> state -> result (state & unit) + diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti deleted file mode 100644 index 1f47eb33..00000000 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Opaque.fsti +++ /dev/null @@ -1,18 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [hashmap_main]: external function declarations *) -module HashmapMain.Opaque -open Primitives -include HashmapMain.Types - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [hashmap_main::hashmap_utils::deserialize]: forward function - Source: 'src/hashmap_utils.rs', lines 10:0-10:43 *) -val hashmap_utils_deserialize - : state -> result (state & (hashmap_HashMap_t u64)) - -(** [hashmap_main::hashmap_utils::serialize]: forward function - Source: 'src/hashmap_utils.rs', lines 5:0-5:42 *) -val hashmap_utils_serialize - : hashmap_HashMap_t u64 -> state -> result (state & unit) - diff --git a/tests/fstar/misc/External.Funs.fst b/tests/fstar/misc/External.Funs.fst index 4d13fb71..00995634 100644 --- a/tests/fstar/misc/External.Funs.fst +++ b/tests/fstar/misc/External.Funs.fst @@ -3,7 +3,7 @@ module External.Funs open Primitives include External.Types -include External.Opaque +include External.FunsExternal #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" diff --git a/tests/fstar/misc/External.FunsExternal.fsti b/tests/fstar/misc/External.FunsExternal.fsti new file mode 100644 index 00000000..923a1101 --- /dev/null +++ b/tests/fstar/misc/External.FunsExternal.fsti @@ -0,0 +1,32 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: external function declarations *) +module External.FunsExternal +open Primitives +include External.Types + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [core::mem::swap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +val core_mem_swap (t : Type0) : t -> t -> state -> result (state & unit) + +(** [core::mem::swap]: backward function 0 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +val core_mem_swap_back0 + (t : Type0) : t -> t -> state -> state -> result (state & t) + +(** [core::mem::swap]: backward function 1 + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) +val core_mem_swap_back1 + (t : Type0) : t -> t -> state -> state -> result (state & t) + +(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) +val core_num_nonzero_NonZeroU32_new + : u32 -> state -> result (state & (option core_num_nonzero_NonZeroU32_t)) + +(** [core::option::{core::option::Option}::unwrap]: forward function + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) +val core_option_Option_unwrap + (t : Type0) : option t -> state -> result (state & t) + diff --git a/tests/fstar/misc/External.Opaque.fsti b/tests/fstar/misc/External.Opaque.fsti deleted file mode 100644 index ea1a70c2..00000000 --- a/tests/fstar/misc/External.Opaque.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [external]: external function declarations *) -module External.Opaque -open Primitives -include External.Types - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [core::mem::swap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) -val core_mem_swap (t : Type0) : t -> t -> state -> result (state & unit) - -(** [core::mem::swap]: backward function 0 - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) -val core_mem_swap_back0 - (t : Type0) : t -> t -> state -> state -> result (state & t) - -(** [core::mem::swap]: backward function 1 - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/mem/mod.rs', lines 726:0-726:42 *) -val core_mem_swap_back1 - (t : Type0) : t -> t -> state -> state -> result (state & t) - -(** [core::num::nonzero::{core::num::nonzero::NonZeroU32#14}::new]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 79:16-79:57 *) -val core_num_nonzero_NonZeroU32_new - : u32 -> state -> result (state & (option core_num_nonzero_NonZeroU32_t)) - -(** [core::option::{core::option::Option}::unwrap]: forward function - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/option.rs', lines 932:4-932:34 *) -val core_option_Option_unwrap - (t : Type0) : option t -> state -> result (state & t) - -- cgit v1.2.3 From bef2bd34fcb0817f1b7d16b95122bcc3c6f05c72 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 10:29:25 +0100 Subject: Generate a dedicated file for the external types --- compiler/Translate.ml | 114 ++++++++++++++++++--- tests/coq/array/Array.v | 2 +- tests/coq/betree/BetreeMain_Funs.v | 10 +- .../coq/betree/BetreeMain_FunsExternal_Template.v | 6 +- tests/coq/betree/BetreeMain_Types.v | 7 +- tests/coq/betree/BetreeMain_TypesExternal.v | 15 +++ .../coq/betree/BetreeMain_TypesExternal_Template.v | 15 +++ tests/coq/betree/_CoqProject | 2 + tests/coq/hashmap/Hashmap_Funs.v | 6 +- tests/coq/hashmap/Hashmap_Types.v | 2 +- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 10 +- .../HashmapMain_FunsExternal_Template.v | 6 +- tests/coq/hashmap_on_disk/HashmapMain_Types.v | 7 +- .../hashmap_on_disk/HashmapMain_TypesExternal.v | 15 +++ .../HashmapMain_TypesExternal_Template.v | 15 +++ tests/coq/hashmap_on_disk/_CoqProject | 2 + tests/coq/misc/Constants.v | 2 +- tests/coq/misc/External_Funs.v | 10 +- tests/coq/misc/External_FunsExternal.v | 2 +- tests/coq/misc/External_FunsExternal_Template.v | 6 +- tests/coq/misc/External_Types.v | 11 +- tests/coq/misc/External_TypesExternal.v | 19 ++++ tests/coq/misc/External_TypesExternal_Template.v | 19 ++++ tests/coq/misc/Loops.v | 2 +- tests/coq/misc/NoNestedBorrows.v | 2 +- tests/coq/misc/Paper.v | 2 +- tests/coq/misc/PoloniusList.v | 2 +- tests/coq/misc/_CoqProject | 6 +- tests/coq/traits/Traits.v | 2 +- tests/fstar/betree/BetreeMain.Types.fst | 61 +++++++++++ tests/fstar/betree/BetreeMain.Types.fsti | 63 ------------ tests/fstar/betree/BetreeMain.TypesExternal.fsti | 10 ++ .../betree_back_stateful/BetreeMain.Types.fst | 61 +++++++++++ .../betree_back_stateful/BetreeMain.Types.fsti | 63 ------------ .../BetreeMain.TypesExternal.fsti | 10 ++ tests/fstar/hashmap_on_disk/HashmapMain.Types.fst | 24 +++++ tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti | 26 ----- .../hashmap_on_disk/HashmapMain.TypesExternal.fsti | 10 ++ tests/fstar/misc/External.Types.fst | 8 ++ tests/fstar/misc/External.Types.fsti | 14 --- tests/fstar/misc/External.TypesExternal.fsti | 14 +++ tests/lean/BetreeMain/Types.lean | 4 +- tests/lean/BetreeMain/TypesExternal.lean | 7 ++ tests/lean/BetreeMain/TypesExternal_Template.lean | 9 ++ tests/lean/External/Types.lean | 8 +- tests/lean/External/TypesExternal.lean | 11 ++ tests/lean/External/TypesExternal_Template.lean | 13 +++ tests/lean/HashmapMain/Types.lean | 4 +- tests/lean/HashmapMain/TypesExternal.lean | 7 ++ tests/lean/HashmapMain/TypesExternal_Template.lean | 9 ++ 50 files changed, 510 insertions(+), 245 deletions(-) create mode 100644 tests/coq/betree/BetreeMain_TypesExternal.v create mode 100644 tests/coq/betree/BetreeMain_TypesExternal_Template.v create mode 100644 tests/coq/hashmap_on_disk/HashmapMain_TypesExternal.v create mode 100644 tests/coq/hashmap_on_disk/HashmapMain_TypesExternal_Template.v create mode 100644 tests/coq/misc/External_TypesExternal.v create mode 100644 tests/coq/misc/External_TypesExternal_Template.v create mode 100644 tests/fstar/betree/BetreeMain.Types.fst delete mode 100644 tests/fstar/betree/BetreeMain.Types.fsti create mode 100644 tests/fstar/betree/BetreeMain.TypesExternal.fsti create mode 100644 tests/fstar/betree_back_stateful/BetreeMain.Types.fst delete mode 100644 tests/fstar/betree_back_stateful/BetreeMain.Types.fsti create mode 100644 tests/fstar/betree_back_stateful/BetreeMain.TypesExternal.fsti create mode 100644 tests/fstar/hashmap_on_disk/HashmapMain.Types.fst delete mode 100644 tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti create mode 100644 tests/fstar/hashmap_on_disk/HashmapMain.TypesExternal.fsti create mode 100644 tests/fstar/misc/External.Types.fst delete mode 100644 tests/fstar/misc/External.Types.fsti create mode 100644 tests/fstar/misc/External.TypesExternal.fsti create mode 100644 tests/lean/BetreeMain/TypesExternal.lean create mode 100644 tests/lean/BetreeMain/TypesExternal_Template.lean create mode 100644 tests/lean/External/TypesExternal.lean create mode 100644 tests/lean/External/TypesExternal_Template.lean create mode 100644 tests/lean/HashmapMain/TypesExternal.lean create mode 100644 tests/lean/HashmapMain/TypesExternal_Template.lean diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 31cb4b32..cc84b9fb 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -481,9 +481,19 @@ let export_types_group (fmt : Format.formatter) (config : gen_config) defs in + let dont_extract (d : Pure.type_decl) : bool = + match d.kind with + | Enum _ | Struct _ -> not config.extract_transparent + | Opaque -> not config.extract_opaque + in + if List.exists (fun b -> b) builtin then (* Sanity check *) assert (List.for_all (fun b -> b) builtin) + else if List.exists dont_extract defs then + (* Check if we have to ignore declarations *) + (* Sanity check *) + assert (List.for_all dont_extract defs) else ( (* Extract the type declarations. @@ -873,6 +883,7 @@ type extract_file_info = { filename : string; namespace : string; in_namespace : bool; + open_namespace : bool; crate_name : string; rust_module_name : string; module_name : string; @@ -931,8 +942,22 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) (* Add the custom includes *) List.iter (fun m -> - Printf.fprintf out "Require Export %s.\n" m; - Printf.fprintf out "Import %s.\n" m) + (* TODO: I don't really understand how the "Require Export", + "Require Import", "Include" work. + I used to have: + {[ + Require Export %s. + Import %s. + ]} + + I now have: + {[ + Require Import %s. + Include %s. + ]} + *) + Printf.fprintf out "Require Import %s.\n" m; + Printf.fprintf out "Include %s.\n" m) fi.custom_includes; Printf.fprintf out "Module %s.\n" fi.module_name | Lean -> @@ -943,9 +968,10 @@ let extract_file (config : gen_config) (ctx : gen_ctx) (fi : extract_file_info) List.iter (fun m -> Printf.fprintf out "import %s\n" m) fi.custom_includes; (* Always open the Primitives namespace *) Printf.fprintf out "open Primitives\n"; - (* If we are inside the namespace: declare it, otherwise: open it *) - if fi.in_namespace then Printf.fprintf out "\nnamespace %s\n" fi.namespace - else Printf.fprintf out "open %s\n" fi.namespace + (* If we are inside the namespace: declare it *) + if fi.in_namespace then Printf.fprintf out "\nnamespace %s\n" fi.namespace; + (* We might need to open the namespace *) + if fi.open_namespace then Printf.fprintf out "open %s\n" fi.namespace | HOL4 -> Printf.fprintf out "open primitivesLib divDefLib\n"; (* Add the custom imports and includes *) @@ -1250,12 +1276,72 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : in let has_opaque_types = has_opaque_types || !Config.use_state in - (* Extract the types *) + (* + * Extract the types + *) (* If there are opaque types, we extract in an interface *) - (* TODO: for Lean and Coq: generate a template file *) + (* Extract the opaque type declarations, if needed *) + let opaque_types_module = + if has_opaque_types then ( + (* For F*, we generate an .fsti, and let the user write the .fst. + For the other backends, we generate a template file as a model + for the file the user has to provide. *) + let module_suffix, opaque_imported_suffix, custom_msg = + match !Config.backend with + | FStar -> + ("TypesExternal", "TypesExternal", ": external type declarations") + | HOL4 | Coq | Lean -> + ( (* The name of the file we generate *) + "TypesExternal_Template", + (* The name of the file that will be imported by the Types + module, and that the user has to provide. *) + "TypesExternal", + ": external types.\n\ + -- This is a template file: rename it to \ + \"TypesExternal.lean\" and fill the holes." ) + in + let opaque_filename = + extract_filebasename ^ file_delimiter ^ module_suffix ^ opaque_ext + in + let opaque_module = crate_name ^ module_delimiter ^ module_suffix in + let opaque_imported_module = + crate_name ^ module_delimiter ^ opaque_imported_suffix + in + let opaque_config = + { + base_gen_config with + extract_opaque = true; + extract_transparent = false; + extract_types = true; + extract_trait_decls = true; + extract_state_type = !Config.use_state; + interface = true; + } + in + let file_info = + { + filename = opaque_filename; + namespace; + in_namespace = false; + open_namespace = false; + crate_name; + rust_module_name = crate.name; + module_name = opaque_module; + custom_msg; + custom_imports = []; + custom_includes = []; + } + in + extract_file opaque_config ctx file_info; + (* Return the additional dependencies *) + [ opaque_imported_module ]) + else [] + in + + (* Extract the non opaque types *) let types_filename_ext = match !Config.backend with - | FStar -> if has_opaque_types then ".fsti" else ".fst" + | FStar -> ".fst" | Coq -> ".v" | Lean -> ".lean" | HOL4 -> "Script.sml" @@ -1269,8 +1355,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : base_gen_config with extract_types = true; extract_trait_decls = true; - extract_opaque = true; - extract_state_type = !Config.use_state; + extract_opaque = false; interface = has_opaque_types; } in @@ -1279,12 +1364,13 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : filename = types_filename; namespace; in_namespace = true; + open_namespace = false; crate_name; rust_module_name = crate.name; module_name = types_module; custom_msg = ": type definitions"; custom_imports = []; - custom_includes = []; + custom_includes = opaque_types_module; } in extract_file types_config ctx file_info; @@ -1307,6 +1393,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : filename = template_clauses_filename; namespace; in_namespace = true; + open_namespace = false; crate_name; rust_module_name = crate.name; module_name = template_clauses_module; @@ -1317,7 +1404,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : in extract_file template_clauses_config ctx file_info); - (* Extract the opaque declarations, if needed *) + (* Extract the opaque fun declarations, if needed *) let opaque_funs_module = if has_opaque_funs then ( (* For F*, we generate an .fsti, and let the user write the .fst. @@ -1362,6 +1449,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : filename = opaque_filename; namespace; in_namespace = false; + open_namespace = true; crate_name; rust_module_name = crate.name; module_name = opaque_module; @@ -1401,6 +1489,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : filename = fun_filename; namespace; in_namespace = true; + open_namespace = false; crate_name; rust_module_name = crate.name; module_name = fun_module; @@ -1434,6 +1523,7 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : filename = extract_filebasename ^ ext; namespace; in_namespace = true; + open_namespace = false; crate_name; rust_module_name = crate.name; module_name = crate_name; diff --git a/tests/coq/array/Array.v b/tests/coq/array/Array.v index 99ff3b03..105ce21f 100644 --- a/tests/coq/array/Array.v +++ b/tests/coq/array/Array.v @@ -528,4 +528,4 @@ Definition ite : result unit := Return tt . -End Array . +End Array. diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index ede82492..aadaa20d 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -6,10 +6,10 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export BetreeMain_Types. -Import BetreeMain_Types. -Require Export BetreeMain_FunsExternal. -Import BetreeMain_FunsExternal. +Require Import BetreeMain_Types. +Include BetreeMain_Types. +Require Import BetreeMain_FunsExternal. +Include BetreeMain_FunsExternal. Module BetreeMain_Funs. (** [betree_main::betree::load_internal_node]: forward function @@ -1230,4 +1230,4 @@ Definition main : result unit := (** Unit test for [betree_main::main] *) Check (main )%return. -End BetreeMain_Funs . +End BetreeMain_Funs. diff --git a/tests/coq/betree/BetreeMain_FunsExternal_Template.v b/tests/coq/betree/BetreeMain_FunsExternal_Template.v index 4898acd4..36022a20 100644 --- a/tests/coq/betree/BetreeMain_FunsExternal_Template.v +++ b/tests/coq/betree/BetreeMain_FunsExternal_Template.v @@ -7,8 +7,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export BetreeMain_Types. -Import BetreeMain_Types. +Require Import BetreeMain_Types. +Include BetreeMain_Types. Module BetreeMain_FunsExternal_Template. (** [betree_main::betree_utils::load_internal_node]: forward function @@ -43,4 +43,4 @@ Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . -End BetreeMain_FunsExternal_Template . +End BetreeMain_FunsExternal_Template. diff --git a/tests/coq/betree/BetreeMain_Types.v b/tests/coq/betree/BetreeMain_Types.v index b729d1c3..22989256 100644 --- a/tests/coq/betree/BetreeMain_Types.v +++ b/tests/coq/betree/BetreeMain_Types.v @@ -6,6 +6,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. +Require Import BetreeMain_TypesExternal. +Include BetreeMain_TypesExternal. Module BetreeMain_Types. (** [betree_main::betree::List] @@ -113,7 +115,4 @@ mkbetree_BeTree_t { } . -(** The state type used in the state-error monad *) -Axiom state : Type. - -End BetreeMain_Types . +End BetreeMain_Types. diff --git a/tests/coq/betree/BetreeMain_TypesExternal.v b/tests/coq/betree/BetreeMain_TypesExternal.v new file mode 100644 index 00000000..50c4a4f8 --- /dev/null +++ b/tests/coq/betree/BetreeMain_TypesExternal.v @@ -0,0 +1,15 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module BetreeMain_TypesExternal. + +(** The state type used in the state-error monad *) +Axiom state : Type. + +End BetreeMain_TypesExternal. diff --git a/tests/coq/betree/BetreeMain_TypesExternal_Template.v b/tests/coq/betree/BetreeMain_TypesExternal_Template.v new file mode 100644 index 00000000..651de2b7 --- /dev/null +++ b/tests/coq/betree/BetreeMain_TypesExternal_Template.v @@ -0,0 +1,15 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module BetreeMain_TypesExternal_Template. + +(** The state type used in the state-error monad *) +Axiom state : Type. + +End BetreeMain_TypesExternal_Template. diff --git a/tests/coq/betree/_CoqProject b/tests/coq/betree/_CoqProject index 9ab8ea9f..13e4b9c1 100644 --- a/tests/coq/betree/_CoqProject +++ b/tests/coq/betree/_CoqProject @@ -4,7 +4,9 @@ -arg all BetreeMain_Types.v +BetreeMain_TypesExternal_Template.v Primitives.v BetreeMain_FunsExternal_Template.v BetreeMain_Funs.v +BetreeMain_TypesExternal.v BetreeMain_FunsExternal.v diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index c08f7f7d..64de44a6 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -6,8 +6,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export Hashmap_Types. -Import Hashmap_Types. +Require Import Hashmap_Types. +Include Hashmap_Types. Module Hashmap_Funs. (** [hashmap::hash_key]: forward function @@ -668,4 +668,4 @@ Definition test1 (n : nat) : result unit := end)) . -End Hashmap_Funs . +End Hashmap_Funs. diff --git a/tests/coq/hashmap/Hashmap_Types.v b/tests/coq/hashmap/Hashmap_Types.v index bfb5ae4b..80a43593 100644 --- a/tests/coq/hashmap/Hashmap_Types.v +++ b/tests/coq/hashmap/Hashmap_Types.v @@ -35,4 +35,4 @@ Arguments hashMap_max_load_factor { _ }. Arguments hashMap_max_load { _ }. Arguments hashMap_slots { _ }. -End Hashmap_Types . +End Hashmap_Types. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index 188c98b3..faba0afe 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -6,10 +6,10 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export HashmapMain_Types. -Import HashmapMain_Types. -Require Export HashmapMain_FunsExternal. -Import HashmapMain_FunsExternal. +Require Import HashmapMain_Types. +Include HashmapMain_Types. +Require Import HashmapMain_FunsExternal. +Include HashmapMain_FunsExternal. Module HashmapMain_Funs. (** [hashmap_main::hashmap::hash_key]: forward function @@ -717,4 +717,4 @@ Definition insert_on_disk Definition main : result unit := Return tt. -End HashmapMain_Funs . +End HashmapMain_Funs. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v b/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v index b5a4a101..e10d02f6 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_FunsExternal_Template.v @@ -7,8 +7,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export HashmapMain_Types. -Import HashmapMain_Types. +Require Import HashmapMain_Types. +Include HashmapMain_Types. Module HashmapMain_FunsExternal_Template. (** [hashmap_main::hashmap_utils::deserialize]: forward function @@ -23,4 +23,4 @@ Axiom hashmap_utils_serialize : hashmap_HashMap_t u64 -> state -> result (state * unit) . -End HashmapMain_FunsExternal_Template . +End HashmapMain_FunsExternal_Template. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Types.v b/tests/coq/hashmap_on_disk/HashmapMain_Types.v index 039b7e72..8d3d72aa 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Types.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Types.v @@ -6,6 +6,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. +Require Import HashmapMain_TypesExternal. +Include HashmapMain_TypesExternal. Module HashmapMain_Types. (** [hashmap_main::hashmap::List] @@ -35,7 +37,4 @@ Arguments hashmap_HashMap_max_load_factor { _ }. Arguments hashmap_HashMap_max_load { _ }. Arguments hashmap_HashMap_slots { _ }. -(** The state type used in the state-error monad *) -Axiom state : Type. - -End HashmapMain_Types . +End HashmapMain_Types. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_TypesExternal.v b/tests/coq/hashmap_on_disk/HashmapMain_TypesExternal.v new file mode 100644 index 00000000..87568232 --- /dev/null +++ b/tests/coq/hashmap_on_disk/HashmapMain_TypesExternal.v @@ -0,0 +1,15 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module HashmapMain_TypesExternal. + +(** The state type used in the state-error monad *) +Axiom state : Type. + +End HashmapMain_TypesExternal. diff --git a/tests/coq/hashmap_on_disk/HashmapMain_TypesExternal_Template.v b/tests/coq/hashmap_on_disk/HashmapMain_TypesExternal_Template.v new file mode 100644 index 00000000..391b2775 --- /dev/null +++ b/tests/coq/hashmap_on_disk/HashmapMain_TypesExternal_Template.v @@ -0,0 +1,15 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module HashmapMain_TypesExternal_Template. + +(** The state type used in the state-error monad *) +Axiom state : Type. + +End HashmapMain_TypesExternal_Template. diff --git a/tests/coq/hashmap_on_disk/_CoqProject b/tests/coq/hashmap_on_disk/_CoqProject index a85fa1fe..41945494 100644 --- a/tests/coq/hashmap_on_disk/_CoqProject +++ b/tests/coq/hashmap_on_disk/_CoqProject @@ -6,5 +6,7 @@ HashmapMain_Types.v Primitives.v HashmapMain_Funs.v +HashmapMain_TypesExternal.v HashmapMain_FunsExternal_Template.v HashmapMain_FunsExternal.v +HashmapMain_TypesExternal_Template.v diff --git a/tests/coq/misc/Constants.v b/tests/coq/misc/Constants.v index 20edb2b1..ad899f25 100644 --- a/tests/coq/misc/Constants.v +++ b/tests/coq/misc/Constants.v @@ -157,4 +157,4 @@ Definition s3_c : Pair_t u32 u32 := s3_body%global. Definition s4_body : result (Pair_t u32 u32) := mk_pair1 7%u32 8%u32. Definition s4_c : Pair_t u32 u32 := s4_body%global. -End Constants . +End Constants. diff --git a/tests/coq/misc/External_Funs.v b/tests/coq/misc/External_Funs.v index 8a3360bb..e9d39f66 100644 --- a/tests/coq/misc/External_Funs.v +++ b/tests/coq/misc/External_Funs.v @@ -6,10 +6,10 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export External_Types. -Import External_Types. -Require Export External_FunsExternal. -Import External_FunsExternal. +Require Import External_Types. +Include External_Types. +Require Import External_FunsExternal. +Include External_FunsExternal. Module External_Funs. (** [external::swap]: forward function @@ -115,4 +115,4 @@ Definition test_swap_non_zero (x : u32) (st : state) : result (state * u32) := if x0 s= 0%u32 then Fail_ Failure else Return (st1, x0) . -End External_Funs . +End External_Funs. diff --git a/tests/coq/misc/External_FunsExternal.v b/tests/coq/misc/External_FunsExternal.v index 07d43061..a8c5756a 100644 --- a/tests/coq/misc/External_FunsExternal.v +++ b/tests/coq/misc/External_FunsExternal.v @@ -7,7 +7,7 @@ Require Import List. Import ListNotations. Local Open Scope Primitives_scope. Require Export External_Types. -Import External_Types. +Include External_Types. Module External_FunsExternal. (** [core::mem::swap]: forward function diff --git a/tests/coq/misc/External_FunsExternal_Template.v b/tests/coq/misc/External_FunsExternal_Template.v index 0977c3ae..31e69c39 100644 --- a/tests/coq/misc/External_FunsExternal_Template.v +++ b/tests/coq/misc/External_FunsExternal_Template.v @@ -7,8 +7,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. -Require Export External_Types. -Import External_Types. +Require Import External_Types. +Include External_Types. Module External_FunsExternal_Template. (** [core::mem::swap]: forward function @@ -41,4 +41,4 @@ Axiom core_option_Option_unwrap : forall(T : Type), option T -> state -> result (state * T) . -End External_FunsExternal_Template . +End External_FunsExternal_Template. diff --git a/tests/coq/misc/External_Types.v b/tests/coq/misc/External_Types.v index c638670c..b42c2ecf 100644 --- a/tests/coq/misc/External_Types.v +++ b/tests/coq/misc/External_Types.v @@ -6,13 +6,8 @@ Require Import Coq.ZArith.ZArith. Require Import List. Import ListNotations. Local Open Scope Primitives_scope. +Require Import External_TypesExternal. +Include External_TypesExternal. Module External_Types. -(** [core::num::nonzero::NonZeroU32] - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) -Axiom core_num_nonzero_NonZeroU32_t : Type. - -(** The state type used in the state-error monad *) -Axiom state : Type. - -End External_Types . +End External_Types. diff --git a/tests/coq/misc/External_TypesExternal.v b/tests/coq/misc/External_TypesExternal.v new file mode 100644 index 00000000..3f02b839 --- /dev/null +++ b/tests/coq/misc/External_TypesExternal.v @@ -0,0 +1,19 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module External_TypesExternal. + +(** [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) +Axiom core_num_nonzero_NonZeroU32_t : Type. + +(** The state type used in the state-error monad *) +Axiom state : Type. + +End External_TypesExternal. diff --git a/tests/coq/misc/External_TypesExternal_Template.v b/tests/coq/misc/External_TypesExternal_Template.v new file mode 100644 index 00000000..7ba79d8e --- /dev/null +++ b/tests/coq/misc/External_TypesExternal_Template.v @@ -0,0 +1,19 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module External_TypesExternal_Template. + +(** [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) +Axiom core_num_nonzero_NonZeroU32_t : Type. + +(** The state type used in the state-error monad *) +Axiom state : Type. + +End External_TypesExternal_Template. diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index 4929ddd0..83c249c1 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -914,4 +914,4 @@ Definition list_nth_shared_mut_loop_pair_merge_back list_nth_shared_mut_loop_pair_merge_loop_back T n ls0 ls1 i ret . -End Loops . +End Loops. diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index b044d24f..16a2e816 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -586,4 +586,4 @@ Definition test_shared_borrow_enum1 (l : List_t u32) : result u32 := Definition test_shared_borrow_enum2 : result u32 := Return 0%u32. -End NoNestedBorrows . +End NoNestedBorrows. diff --git a/tests/coq/misc/Paper.v b/tests/coq/misc/Paper.v index 4a49096f..6b110193 100644 --- a/tests/coq/misc/Paper.v +++ b/tests/coq/misc/Paper.v @@ -128,4 +128,4 @@ Definition call_choose (p : (u32 * u32)) : result u32 := Return px0 . -End Paper . +End Paper. diff --git a/tests/coq/misc/PoloniusList.v b/tests/coq/misc/PoloniusList.v index a0820e40..2371b1cc 100644 --- a/tests/coq/misc/PoloniusList.v +++ b/tests/coq/misc/PoloniusList.v @@ -41,4 +41,4 @@ Fixpoint get_list_at_x_back end . -End PoloniusList . +End PoloniusList. diff --git a/tests/coq/misc/_CoqProject b/tests/coq/misc/_CoqProject index 6884d5d9..0828bced 100644 --- a/tests/coq/misc/_CoqProject +++ b/tests/coq/misc/_CoqProject @@ -4,12 +4,14 @@ -arg all Loops.v +External_Types.v Primitives.v External_Funs.v +Paper.v +External_TypesExternal.v Constants.v PoloniusList.v -External_Types.v NoNestedBorrows.v External_FunsExternal.v +External_TypesExternal_Template.v External_FunsExternal_Template.v -Paper.v diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index 50eaf848..ebdca4ec 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -611,4 +611,4 @@ Arguments CFn_t_call_mut { _ _ }. Definition incr_u32 (x : u32) : result u32 := u32_add x 1%u32. -End Traits . +End Traits. diff --git a/tests/fstar/betree/BetreeMain.Types.fst b/tests/fstar/betree/BetreeMain.Types.fst new file mode 100644 index 00000000..b87219b2 --- /dev/null +++ b/tests/fstar/betree/BetreeMain.Types.fst @@ -0,0 +1,61 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: type definitions *) +module BetreeMain.Types +open Primitives +include BetreeMain.TypesExternal + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [betree_main::betree::List] + Source: 'src/betree.rs', lines 17:0-17:23 *) +type betree_List_t (t : Type0) = +| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t +| Betree_List_Nil : betree_List_t t + +(** [betree_main::betree::UpsertFunState] + Source: 'src/betree.rs', lines 63:0-63:23 *) +type betree_UpsertFunState_t = +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t + +(** [betree_main::betree::Message] + Source: 'src/betree.rs', lines 69:0-69:23 *) +type betree_Message_t = +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t + +(** [betree_main::betree::Leaf] + Source: 'src/betree.rs', lines 167:0-167:11 *) +type betree_Leaf_t = { id : u64; size : u64; } + +(** [betree_main::betree::Internal] + Source: 'src/betree.rs', lines 156:0-156:15 *) +type betree_Internal_t = +{ + id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; +} + +(** [betree_main::betree::Node] + Source: 'src/betree.rs', lines 179:0-179:9 *) +and betree_Node_t = +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t + +(** [betree_main::betree::Params] + Source: 'src/betree.rs', lines 187:0-187:13 *) +type betree_Params_t = { min_flush_size : u64; split_size : u64; } + +(** [betree_main::betree::NodeIdCounter] + Source: 'src/betree.rs', lines 201:0-201:20 *) +type betree_NodeIdCounter_t = { next_node_id : u64; } + +(** [betree_main::betree::BeTree] + Source: 'src/betree.rs', lines 218:0-218:17 *) +type betree_BeTree_t = +{ + params : betree_Params_t; + node_id_cnt : betree_NodeIdCounter_t; + root : betree_Node_t; +} + diff --git a/tests/fstar/betree/BetreeMain.Types.fsti b/tests/fstar/betree/BetreeMain.Types.fsti deleted file mode 100644 index a098ec19..00000000 --- a/tests/fstar/betree/BetreeMain.Types.fsti +++ /dev/null @@ -1,63 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [betree_main]: type definitions *) -module BetreeMain.Types -open Primitives - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [betree_main::betree::List] - Source: 'src/betree.rs', lines 17:0-17:23 *) -type betree_List_t (t : Type0) = -| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t -| Betree_List_Nil : betree_List_t t - -(** [betree_main::betree::UpsertFunState] - Source: 'src/betree.rs', lines 63:0-63:23 *) -type betree_UpsertFunState_t = -| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t -| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t - -(** [betree_main::betree::Message] - Source: 'src/betree.rs', lines 69:0-69:23 *) -type betree_Message_t = -| Betree_Message_Insert : u64 -> betree_Message_t -| Betree_Message_Delete : betree_Message_t -| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t - -(** [betree_main::betree::Leaf] - Source: 'src/betree.rs', lines 167:0-167:11 *) -type betree_Leaf_t = { id : u64; size : u64; } - -(** [betree_main::betree::Internal] - Source: 'src/betree.rs', lines 156:0-156:15 *) -type betree_Internal_t = -{ - id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; -} - -(** [betree_main::betree::Node] - Source: 'src/betree.rs', lines 179:0-179:9 *) -and betree_Node_t = -| Betree_Node_Internal : betree_Internal_t -> betree_Node_t -| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t - -(** [betree_main::betree::Params] - Source: 'src/betree.rs', lines 187:0-187:13 *) -type betree_Params_t = { min_flush_size : u64; split_size : u64; } - -(** [betree_main::betree::NodeIdCounter] - Source: 'src/betree.rs', lines 201:0-201:20 *) -type betree_NodeIdCounter_t = { next_node_id : u64; } - -(** [betree_main::betree::BeTree] - Source: 'src/betree.rs', lines 218:0-218:17 *) -type betree_BeTree_t = -{ - params : betree_Params_t; - node_id_cnt : betree_NodeIdCounter_t; - root : betree_Node_t; -} - -(** The state type used in the state-error monad *) -val state : Type0 - diff --git a/tests/fstar/betree/BetreeMain.TypesExternal.fsti b/tests/fstar/betree/BetreeMain.TypesExternal.fsti new file mode 100644 index 00000000..1b2c53a6 --- /dev/null +++ b/tests/fstar/betree/BetreeMain.TypesExternal.fsti @@ -0,0 +1,10 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external type declarations *) +module BetreeMain.TypesExternal +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** The state type used in the state-error monad *) +val state : Type0 + diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Types.fst b/tests/fstar/betree_back_stateful/BetreeMain.Types.fst new file mode 100644 index 00000000..b87219b2 --- /dev/null +++ b/tests/fstar/betree_back_stateful/BetreeMain.Types.fst @@ -0,0 +1,61 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: type definitions *) +module BetreeMain.Types +open Primitives +include BetreeMain.TypesExternal + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [betree_main::betree::List] + Source: 'src/betree.rs', lines 17:0-17:23 *) +type betree_List_t (t : Type0) = +| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t +| Betree_List_Nil : betree_List_t t + +(** [betree_main::betree::UpsertFunState] + Source: 'src/betree.rs', lines 63:0-63:23 *) +type betree_UpsertFunState_t = +| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t +| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t + +(** [betree_main::betree::Message] + Source: 'src/betree.rs', lines 69:0-69:23 *) +type betree_Message_t = +| Betree_Message_Insert : u64 -> betree_Message_t +| Betree_Message_Delete : betree_Message_t +| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t + +(** [betree_main::betree::Leaf] + Source: 'src/betree.rs', lines 167:0-167:11 *) +type betree_Leaf_t = { id : u64; size : u64; } + +(** [betree_main::betree::Internal] + Source: 'src/betree.rs', lines 156:0-156:15 *) +type betree_Internal_t = +{ + id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; +} + +(** [betree_main::betree::Node] + Source: 'src/betree.rs', lines 179:0-179:9 *) +and betree_Node_t = +| Betree_Node_Internal : betree_Internal_t -> betree_Node_t +| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t + +(** [betree_main::betree::Params] + Source: 'src/betree.rs', lines 187:0-187:13 *) +type betree_Params_t = { min_flush_size : u64; split_size : u64; } + +(** [betree_main::betree::NodeIdCounter] + Source: 'src/betree.rs', lines 201:0-201:20 *) +type betree_NodeIdCounter_t = { next_node_id : u64; } + +(** [betree_main::betree::BeTree] + Source: 'src/betree.rs', lines 218:0-218:17 *) +type betree_BeTree_t = +{ + params : betree_Params_t; + node_id_cnt : betree_NodeIdCounter_t; + root : betree_Node_t; +} + diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti b/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti deleted file mode 100644 index a098ec19..00000000 --- a/tests/fstar/betree_back_stateful/BetreeMain.Types.fsti +++ /dev/null @@ -1,63 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [betree_main]: type definitions *) -module BetreeMain.Types -open Primitives - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [betree_main::betree::List] - Source: 'src/betree.rs', lines 17:0-17:23 *) -type betree_List_t (t : Type0) = -| Betree_List_Cons : t -> betree_List_t t -> betree_List_t t -| Betree_List_Nil : betree_List_t t - -(** [betree_main::betree::UpsertFunState] - Source: 'src/betree.rs', lines 63:0-63:23 *) -type betree_UpsertFunState_t = -| Betree_UpsertFunState_Add : u64 -> betree_UpsertFunState_t -| Betree_UpsertFunState_Sub : u64 -> betree_UpsertFunState_t - -(** [betree_main::betree::Message] - Source: 'src/betree.rs', lines 69:0-69:23 *) -type betree_Message_t = -| Betree_Message_Insert : u64 -> betree_Message_t -| Betree_Message_Delete : betree_Message_t -| Betree_Message_Upsert : betree_UpsertFunState_t -> betree_Message_t - -(** [betree_main::betree::Leaf] - Source: 'src/betree.rs', lines 167:0-167:11 *) -type betree_Leaf_t = { id : u64; size : u64; } - -(** [betree_main::betree::Internal] - Source: 'src/betree.rs', lines 156:0-156:15 *) -type betree_Internal_t = -{ - id : u64; pivot : u64; left : betree_Node_t; right : betree_Node_t; -} - -(** [betree_main::betree::Node] - Source: 'src/betree.rs', lines 179:0-179:9 *) -and betree_Node_t = -| Betree_Node_Internal : betree_Internal_t -> betree_Node_t -| Betree_Node_Leaf : betree_Leaf_t -> betree_Node_t - -(** [betree_main::betree::Params] - Source: 'src/betree.rs', lines 187:0-187:13 *) -type betree_Params_t = { min_flush_size : u64; split_size : u64; } - -(** [betree_main::betree::NodeIdCounter] - Source: 'src/betree.rs', lines 201:0-201:20 *) -type betree_NodeIdCounter_t = { next_node_id : u64; } - -(** [betree_main::betree::BeTree] - Source: 'src/betree.rs', lines 218:0-218:17 *) -type betree_BeTree_t = -{ - params : betree_Params_t; - node_id_cnt : betree_NodeIdCounter_t; - root : betree_Node_t; -} - -(** The state type used in the state-error monad *) -val state : Type0 - diff --git a/tests/fstar/betree_back_stateful/BetreeMain.TypesExternal.fsti b/tests/fstar/betree_back_stateful/BetreeMain.TypesExternal.fsti new file mode 100644 index 00000000..1b2c53a6 --- /dev/null +++ b/tests/fstar/betree_back_stateful/BetreeMain.TypesExternal.fsti @@ -0,0 +1,10 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [betree_main]: external type declarations *) +module BetreeMain.TypesExternal +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** The state type used in the state-error monad *) +val state : Type0 + diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fst new file mode 100644 index 00000000..afebcde3 --- /dev/null +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fst @@ -0,0 +1,24 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: type definitions *) +module HashmapMain.Types +open Primitives +include HashmapMain.TypesExternal + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [hashmap_main::hashmap::List] + Source: 'src/hashmap.rs', lines 19:0-19:16 *) +type hashmap_List_t (t : Type0) = +| Hashmap_List_Cons : usize -> t -> hashmap_List_t t -> hashmap_List_t t +| Hashmap_List_Nil : hashmap_List_t t + +(** [hashmap_main::hashmap::HashMap] + Source: 'src/hashmap.rs', lines 35:0-35:21 *) +type hashmap_HashMap_t (t : Type0) = +{ + num_entries : usize; + max_load_factor : (usize & usize); + max_load : usize; + slots : alloc_vec_Vec (hashmap_List_t t); +} + diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti deleted file mode 100644 index e77954ad..00000000 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Types.fsti +++ /dev/null @@ -1,26 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [hashmap_main]: type definitions *) -module HashmapMain.Types -open Primitives - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [hashmap_main::hashmap::List] - Source: 'src/hashmap.rs', lines 19:0-19:16 *) -type hashmap_List_t (t : Type0) = -| Hashmap_List_Cons : usize -> t -> hashmap_List_t t -> hashmap_List_t t -| Hashmap_List_Nil : hashmap_List_t t - -(** [hashmap_main::hashmap::HashMap] - Source: 'src/hashmap.rs', lines 35:0-35:21 *) -type hashmap_HashMap_t (t : Type0) = -{ - num_entries : usize; - max_load_factor : (usize & usize); - max_load : usize; - slots : alloc_vec_Vec (hashmap_List_t t); -} - -(** The state type used in the state-error monad *) -val state : Type0 - diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.TypesExternal.fsti b/tests/fstar/hashmap_on_disk/HashmapMain.TypesExternal.fsti new file mode 100644 index 00000000..75747408 --- /dev/null +++ b/tests/fstar/hashmap_on_disk/HashmapMain.TypesExternal.fsti @@ -0,0 +1,10 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [hashmap_main]: external type declarations *) +module HashmapMain.TypesExternal +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** The state type used in the state-error monad *) +val state : Type0 + diff --git a/tests/fstar/misc/External.Types.fst b/tests/fstar/misc/External.Types.fst new file mode 100644 index 00000000..4fbcec47 --- /dev/null +++ b/tests/fstar/misc/External.Types.fst @@ -0,0 +1,8 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: type definitions *) +module External.Types +open Primitives +include External.TypesExternal + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + diff --git a/tests/fstar/misc/External.Types.fsti b/tests/fstar/misc/External.Types.fsti deleted file mode 100644 index 0cb9fd0e..00000000 --- a/tests/fstar/misc/External.Types.fsti +++ /dev/null @@ -1,14 +0,0 @@ -(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) -(** [external]: type definitions *) -module External.Types -open Primitives - -#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" - -(** [core::num::nonzero::NonZeroU32] - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) -val core_num_nonzero_NonZeroU32_t : Type0 - -(** The state type used in the state-error monad *) -val state : Type0 - diff --git a/tests/fstar/misc/External.TypesExternal.fsti b/tests/fstar/misc/External.TypesExternal.fsti new file mode 100644 index 00000000..4bfbe0c5 --- /dev/null +++ b/tests/fstar/misc/External.TypesExternal.fsti @@ -0,0 +1,14 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [external]: external type declarations *) +module External.TypesExternal +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 *) +val core_num_nonzero_NonZeroU32_t : Type0 + +(** The state type used in the state-error monad *) +val state : Type0 + diff --git a/tests/lean/BetreeMain/Types.lean b/tests/lean/BetreeMain/Types.lean index 6e528437..877508f6 100644 --- a/tests/lean/BetreeMain/Types.lean +++ b/tests/lean/BetreeMain/Types.lean @@ -1,6 +1,7 @@ -- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS -- [betree_main]: type definitions import Base +import BetreeMain.TypesExternal open Primitives namespace betree_main @@ -63,7 +64,4 @@ structure betree.BeTree where node_id_cnt : betree.NodeIdCounter root : betree.Node -/- The state type used in the state-error monad -/ -axiom State : Type - end betree_main diff --git a/tests/lean/BetreeMain/TypesExternal.lean b/tests/lean/BetreeMain/TypesExternal.lean new file mode 100644 index 00000000..1701eaaf --- /dev/null +++ b/tests/lean/BetreeMain/TypesExternal.lean @@ -0,0 +1,7 @@ +-- [betree_main]: external types. +import Base +open Primitives + +/- The state type used in the state-error monad -/ +axiom State : Type + diff --git a/tests/lean/BetreeMain/TypesExternal_Template.lean b/tests/lean/BetreeMain/TypesExternal_Template.lean new file mode 100644 index 00000000..bbac7e99 --- /dev/null +++ b/tests/lean/BetreeMain/TypesExternal_Template.lean @@ -0,0 +1,9 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [betree_main]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. +import Base +open Primitives + +/- The state type used in the state-error monad -/ +axiom State : Type + diff --git a/tests/lean/External/Types.lean b/tests/lean/External/Types.lean index 40f20cda..961f3e8a 100644 --- a/tests/lean/External/Types.lean +++ b/tests/lean/External/Types.lean @@ -1,15 +1,9 @@ -- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS -- [external]: type definitions import Base +import External.TypesExternal open Primitives namespace external -/- [core::num::nonzero::NonZeroU32] - Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 -/ -axiom core.num.nonzero.NonZeroU32 : Type - -/- The state type used in the state-error monad -/ -axiom State : Type - end external diff --git a/tests/lean/External/TypesExternal.lean b/tests/lean/External/TypesExternal.lean new file mode 100644 index 00000000..7c30f792 --- /dev/null +++ b/tests/lean/External/TypesExternal.lean @@ -0,0 +1,11 @@ +-- [external]: external types. +import Base +open Primitives + +/- [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 -/ +axiom core.num.nonzero.NonZeroU32 : Type + +/- The state type used in the state-error monad -/ +axiom State : Type + diff --git a/tests/lean/External/TypesExternal_Template.lean b/tests/lean/External/TypesExternal_Template.lean new file mode 100644 index 00000000..85fef236 --- /dev/null +++ b/tests/lean/External/TypesExternal_Template.lean @@ -0,0 +1,13 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [external]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. +import Base +open Primitives + +/- [core::num::nonzero::NonZeroU32] + Source: '/rustc/d59363ad0b6391b7fc5bbb02c9ccf9300eef3753/library/core/src/num/nonzero.rs', lines 50:12-50:33 -/ +axiom core.num.nonzero.NonZeroU32 : Type + +/- The state type used in the state-error monad -/ +axiom State : Type + diff --git a/tests/lean/HashmapMain/Types.lean b/tests/lean/HashmapMain/Types.lean index f7be6719..ae9ac999 100644 --- a/tests/lean/HashmapMain/Types.lean +++ b/tests/lean/HashmapMain/Types.lean @@ -1,6 +1,7 @@ -- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS -- [hashmap_main]: type definitions import Base +import HashmapMain.TypesExternal open Primitives namespace hashmap_main @@ -19,7 +20,4 @@ structure hashmap.HashMap (T : Type) where max_load : Usize slots : alloc.vec.Vec (hashmap.List T) -/- The state type used in the state-error monad -/ -axiom State : Type - end hashmap_main diff --git a/tests/lean/HashmapMain/TypesExternal.lean b/tests/lean/HashmapMain/TypesExternal.lean new file mode 100644 index 00000000..4e1cdbe9 --- /dev/null +++ b/tests/lean/HashmapMain/TypesExternal.lean @@ -0,0 +1,7 @@ +-- [hashmap_main]: external types. +import Base +open Primitives + +/- The state type used in the state-error monad -/ +axiom State : Type + diff --git a/tests/lean/HashmapMain/TypesExternal_Template.lean b/tests/lean/HashmapMain/TypesExternal_Template.lean new file mode 100644 index 00000000..cfa8bbb1 --- /dev/null +++ b/tests/lean/HashmapMain/TypesExternal_Template.lean @@ -0,0 +1,9 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [hashmap_main]: external types. +-- This is a template file: rename it to "TypesExternal.lean" and fill the holes. +import Base +open Primitives + +/- The state type used in the state-error monad -/ +axiom State : Type + -- cgit v1.2.3 From fdb8555cf6bc21ea230141373920196b078bdd28 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 13:48:46 +0100 Subject: Do not activate the sanity (invariant) checks by default --- Makefile | 7 ++----- compiler/Config.ml | 8 ++++---- compiler/InterpreterBorrows.ml | 4 ++-- compiler/InterpreterLoopsJoinCtxs.ml | 2 +- compiler/InterpreterLoopsMatchCtxs.ml | 2 +- compiler/InterpreterPaths.ml | 2 +- compiler/Invariants.ml | 2 +- compiler/Main.ml | 8 ++++---- 8 files changed, 16 insertions(+), 19 deletions(-) diff --git a/Makefile b/Makefile index e0367d73..88cb7d05 100644 --- a/Makefile +++ b/Makefile @@ -30,11 +30,8 @@ CHARON_TESTS_POLONIUS_DIR ?= $(CHARON_HOME)/tests-polonius AENEAS_EXE ?= bin/aeneas # The user can specify additional translation options for Aeneas. -# By default we do: -# - unfold all the monadic let bindings to matches (required by F*) -# - insert calls to the normalizer in the translated code to test the -# generated unit functions -OPTIONS += +# By default we activate the (expensive) sanity checks. +OPTIONS ?= -checks # # The rules use (and update) the following variables diff --git a/compiler/Config.ml b/compiler/Config.ml index fe110ee4..48ee0a06 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -35,11 +35,11 @@ let backend = ref FStar (** {1 Interpreter} *) -(** Check that invariants are maintained whenever we execute a statement - - TODO: rename to sanity_checks. +(** Activate the sanity checks, and in particular the invariant checks + that are performed at every evaluation step. This is very expensive + (~100x slow down) but very efficient to catch mistakes early. *) -let check_invariants = ref true +let sanity_checks = ref false (** Expand all symbolic values containing borrows upon introduction - allows to use restrict ourselves to a simpler model for the projectors over diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 8c9c0e72..2f793f4a 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2155,7 +2155,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) ^ "\n\n- abs1:\n" ^ abs_to_string ctx abs1)); (* Check that the abstractions are destructured *) - if !Config.check_invariants then ( + if !Config.sanity_checks then ( let destructure_shared_values = true in assert (abs_is_destructured destructure_shared_values ctx abs0); assert (abs_is_destructured destructure_shared_values ctx abs1)); @@ -2487,7 +2487,7 @@ let merge_into_abstraction_aux (abs_kind : abs_kind) (can_end : bool) in (* Sanity check *) - if !Config.check_invariants then assert (abs_is_destructured true ctx abs); + if !Config.sanity_checks then assert (abs_is_destructured true ctx abs); (* Return *) abs diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 4cc74aae..8d485483 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -714,7 +714,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (loop_id : LoopId.id) ^ eval_ctx_to_string !joined_ctx)); (* Sanity check *) - if !Config.check_invariants then Invariants.check_invariants !joined_ctx; + if !Config.sanity_checks then Invariants.check_invariants !joined_ctx; (* Return *) ctx1 in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 74f9ba2c..bf459e41 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -1580,7 +1580,7 @@ let match_ctx_with_target (config : config) (loop_id : LoopId.id) ^ eval_ctx_to_string tgt_ctx)); (* Sanity check *) - if !Config.check_invariants then + if !Config.sanity_checks then Invariants.check_borrowed_values_invariant tgt_ctx; (* End all the borrows which appear in the *new* abstractions *) diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index 729a3577..999b8ab0 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -311,7 +311,7 @@ let try_read_place (access : access_kind) (p : place) (ctx : eval_ctx) : (* Note that we ignore the new environment: it should be the same as the original one. *) - if !Config.check_invariants then + if !Config.sanity_checks then if ctx1 <> ctx then ( let msg = "Unexpected environment update:\nNew environment:\n" diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index e0e3f354..fa0d7436 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -804,7 +804,7 @@ let check_symbolic_values (ctx : eval_ctx) : unit = M.iter check_info !infos let check_invariants (ctx : eval_ctx) : unit = - if !Config.check_invariants then ( + if !Config.sanity_checks then ( log#ldebug (lazy ("Checking invariants:\n" ^ eval_ctx_to_string ctx)); check_loans_borrows_relation_invariant ctx; check_borrowed_values_invariant ctx; diff --git a/compiler/Main.ml b/compiler/Main.ml index e350da8a..7f98f581 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -107,10 +107,10 @@ let () = 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 \ - step. Dramatically increases speed." ); + ( "-checks", + Arg.Set sanity_checks, + " Activate extensive sanity checks (warning: causes a ~100 times slow \ + down)." ); ( "-no-gen-lib-entry", Arg.Clear generate_lib_entry_point, " Do not generate the entry point file for the generated library (only \ -- cgit v1.2.3 From a17eef1053909117d75c9ea8eeaad786626cc05d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 14:15:01 +0100 Subject: Update the way the Primitives file is copied --- compiler/Translate.ml | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/compiler/Translate.ml b/compiler/Translate.ml index cc84b9fb..37f58140 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -1206,20 +1206,27 @@ let translate_crate (filename : string) (dest_dir : string) (crate : crate) : match primitives_src_dest with | None -> () | Some (primitives_src, primitives_destname) -> ( - let src = open_in (exe_dir ^ primitives_src) in - let tgt_filename = Filename.concat dest_dir primitives_destname in - let tgt = open_out tgt_filename in - (* Very annoying: I couldn't find a "cp" function in the OCaml libraries... *) try - while true do - (* We copy line by line *) - let line = input_line src in - Printf.fprintf tgt "%s\n" line - done - with End_of_file -> - close_in src; - close_out tgt; - log#linfo (lazy ("Copied: " ^ tgt_filename))) + (* TODO: stop copying the primitives file *) + let src = open_in (exe_dir ^ primitives_src) in + let tgt_filename = Filename.concat dest_dir primitives_destname in + let tgt = open_out tgt_filename in + (* Very annoying: I couldn't find a "cp" function in the OCaml libraries... *) + try + while true do + (* We copy line by line *) + let line = input_line src in + Printf.fprintf tgt "%s\n" line + done + with End_of_file -> + close_in src; + close_out tgt; + log#linfo (lazy ("Copied: " ^ tgt_filename)) + with Sys_error _ -> + log#error + "Could not copy the primitives file: %s.\n\ + You will have to copy it/set up the project by hand." + primitives_src) in (* Extract the file(s) *) -- cgit v1.2.3 From 8a6c26355ef82de725ed643f4a3c40ed54d1b4c7 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 14:19:12 +0100 Subject: Update a comment --- compiler/Config.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/Config.ml b/compiler/Config.ml index 48ee0a06..1a00656d 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -52,7 +52,8 @@ let greedy_expand_symbolics_with_borrows = true (** Experimental. - TODO: remove (always true now) + TODO: remove (always true now), but check that when we panic/call a function + there is no bottom below a borrow. We sometimes want to temporarily break the invariant that there is no bottom value below a borrow. If this value is true, we don't check -- cgit v1.2.3 From 6f8f1213e056804eda4c521922cdf45f4e92a509 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 15:57:55 +0100 Subject: Fix the issues with the cross-references for OCaml doc --- compiler/Config.ml | 2 +- compiler/Contexts.ml | 8 ++++---- compiler/ExtractBase.ml | 6 +++--- compiler/ExtractTypes.ml | 2 +- compiler/InterpreterBorrowsCore.ml | 12 ++++++------ compiler/InterpreterExpansion.mli | 2 +- compiler/InterpreterLoopsCore.ml | 8 ++++---- compiler/InterpreterLoopsMatchCtxs.mli | 6 +++--- compiler/InterpreterProjectors.mli | 2 +- compiler/InterpreterStatements.mli | 2 +- compiler/InterpreterUtils.ml | 4 ++-- compiler/Pure.ml | 4 ++-- compiler/PureUtils.ml | 2 +- compiler/Substitute.ml | 2 +- compiler/SymbolicAst.ml | 4 ++-- compiler/TypesUtils.ml | 4 ++-- 16 files changed, 35 insertions(+), 35 deletions(-) diff --git a/compiler/Config.ml b/compiler/Config.ml index 1a00656d..364ef748 100644 --- a/compiler/Config.ml +++ b/compiler/Config.ml @@ -289,7 +289,7 @@ let unfold_monadic_let_bindings = ref false we later filter the useless *forward* calls in the micro-passes, where it is more natural to do. - See the comments for {!val:PureMicroPasses.expression_contains_child_call_in_all_paths} + See the comments for {!PureMicroPasses.expression_contains_child_call_in_all_paths} for additional explanations. *) let filter_useless_monadic_calls = ref true diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index a2ae4f16..c93bb213 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -112,7 +112,7 @@ let reset_global_counters () = fun_call_id_counter := FunCallId.generator_zero; dummy_var_id_counter := DummyVarId.generator_zero -(** Ancestor for {!env} iter visitor *) +(** Ancestor for {!type:env} iter visitor *) class ['self] iter_env_base = object (_self : 'self) inherit [_] iter_abs @@ -120,7 +120,7 @@ class ['self] iter_env_base = method visit_dummy_var_id : 'env -> dummy_var_id -> unit = fun _ _ -> () end -(** Ancestor for {!env} map visitor *) +(** Ancestor for {!type:env} map visitor *) class ['self] map_env_base = object (_self : 'self) inherit [_] map_abs @@ -423,11 +423,11 @@ let erase_regions (ty : ty) : ty = in v#visit_ty () ty -(** Push an uninitialized variable (which thus maps to {!constructor:Values.value.Bottom}) *) +(** Push an uninitialized variable (which thus maps to {!constructor:Values.value.VBottom}) *) let ctx_push_uninitialized_var (ctx : eval_ctx) (var : var) : eval_ctx = ctx_push_var ctx var (mk_bottom (erase_regions var.var_ty)) -(** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.Bottom}) *) +(** Push a list of uninitialized variables (which thus map to {!constructor:Values.value.VBottom}) *) let ctx_push_uninitialized_vars (ctx : eval_ctx) (vars : var list) : eval_ctx = let vars = List.map (fun v -> (v, mk_bottom (erase_regions v.var_ty))) vars in ctx_push_vars ctx vars diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 1ca68120..85ab1112 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -311,7 +311,7 @@ let names_map_add (id_to_string : id -> string) (id : id) (name : string) the same name because Lean uses the typing information to resolve the ambiguities. - This map complements the {!names_map}, which checks for collisions. + This map complements the {!type:names_map}, which checks for collisions. *) type unsafe_names_map = { id_to_name : string IdMap.t } @@ -1639,7 +1639,7 @@ let ctx_compute_trait_type_clause_name (ctx : extraction_ctx) function is an assumed function or a local function - function basename - the number of loops in the parent function. This is used for - the same purpose as in {!field:llbc_name}. + the same purpose as in [llbc_name]. - loop identifier, if this is for a loop *) let ctx_compute_termination_measure_name (ctx : extraction_ctx) @@ -1668,7 +1668,7 @@ let ctx_compute_termination_measure_name (ctx : extraction_ctx) function is an assumed function or a local function - function basename - the number of loops in the parent function. This is used for - the same purpose as in {!field:llbc_name}. + the same purpose as in [llbc_name]. - loop identifier, if this is for a loop *) let ctx_compute_decreases_proof_name (ctx : extraction_ctx) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index c6212d31..ca9984be 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -213,7 +213,7 @@ let is_empty_record_type_decl_group (dg : Pure.type_decl list) : bool = - 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 + Calls to {!Extract.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 diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index b13d545c..44f85d0a 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -924,7 +924,7 @@ let remove_intersecting_aproj_borrows_shared (regions : RegionId.Set.t) [subst]: takes as parameters the abstraction in which we perform the substitution and the list of given back values at the projector of - loans where we perform the substitution (see the fields in {!AProjLoans}). + loans where we perform the substitution (see the fields in {!Values.AProjLoans}). Note that the symbolic value at this place is necessarily equal to [sv], which is why we don't give it as parameters. *) @@ -970,13 +970,13 @@ let update_intersecting_aproj_loans (proj_regions : RegionId.Set.t) (* Return *) ctx -(** Helper function: lookup an {!AProjLoans} by using an abstraction id and a +(** Helper function: lookup an {!constructor:Values.aproj.AProjLoans} by using an abstraction id and a symbolic value. - + We return the information from the looked up projector of loans. See the - fields in {!AProjLoans} (we don't return the symbolic value, because it + fields in {!constructor:Values.aproj.AProjLoans} (we don't return the symbolic value, because it is equal to [sv]). - + Sanity check: we check that there is exactly one projector which corresponds to the couple (abstraction id, symbolic value). *) @@ -1115,7 +1115,7 @@ let update_aproj_borrows (abs_id : AbstractionId.id) (sv : symbolic_value) (** Helper function: might break invariants. - Converts an {!AProjLoans} to an {!AEndedProjLoans}. The projector is identified + Converts an {!Values.aproj.AProjLoans} to an {!Values.aproj.AEndedProjLoans}. The projector is identified by a symbolic value and an abstraction id. *) let update_aproj_loans_to_ended (abs_id : AbstractionId.id) diff --git a/compiler/InterpreterExpansion.mli b/compiler/InterpreterExpansion.mli index 4be1fd24..b545f979 100644 --- a/compiler/InterpreterExpansion.mli +++ b/compiler/InterpreterExpansion.mli @@ -79,6 +79,6 @@ val expand_symbolic_int : m_fun (** If this mode is activated through the [config], greedily expand the symbolic - values which need to be expanded. See {!type:config} for more information. + values which need to be expanded. See {!type:Contexts.config} for more information. *) val greedy_expand_symbolic_values : config -> cm_fun diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index d14230c6..ca1f8f31 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -41,10 +41,10 @@ type abs_borrows_loans_maps = { borrow_loan_to_abs : AbstractionId.Set.t BorrowId.Map.t; } -(** See {!InterpreterLoopsMatchCtxs.MakeMatcher} and {!InterpreterLoopsCore.Matcher}. +(** See {!module:Aeneas.InterpreterLoopsMatchCtxs.MakeMatcher} and [Matcher]. This module contains primitive match functions to instantiate the generic - {!InterpreterLoopsMatchCtxs.MakeMatcher} functor. + {!module:Aeneas.InterpreterLoopsMatchCtxs.MakeMatcher} functor. *) module type PrimMatcher = sig val match_etys : ety -> ety -> ety @@ -231,8 +231,8 @@ module type Matcher = sig eval_ctx -> typed_avalue -> typed_avalue -> typed_avalue end -(** See {!InterpreterLoopsMatchCtxs.MakeCheckEquivMatcher} and - {!InterpreterLoopsCore.CheckEquivMatcher}. +(** See {!module:InterpreterLoopsMatchCtxs.MakeCheckEquivMatcher} and + {!module-type:InterpreterLoopsCore.CheckEquivMatcher}. Very annoying: functors only take modules as inputs... *) diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index bf29af79..5f69b8d3 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -27,13 +27,13 @@ val compute_abs_borrows_loans_maps : We use it for joins, to check if two environments are convertible, etc. See for instance {!MakeJoinMatcher} and {!MakeCheckEquivMatcher}. - The functor is parameterized by a {!PrimMatcher}, which implements the - non-generic part of the match. More precisely, the role of {!PrimMatcher} is two + The functor is parameterized by a {!module-type:InterpreterLoopsCore.PrimMatcher}, which implements the + non-generic part of the match. More precisely, the role of {!module-type:InterpreterLoopsCore.PrimMatcher} is two provide generic functions which recursively match two values (by recursively matching the fields of ADT values for instance). When it does need to match values in a non-trivial manner (if two ADT values don't have the same variant for instance) it calls the corresponding specialized function from - {!PrimMatcher}. + {!module-type:InterpreterLoopsCore.PrimMatcher}. *) module MakeMatcher : functor (_ : PrimMatcher) -> Matcher diff --git a/compiler/InterpreterProjectors.mli b/compiler/InterpreterProjectors.mli index 583c6907..9e4ebc20 100644 --- a/compiler/InterpreterProjectors.mli +++ b/compiler/InterpreterProjectors.mli @@ -6,7 +6,7 @@ open Contexts Apply a proj_borrows on a shared borrow. Note that when projecting over shared values, we generate - {!type:abstract_shared_borrows}, not {!type:avalue}s. + {!type:Aeneas.Values.abstract_shared_borrows}, not {!type:Aeneas.Values.avalue}s. Parameters: [regions] diff --git a/compiler/InterpreterStatements.mli b/compiler/InterpreterStatements.mli index d84e8be6..3832d02f 100644 --- a/compiler/InterpreterStatements.mli +++ b/compiler/InterpreterStatements.mli @@ -10,7 +10,7 @@ open Cps dummy variables, after ending the proper borrows of course) but the return variable, move the return value out of the return variable, remove all the local variables (but preserve the abstractions!), remove the - {!constructor:env_elem.Frame} indicator delimiting the current frame and + {!constructor:Contexts.env_elem.EFrame} indicator delimiting the current frame and handle the return value to the continuation. If the boolean is false, we don't move the return value, and call the diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index ecd8f53f..bba88e9f 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -111,7 +111,7 @@ let mk_typed_value_from_symbolic_value (svalue : symbolic_value) : typed_value = (** Create a loans projector value from a symbolic value. Checks if the projector will actually project some regions. If not, - returns {!AIgnored} ([_]). + returns {!Values.AIgnored} ([_]). TODO: update to handle 'static *) @@ -238,7 +238,7 @@ let symbolic_value_has_ended_regions (ended_regions : RegionId.Set.t) let regions = ty_regions s.sv_ty in not (RegionId.Set.disjoint regions ended_regions) -(** Check if a {!type:value} contains [⊥]. +(** Check if a {!type:Values.value} contains [⊥]. Note that this function is very general: it also checks wether symbolic values contain already ended regions. diff --git a/compiler/Pure.ml b/compiler/Pure.ml index 50849df9..0ae83007 100644 --- a/compiler/Pure.ml +++ b/compiler/Pure.ml @@ -273,7 +273,7 @@ class virtual ['self] mapreduce_ty_base = type ty = | TAdt of type_id * generic_args - (** {!Adt} encodes ADTs and tuples and assumed types. + (** {!TAdt} encodes ADTs and tuples and assumed types. TODO: what about the ended regions? (ADTs may be parameterized with several region variables. When giving back an ADT value, we may @@ -1064,7 +1064,7 @@ type trait_impl = { meta : meta; impl_trait : trait_decl_ref; llbc_impl_trait : Types.trait_decl_ref; - (** Same remark as for {llbc_generics}. *) + (** Same remark as for {!field:llbc_generics}. *) generics : generic_params; llbc_generics : Types.generic_params; (** We use the LLBC generics to generate "pretty" names, for instance diff --git a/compiler/PureUtils.ml b/compiler/PureUtils.ml index 6b0deb73..a5143f3c 100644 --- a/compiler/PureUtils.ml +++ b/compiler/PureUtils.ml @@ -195,7 +195,7 @@ let fun_sig_substitute (subst : subst) (sg : fun_sig) : inst_fun_sig = We only look for outer monadic let-bindings. This is used when printing the branches of [if ... then ... else ...]. - Rem.: this function will *fail* if there are {!constructor:Aeneas.Pure.expression.Loop} + Rem.: this function will *fail* if there are {!Pure.Loop} nodes (you should call it on an expression where those nodes have been eliminated). *) let rec let_group_requires_parentheses (e : texpression) : bool = diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 73e7f71d..a05b2c5a 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -76,7 +76,7 @@ let erase_regions_subst : subst = tr_self = Self; } -(** Convert an {!rty} to an {!ety} by erasing the region variables *) +(** Erase the region variables in a type *) let erase_regions (ty : ty) : ty = ty_substitute erase_regions_subst ty let trait_ref_erase_regions (tr : trait_ref) : trait_ref = diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index a9f45926..53f99b7f 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -66,8 +66,8 @@ type 'a region_group_id_map = 'a RegionGroupId.Map.t [@@deriving show] (** Ancestor for {!expression} iter visitor. - We could make it inherit the visitor for {!eval_ctx}, but in all the uses - of this visitor we don't need to explore {!eval_ctx}, so we make it inherit + We could make it inherit the visitor for {!Contexts.eval_ctx}, but in all the uses + of this visitor we don't need to explore {!Contexts.eval_ctx}, so we make it inherit the abstraction visitors instead. *) class ['self] iter_expression_base = diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml index 52e12b9a..76cc710a 100644 --- a/compiler/TypesUtils.ml +++ b/compiler/TypesUtils.ml @@ -5,7 +5,7 @@ include Charon.TypesUtils (** Retuns true if the type contains borrows. Note that we can't simply explore the type and look for regions: sometimes - we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, + we erase the lists of regions (by replacing them with [[]] when using {!type:Types.ty}, and when a type uses 'static this region doesn't appear in the region parameters. *) let ty_has_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = @@ -15,7 +15,7 @@ let ty_has_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = (** Retuns true if the type contains nested borrows. Note that we can't simply explore the type and look for regions: sometimes - we erase the lists of regions (by replacing them with [[]] when using {!Types.ety}, + we erase the lists of regions (by replacing them with [[]] when using {!type:Types.ty}, and when a type uses 'static this region doesn't appear in the region parameters. *) let ty_has_nested_borrows (infos : TypesAnalysis.type_infos) (ty : ty) : bool = -- cgit v1.2.3 From a3a3ab9723348e24f83073a52145128f34022265 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 27 Nov 2023 16:17:11 +0100 Subject: Update the flake.lock --- flake.lock | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/flake.lock b/flake.lock index 3457101c..8a34cfcb 100644 --- a/flake.lock +++ b/flake.lock @@ -8,11 +8,11 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1700661241, - "narHash": "sha256-vsMlaH7A5S7+uQGIYtu7Zt81s177X/xWbj2wdu54mtI=", + "lastModified": 1701097924, + "narHash": "sha256-fIXlINGdx8228emfCSkbqLN7f6mrLvoJc4gmqcyACU0=", "owner": "aeneasverif", "repo": "charon", - "rev": "a3b93d7b6546f1501d5376f7c8bdc0d95d289eb6", + "rev": "a635cdc69aa3c17e06ebc42e0694b0fcb7fa0fbb", "type": "github" }, "original": { @@ -131,11 +131,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1700586754, - "narHash": "sha256-SfzRprm7aIqT4RYaOt5k/I0tCJwoCbdjRzr//2omX60=", + "lastModified": 1700646441, + "narHash": "sha256-yZe9nDY+0nAWATQLorXSJB7yZ6yNyIlz9mT/qxHgNac=", "owner": "fstarlang", "repo": "fstar", - "rev": "71f2d632e318996f227063bf9d31ee91a4f48dfe", + "rev": "fe6dec16fc4f0234663da63de26d9d2e72fe14df", "type": "github" }, "original": { @@ -164,11 +164,11 @@ ] }, "locked": { - "lastModified": 1700602420, - "narHash": "sha256-RqTzTPk4c3hs9Z4IODcw/73L77Mo2tIPWw2KQzLv/O4=", + "lastModified": 1700661621, + "narHash": "sha256-XON6e4x5QRviofMGRyEwd+5PTVWAp/LdFFveC0LQhkY=", "owner": "hacl-star", "repo": "hacl-star", - "rev": "a5604d1b255e54cd32a104616c4b01808d46d809", + "rev": "95112e8dcb1ea3fe7d254290f8864b8f8e2fb6b2", "type": "github" }, "original": { @@ -194,11 +194,11 @@ ] }, "locked": { - "lastModified": 1700615900, - "narHash": "sha256-dnhIrg55enqH2KteebnDoRRi4CRXX3y8UNorGzf1ofE=", + "lastModified": 1700702143, + "narHash": "sha256-BadYV0m36o3T0I7gB8rp7vos2HL6N+9I23+HAZdoZFM=", "owner": "hacl-star", "repo": "hacl-nix", - "rev": "7363c6f54bf89ccd5c968f4766c6ea19079b2661", + "rev": "84b572dc55ec16eb8403ada9934987fd7ff44f76", "type": "github" }, "original": { @@ -265,11 +265,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1700650599, - "narHash": "sha256-AK9AO8COmeBpBFmhM9YLrAz/S7XknokCdXLIDC7tfQc=", + "lastModified": 1701086558, + "narHash": "sha256-Y5d0Ba09Bs8J6rxfH9gTEWEZ/pqDfIPwg73VYWpxIs8=", "owner": "leanprover", "repo": "lean4", - "rev": "9efdde23e0858f0925f0d3b4a6df842670b626c9", + "rev": "9769ad65723866093b35cd2c8875cc45e65d477a", "type": "github" }, "original": { @@ -318,11 +318,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1700650599, - "narHash": "sha256-AK9AO8COmeBpBFmhM9YLrAz/S7XknokCdXLIDC7tfQc=", + "lastModified": 1701086558, + "narHash": "sha256-Y5d0Ba09Bs8J6rxfH9gTEWEZ/pqDfIPwg73VYWpxIs8=", "owner": "leanprover", "repo": "lean4", - "rev": "9efdde23e0858f0925f0d3b4a6df842670b626c9", + "rev": "9769ad65723866093b35cd2c8875cc45e65d477a", "type": "github" }, "original": { -- cgit v1.2.3 From 59cb4312df866ec00a1fddec62a1e660b358052d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 11:46:35 +0100 Subject: Regenerate the test files --- tests/coq/traits/Traits.v | 5 ----- tests/fstar/traits/Traits.fst | 5 ----- tests/lean/Traits.lean | 5 ----- 3 files changed, 15 deletions(-) diff --git a/tests/coq/traits/Traits.v b/tests/coq/traits/Traits.v index ebdca4ec..549a7116 100644 --- a/tests/coq/traits/Traits.v +++ b/tests/coq/traits/Traits.v @@ -606,9 +606,4 @@ Arguments mkCFn_t { _ _ }. Arguments CFn_tCFn_t_CFnMutSelfArgsInst { _ _ }. Arguments CFn_t_call_mut { _ _ }. -(** [traits::incr_u32]: forward function - Source: 'src/traits.rs', lines 300:0-300:30 *) -Definition incr_u32 (x : u32) : result u32 := - u32_add x 1%u32. - End Traits. diff --git a/tests/fstar/traits/Traits.fst b/tests/fstar/traits/Traits.fst index 895a1cac..8252aad4 100644 --- a/tests/fstar/traits/Traits.fst +++ b/tests/fstar/traits/Traits.fst @@ -454,8 +454,3 @@ noeq type cFn_t (self args : Type0) = { cFnMutSelfArgsInst.cFnOnceSelfArgsInst.tOutput; } -(** [traits::incr_u32]: forward function - Source: 'src/traits.rs', lines 300:0-300:30 *) -let incr_u32 (x : u32) : result u32 = - u32_add x 1 - diff --git a/tests/lean/Traits.lean b/tests/lean/Traits.lean index e7795d9c..653384d6 100644 --- a/tests/lean/Traits.lean +++ b/tests/lean/Traits.lean @@ -468,9 +468,4 @@ structure CFn (Self Args : Type) where call_mut : Self → Args → Result CFnMutSelfArgsInst.CFnOnceSelfArgsInst.Output -/- [traits::incr_u32]: forward function - Source: 'src/traits.rs', lines 300:0-300:30 -/ -def incr_u32 (x : U32) : Result U32 := - x + 1#u32 - end traits -- cgit v1.2.3 From 94efdf274eb11f4f1ba9a510eb3dd6e190cfc507 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 12:50:45 +0100 Subject: Regenerate the tests --- tests/coq/array/Array.v | 71 ++++++++++++++++------------ tests/fstar/array/Array.Clauses.Template.fst | 4 +- tests/fstar/array/Array.Funs.fst | 68 ++++++++++++++------------ tests/lean/Array.lean | 71 ++++++++++++++++------------ 4 files changed, 125 insertions(+), 89 deletions(-) diff --git a/tests/coq/array/Array.v b/tests/coq/array/Array.v index 105ce21f..1f2cc0e0 100644 --- a/tests/coq/array/Array.v +++ b/tests/coq/array/Array.v @@ -256,8 +256,21 @@ Definition take_slice (s : slice u32) : result unit := Definition take_mut_slice (s : slice u32) : result (slice u32) := Return s. +(** [array::const_array]: forward function + Source: 'src/array.rs', lines 127:0-127:32 *) +Definition const_array : result (array u32 2%usize) := + Return (mk_array u32 2%usize [ 0%u32; 0%u32 ]) +. + +(** [array::const_slice]: forward function + Source: 'src/array.rs', lines 131:0-131:20 *) +Definition const_slice : result unit := + _ <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); + Return tt +. + (** [array::take_all]: forward function - Source: 'src/array.rs', lines 127:0-127:17 *) + Source: 'src/array.rs', lines 141:0-141:17 *) Definition take_all : result unit := _ <- take_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); _ <- take_array_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); @@ -270,37 +283,37 @@ Definition take_all : result unit := . (** [array::index_array]: forward function - Source: 'src/array.rs', lines 141:0-141:38 *) + Source: 'src/array.rs', lines 155:0-155:38 *) Definition index_array (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . (** [array::index_array_borrow]: forward function - Source: 'src/array.rs', lines 144:0-144:46 *) + Source: 'src/array.rs', lines 158:0-158:46 *) Definition index_array_borrow (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . (** [array::index_slice_u32_0]: forward function - Source: 'src/array.rs', lines 148:0-148:42 *) + Source: 'src/array.rs', lines 162:0-162:42 *) Definition index_slice_u32_0 (x : slice u32) : result u32 := slice_index_usize u32 x 0%usize . (** [array::index_mut_slice_u32_0]: forward function - Source: 'src/array.rs', lines 152:0-152:50 *) + Source: 'src/array.rs', lines 166:0-166:50 *) Definition index_mut_slice_u32_0 (x : slice u32) : result u32 := slice_index_usize u32 x 0%usize . (** [array::index_mut_slice_u32_0]: backward function 0 - Source: 'src/array.rs', lines 152:0-152:50 *) + Source: 'src/array.rs', lines 166:0-166:50 *) Definition index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) := _ <- slice_index_usize u32 x 0%usize; Return x . (** [array::index_all]: forward function - Source: 'src/array.rs', lines 156:0-156:25 *) + Source: 'src/array.rs', lines 170:0-170:25 *) Definition index_all : result u32 := i <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); i0 <- index_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); @@ -319,14 +332,14 @@ Definition index_all : result u32 := . (** [array::update_array]: forward function - Source: 'src/array.rs', lines 170:0-170:36 *) + Source: 'src/array.rs', lines 184:0-184:36 *) Definition update_array (x : array u32 2%usize) : result unit := _ <- array_update_usize u32 2%usize x 0%usize 1%u32; Return tt . (** [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/array.rs', lines 173:0-173:48 *) + Source: 'src/array.rs', lines 187:0-187:48 *) Definition update_array_mut_borrow (x : array u32 2%usize) : result (array u32 2%usize) := array_update_usize u32 2%usize x 0%usize 1%u32 @@ -334,13 +347,13 @@ Definition update_array_mut_borrow (** [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/array.rs', lines 176:0-176:38 *) + Source: 'src/array.rs', lines 190:0-190:38 *) Definition update_mut_slice (x : slice u32) : result (slice u32) := slice_update_usize u32 x 0%usize 1%u32 . (** [array::update_all]: forward function - Source: 'src/array.rs', lines 180:0-180:19 *) + Source: 'src/array.rs', lines 194:0-194:19 *) Definition update_all : result unit := _ <- update_array (mk_array u32 2%usize [ 0%u32; 0%u32 ]); x <- update_array_mut_borrow (mk_array u32 2%usize [ 0%u32; 0%u32 ]); @@ -351,7 +364,7 @@ Definition update_all : result unit := . (** [array::range_all]: forward function - Source: 'src/array.rs', lines 191:0-191:18 *) + Source: 'src/array.rs', lines 205:0-205:18 *) Definition range_all : result unit := s <- core_array_Array_index_mut u32 (core_ops_range_Range usize) 4%usize @@ -376,37 +389,37 @@ Definition range_all : result unit := . (** [array::deref_array_borrow]: forward function - Source: 'src/array.rs', lines 200:0-200:46 *) + Source: 'src/array.rs', lines 214:0-214:46 *) Definition deref_array_borrow (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . (** [array::deref_array_mut_borrow]: forward function - Source: 'src/array.rs', lines 205:0-205:54 *) + Source: 'src/array.rs', lines 219:0-219:54 *) Definition deref_array_mut_borrow (x : array u32 2%usize) : result u32 := array_index_usize u32 2%usize x 0%usize . (** [array::deref_array_mut_borrow]: backward function 0 - Source: 'src/array.rs', lines 205:0-205:54 *) + Source: 'src/array.rs', lines 219:0-219:54 *) Definition deref_array_mut_borrow_back (x : array u32 2%usize) : result (array u32 2%usize) := _ <- array_index_usize u32 2%usize x 0%usize; Return x . (** [array::take_array_t]: forward function - Source: 'src/array.rs', lines 213:0-213:31 *) + Source: 'src/array.rs', lines 227:0-227:31 *) Definition take_array_t (a : array AB_t 2%usize) : result unit := Return tt. (** [array::non_copyable_array]: forward function - Source: 'src/array.rs', lines 215:0-215:27 *) + Source: 'src/array.rs', lines 229:0-229:27 *) Definition non_copyable_array : result unit := _ <- take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]); Return tt . (** [array::sum]: loop 0: forward function - Source: 'src/array.rs', lines 228:0-236:1 *) + Source: 'src/array.rs', lines 242:0-250:1 *) Fixpoint sum_loop (n : nat) (s : slice u32) (sum0 : u32) (i : usize) : result u32 := match n with @@ -424,13 +437,13 @@ Fixpoint sum_loop . (** [array::sum]: forward function - Source: 'src/array.rs', lines 228:0-228:28 *) + Source: 'src/array.rs', lines 242:0-242:28 *) Definition sum (n : nat) (s : slice u32) : result u32 := sum_loop n s 0%u32 0%usize . (** [array::sum2]: loop 0: forward function - Source: 'src/array.rs', lines 238:0-247:1 *) + Source: 'src/array.rs', lines 252:0-261:1 *) Fixpoint sum2_loop (n : nat) (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : result u32 @@ -452,7 +465,7 @@ Fixpoint sum2_loop . (** [array::sum2]: forward function - Source: 'src/array.rs', lines 238:0-238:41 *) + Source: 'src/array.rs', lines 252:0-252:41 *) Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := let i := slice_len u32 s in let i0 := slice_len u32 s2 in @@ -460,7 +473,7 @@ Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := . (** [array::f0]: forward function - Source: 'src/array.rs', lines 249:0-249:11 *) + Source: 'src/array.rs', lines 263:0-263:11 *) Definition f0 : result unit := s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]); s0 <- slice_update_usize u32 s 0%usize 1%u32; @@ -469,7 +482,7 @@ Definition f0 : result unit := . (** [array::f1]: forward function - Source: 'src/array.rs', lines 254:0-254:11 *) + Source: 'src/array.rs', lines 268:0-268:11 *) Definition f1 : result unit := _ <- array_update_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) @@ -478,12 +491,12 @@ Definition f1 : result unit := . (** [array::f2]: forward function - Source: 'src/array.rs', lines 259:0-259:17 *) + Source: 'src/array.rs', lines 273:0-273:17 *) Definition f2 (i : u32) : result unit := Return tt. (** [array::f4]: forward function - Source: 'src/array.rs', lines 268:0-268:54 *) + Source: 'src/array.rs', lines 282:0-282:54 *) Definition f4 (x : array u32 32%usize) (y : usize) (z : usize) : result (slice u32) := core_array_Array_index u32 (core_ops_range_Range usize) 32%usize @@ -493,7 +506,7 @@ Definition f4 . (** [array::f3]: forward function - Source: 'src/array.rs', lines 261:0-261:18 *) + Source: 'src/array.rs', lines 275:0-275:18 *) Definition f3 (n : nat) : result u32 := i <- array_index_usize u32 2%usize (mk_array u32 2%usize [ 1%u32; 2%u32 ]) @@ -506,18 +519,18 @@ Definition f3 (n : nat) : result u32 := . (** [array::SZ] - Source: 'src/array.rs', lines 272:0-272:19 *) + Source: 'src/array.rs', lines 286:0-286:19 *) Definition sz_body : result usize := Return 32%usize. Definition sz_c : usize := sz_body%global. (** [array::f5]: forward function - Source: 'src/array.rs', lines 275:0-275:31 *) + Source: 'src/array.rs', lines 289:0-289:31 *) Definition f5 (x : array u32 32%usize) : result u32 := array_index_usize u32 32%usize x 0%usize . (** [array::ite]: forward function - Source: 'src/array.rs', lines 280:0-280:12 *) + Source: 'src/array.rs', lines 294:0-294:12 *) Definition ite : result unit := s <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); s0 <- array_to_slice u32 2%usize (mk_array u32 2%usize [ 0%u32; 0%u32 ]); diff --git a/tests/fstar/array/Array.Clauses.Template.fst b/tests/fstar/array/Array.Clauses.Template.fst index 08a2925f..84347ab9 100644 --- a/tests/fstar/array/Array.Clauses.Template.fst +++ b/tests/fstar/array/Array.Clauses.Template.fst @@ -7,13 +7,13 @@ open Array.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" (** [array::sum]: decreases clause - Source: 'src/array.rs', lines 228:0-236:1 *) + Source: 'src/array.rs', lines 242:0-250:1 *) unfold let sum_loop_decreases (s : slice u32) (sum0 : u32) (i : usize) : nat = admit () (** [array::sum2]: decreases clause - Source: 'src/array.rs', lines 238:0-247:1 *) + Source: 'src/array.rs', lines 252:0-261:1 *) unfold let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : nat = diff --git a/tests/fstar/array/Array.Funs.fst b/tests/fstar/array/Array.Funs.fst index a8722a4f..935bd9c9 100644 --- a/tests/fstar/array/Array.Funs.fst +++ b/tests/fstar/array/Array.Funs.fst @@ -209,8 +209,18 @@ let take_slice (s : slice u32) : result unit = let take_mut_slice (s : slice u32) : result (slice u32) = Return s +(** [array::const_array]: forward function + Source: 'src/array.rs', lines 127:0-127:32 *) +let const_array : result (array u32 2) = + Return (mk_array u32 2 [ 0; 0 ]) + +(** [array::const_slice]: forward function + Source: 'src/array.rs', lines 131:0-131:20 *) +let const_slice : result unit = + let* _ = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in Return () + (** [array::take_all]: forward function - Source: 'src/array.rs', lines 127:0-127:17 *) + Source: 'src/array.rs', lines 141:0-141:17 *) let take_all : result unit = let* _ = take_array (mk_array u32 2 [ 0; 0 ]) in let* _ = take_array_borrow (mk_array u32 2 [ 0; 0 ]) in @@ -222,32 +232,32 @@ let take_all : result unit = Return () (** [array::index_array]: forward function - Source: 'src/array.rs', lines 141:0-141:38 *) + Source: 'src/array.rs', lines 155:0-155:38 *) let index_array (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 (** [array::index_array_borrow]: forward function - Source: 'src/array.rs', lines 144:0-144:46 *) + Source: 'src/array.rs', lines 158:0-158:46 *) let index_array_borrow (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 (** [array::index_slice_u32_0]: forward function - Source: 'src/array.rs', lines 148:0-148:42 *) + Source: 'src/array.rs', lines 162:0-162:42 *) let index_slice_u32_0 (x : slice u32) : result u32 = slice_index_usize u32 x 0 (** [array::index_mut_slice_u32_0]: forward function - Source: 'src/array.rs', lines 152:0-152:50 *) + Source: 'src/array.rs', lines 166:0-166:50 *) let index_mut_slice_u32_0 (x : slice u32) : result u32 = slice_index_usize u32 x 0 (** [array::index_mut_slice_u32_0]: backward function 0 - Source: 'src/array.rs', lines 152:0-152:50 *) + Source: 'src/array.rs', lines 166:0-166:50 *) let index_mut_slice_u32_0_back (x : slice u32) : result (slice u32) = let* _ = slice_index_usize u32 x 0 in Return x (** [array::index_all]: forward function - Source: 'src/array.rs', lines 156:0-156:25 *) + Source: 'src/array.rs', lines 170:0-170:25 *) let index_all : result u32 = let* i = index_array (mk_array u32 2 [ 0; 0 ]) in let* i0 = index_array (mk_array u32 2 [ 0; 0 ]) in @@ -265,24 +275,24 @@ let index_all : result u32 = Return i7 (** [array::update_array]: forward function - Source: 'src/array.rs', lines 170:0-170:36 *) + Source: 'src/array.rs', lines 184:0-184:36 *) let update_array (x : array u32 2) : result unit = let* _ = array_update_usize u32 2 x 0 1 in Return () (** [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/array.rs', lines 173:0-173:48 *) + Source: 'src/array.rs', lines 187:0-187:48 *) let update_array_mut_borrow (x : array u32 2) : result (array u32 2) = array_update_usize u32 2 x 0 1 (** [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/array.rs', lines 176:0-176:38 *) + Source: 'src/array.rs', lines 190:0-190:38 *) let update_mut_slice (x : slice u32) : result (slice u32) = slice_update_usize u32 x 0 1 (** [array::update_all]: forward function - Source: 'src/array.rs', lines 180:0-180:19 *) + Source: 'src/array.rs', lines 194:0-194:19 *) let update_all : result unit = let* _ = update_array (mk_array u32 2 [ 0; 0 ]) in let* x = update_array_mut_borrow (mk_array u32 2 [ 0; 0 ]) in @@ -292,7 +302,7 @@ let update_all : result unit = Return () (** [array::range_all]: forward function - Source: 'src/array.rs', lines 191:0-191:18 *) + Source: 'src/array.rs', lines 205:0-205:18 *) let range_all : result unit = let* s = core_array_Array_index_mut u32 (core_ops_range_Range usize) 4 @@ -308,32 +318,32 @@ let range_all : result unit = Return () (** [array::deref_array_borrow]: forward function - Source: 'src/array.rs', lines 200:0-200:46 *) + Source: 'src/array.rs', lines 214:0-214:46 *) let deref_array_borrow (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 (** [array::deref_array_mut_borrow]: forward function - Source: 'src/array.rs', lines 205:0-205:54 *) + Source: 'src/array.rs', lines 219:0-219:54 *) let deref_array_mut_borrow (x : array u32 2) : result u32 = array_index_usize u32 2 x 0 (** [array::deref_array_mut_borrow]: backward function 0 - Source: 'src/array.rs', lines 205:0-205:54 *) + Source: 'src/array.rs', lines 219:0-219:54 *) let deref_array_mut_borrow_back (x : array u32 2) : result (array u32 2) = let* _ = array_index_usize u32 2 x 0 in Return x (** [array::take_array_t]: forward function - Source: 'src/array.rs', lines 213:0-213:31 *) + Source: 'src/array.rs', lines 227:0-227:31 *) let take_array_t (a : array aB_t 2) : result unit = Return () (** [array::non_copyable_array]: forward function - Source: 'src/array.rs', lines 215:0-215:27 *) + Source: 'src/array.rs', lines 229:0-229:27 *) let non_copyable_array : result unit = let* _ = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) in Return () (** [array::sum]: loop 0: forward function - Source: 'src/array.rs', lines 228:0-236:1 *) + Source: 'src/array.rs', lines 242:0-250:1 *) let rec sum_loop (s : slice u32) (sum0 : u32) (i : usize) : Tot (result u32) (decreases (sum_loop_decreases s sum0 i)) @@ -348,12 +358,12 @@ let rec sum_loop else Return sum0 (** [array::sum]: forward function - Source: 'src/array.rs', lines 228:0-228:28 *) + Source: 'src/array.rs', lines 242:0-242:28 *) let sum (s : slice u32) : result u32 = sum_loop s 0 0 (** [array::sum2]: loop 0: forward function - Source: 'src/array.rs', lines 238:0-247:1 *) + Source: 'src/array.rs', lines 252:0-261:1 *) let rec sum2_loop (s : slice u32) (s2 : slice u32) (sum0 : u32) (i : usize) : Tot (result u32) (decreases (sum2_loop_decreases s s2 sum0 i)) @@ -370,14 +380,14 @@ let rec sum2_loop else Return sum0 (** [array::sum2]: forward function - Source: 'src/array.rs', lines 238:0-238:41 *) + Source: 'src/array.rs', lines 252:0-252:41 *) let sum2 (s : slice u32) (s2 : slice u32) : result u32 = let i = slice_len u32 s in let i0 = slice_len u32 s2 in if not (i = i0) then Fail Failure else sum2_loop s s2 0 0 (** [array::f0]: forward function - Source: 'src/array.rs', lines 249:0-249:11 *) + Source: 'src/array.rs', lines 263:0-263:11 *) let f0 : result unit = let* s = array_to_slice u32 2 (mk_array u32 2 [ 1; 2 ]) in let* s0 = slice_update_usize u32 s 0 1 in @@ -385,17 +395,17 @@ let f0 : result unit = Return () (** [array::f1]: forward function - Source: 'src/array.rs', lines 254:0-254:11 *) + Source: 'src/array.rs', lines 268:0-268:11 *) let f1 : result unit = let* _ = array_update_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 1 in Return () (** [array::f2]: forward function - Source: 'src/array.rs', lines 259:0-259:17 *) + Source: 'src/array.rs', lines 273:0-273:17 *) let f2 (i : u32) : result unit = Return () (** [array::f4]: forward function - Source: 'src/array.rs', lines 268:0-268:54 *) + Source: 'src/array.rs', lines 282:0-282:54 *) let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = core_array_Array_index u32 (core_ops_range_Range usize) 32 (core_ops_index_IndexSliceTIInst u32 (core_ops_range_Range usize) @@ -403,7 +413,7 @@ let f4 (x : array u32 32) (y : usize) (z : usize) : result (slice u32) = { start = y; end_ = z } (** [array::f3]: forward function - Source: 'src/array.rs', lines 261:0-261:18 *) + Source: 'src/array.rs', lines 275:0-275:18 *) let f3 : result u32 = let* i = array_index_usize u32 2 (mk_array u32 2 [ 1; 2 ]) 0 in let* _ = f2 i in @@ -413,17 +423,17 @@ let f3 : result u32 = sum2 s s0 (** [array::SZ] - Source: 'src/array.rs', lines 272:0-272:19 *) + Source: 'src/array.rs', lines 286:0-286:19 *) let sz_body : result usize = Return 32 let sz_c : usize = eval_global sz_body (** [array::f5]: forward function - Source: 'src/array.rs', lines 275:0-275:31 *) + Source: 'src/array.rs', lines 289:0-289:31 *) let f5 (x : array u32 32) : result u32 = array_index_usize u32 32 x 0 (** [array::ite]: forward function - Source: 'src/array.rs', lines 280:0-280:12 *) + Source: 'src/array.rs', lines 294:0-294:12 *) let ite : result unit = let* s = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in let* s0 = array_to_slice u32 2 (mk_array u32 2 [ 0; 0 ]) in diff --git a/tests/lean/Array.lean b/tests/lean/Array.lean index b49add96..25dad3cf 100644 --- a/tests/lean/Array.lean +++ b/tests/lean/Array.lean @@ -232,8 +232,21 @@ def take_slice (s : Slice U32) : Result Unit := def take_mut_slice (s : Slice U32) : Result (Slice U32) := Result.ret s +/- [array::const_array]: forward function + Source: 'src/array.rs', lines 127:0-127:32 -/ +def const_array : Result (Array U32 2#usize) := + Result.ret (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + +/- [array::const_slice]: forward function + Source: 'src/array.rs', lines 131:0-131:20 -/ +def const_slice : Result Unit := + do + let _ ← + Array.to_slice U32 2#usize (Array.make U32 2#usize [ 0#u32, 0#u32 ]) + Result.ret () + /- [array::take_all]: forward function - Source: 'src/array.rs', lines 127:0-127:17 -/ + Source: 'src/array.rs', lines 141:0-141:17 -/ def take_all : Result Unit := do let _ ← take_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) @@ -249,34 +262,34 @@ def take_all : Result Unit := Result.ret () /- [array::index_array]: forward function - Source: 'src/array.rs', lines 141:0-141:38 -/ + Source: 'src/array.rs', lines 155:0-155:38 -/ def index_array (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize /- [array::index_array_borrow]: forward function - Source: 'src/array.rs', lines 144:0-144:46 -/ + Source: 'src/array.rs', lines 158:0-158:46 -/ def index_array_borrow (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize /- [array::index_slice_u32_0]: forward function - Source: 'src/array.rs', lines 148:0-148:42 -/ + Source: 'src/array.rs', lines 162:0-162:42 -/ def index_slice_u32_0 (x : Slice U32) : Result U32 := Slice.index_usize U32 x 0#usize /- [array::index_mut_slice_u32_0]: forward function - Source: 'src/array.rs', lines 152:0-152:50 -/ + Source: 'src/array.rs', lines 166:0-166:50 -/ def index_mut_slice_u32_0 (x : Slice U32) : Result U32 := Slice.index_usize U32 x 0#usize /- [array::index_mut_slice_u32_0]: backward function 0 - Source: 'src/array.rs', lines 152:0-152:50 -/ + Source: 'src/array.rs', lines 166:0-166:50 -/ def index_mut_slice_u32_0_back (x : Slice U32) : Result (Slice U32) := do let _ ← Slice.index_usize U32 x 0#usize Result.ret x /- [array::index_all]: forward function - Source: 'src/array.rs', lines 156:0-156:25 -/ + Source: 'src/array.rs', lines 170:0-170:25 -/ def index_all : Result U32 := do let i ← index_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) @@ -298,7 +311,7 @@ def index_all : Result U32 := Result.ret i7 /- [array::update_array]: forward function - Source: 'src/array.rs', lines 170:0-170:36 -/ + Source: 'src/array.rs', lines 184:0-184:36 -/ def update_array (x : Array U32 2#usize) : Result Unit := do let _ ← Array.update_usize U32 2#usize x 0#usize 1#u32 @@ -306,19 +319,19 @@ def update_array (x : Array U32 2#usize) : Result Unit := /- [array::update_array_mut_borrow]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/array.rs', lines 173:0-173:48 -/ + Source: 'src/array.rs', lines 187:0-187:48 -/ def update_array_mut_borrow (x : Array U32 2#usize) : Result (Array U32 2#usize) := Array.update_usize U32 2#usize x 0#usize 1#u32 /- [array::update_mut_slice]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/array.rs', lines 176:0-176:38 -/ + Source: 'src/array.rs', lines 190:0-190:38 -/ def update_mut_slice (x : Slice U32) : Result (Slice U32) := Slice.update_usize U32 x 0#usize 1#u32 /- [array::update_all]: forward function - Source: 'src/array.rs', lines 180:0-180:19 -/ + Source: 'src/array.rs', lines 194:0-194:19 -/ def update_all : Result Unit := do let _ ← update_array (Array.make U32 2#usize [ 0#u32, 0#u32 ]) @@ -329,7 +342,7 @@ def update_all : Result Unit := Result.ret () /- [array::range_all]: forward function - Source: 'src/array.rs', lines 191:0-191:18 -/ + Source: 'src/array.rs', lines 205:0-205:18 -/ def range_all : Result Unit := do let s ← @@ -348,17 +361,17 @@ def range_all : Result Unit := Result.ret () /- [array::deref_array_borrow]: forward function - Source: 'src/array.rs', lines 200:0-200:46 -/ + Source: 'src/array.rs', lines 214:0-214:46 -/ def deref_array_borrow (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: forward function - Source: 'src/array.rs', lines 205:0-205:54 -/ + Source: 'src/array.rs', lines 219:0-219:54 -/ def deref_array_mut_borrow (x : Array U32 2#usize) : Result U32 := Array.index_usize U32 2#usize x 0#usize /- [array::deref_array_mut_borrow]: backward function 0 - Source: 'src/array.rs', lines 205:0-205:54 -/ + Source: 'src/array.rs', lines 219:0-219:54 -/ def deref_array_mut_borrow_back (x : Array U32 2#usize) : Result (Array U32 2#usize) := do @@ -366,19 +379,19 @@ def deref_array_mut_borrow_back Result.ret x /- [array::take_array_t]: forward function - Source: 'src/array.rs', lines 213:0-213:31 -/ + Source: 'src/array.rs', lines 227:0-227:31 -/ def take_array_t (a : Array AB 2#usize) : Result Unit := Result.ret () /- [array::non_copyable_array]: forward function - Source: 'src/array.rs', lines 215:0-215:27 -/ + Source: 'src/array.rs', lines 229:0-229:27 -/ def non_copyable_array : Result Unit := do let _ ← take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) Result.ret () /- [array::sum]: loop 0: forward function - Source: 'src/array.rs', lines 228:0-236:1 -/ + Source: 'src/array.rs', lines 242:0-250:1 -/ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := let i0 := Slice.len U32 s if i < i0 @@ -391,12 +404,12 @@ divergent def sum_loop (s : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := else Result.ret sum0 /- [array::sum]: forward function - Source: 'src/array.rs', lines 228:0-228:28 -/ + Source: 'src/array.rs', lines 242:0-242:28 -/ def sum (s : Slice U32) : Result U32 := sum_loop s 0#u32 0#usize /- [array::sum2]: loop 0: forward function - Source: 'src/array.rs', lines 238:0-247:1 -/ + Source: 'src/array.rs', lines 252:0-261:1 -/ divergent def sum2_loop (s : Slice U32) (s2 : Slice U32) (sum0 : U32) (i : Usize) : Result U32 := let i0 := Slice.len U32 s @@ -412,7 +425,7 @@ divergent def sum2_loop else Result.ret sum0 /- [array::sum2]: forward function - Source: 'src/array.rs', lines 238:0-238:41 -/ + Source: 'src/array.rs', lines 252:0-252:41 -/ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := let i := Slice.len U32 s let i0 := Slice.len U32 s2 @@ -421,7 +434,7 @@ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := else sum2_loop s s2 0#u32 0#usize /- [array::f0]: forward function - Source: 'src/array.rs', lines 249:0-249:11 -/ + Source: 'src/array.rs', lines 263:0-263:11 -/ def f0 : Result Unit := do let s ← @@ -432,7 +445,7 @@ def f0 : Result Unit := Result.ret () /- [array::f1]: forward function - Source: 'src/array.rs', lines 254:0-254:11 -/ + Source: 'src/array.rs', lines 268:0-268:11 -/ def f1 : Result Unit := do let _ ← @@ -441,12 +454,12 @@ def f1 : Result Unit := Result.ret () /- [array::f2]: forward function - Source: 'src/array.rs', lines 259:0-259:17 -/ + Source: 'src/array.rs', lines 273:0-273:17 -/ def f2 (i : U32) : Result Unit := Result.ret () /- [array::f4]: forward function - Source: 'src/array.rs', lines 268:0-268:54 -/ + Source: 'src/array.rs', lines 282:0-282:54 -/ def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := core.array.Array.index U32 (core.ops.range.Range Usize) 32#usize (core.ops.index.IndexSliceTIInst U32 (core.ops.range.Range Usize) @@ -454,7 +467,7 @@ def f4 (x : Array U32 32#usize) (y : Usize) (z : Usize) : Result (Slice U32) := { start := y, end_ := z } /- [array::f3]: forward function - Source: 'src/array.rs', lines 261:0-261:18 -/ + Source: 'src/array.rs', lines 275:0-275:18 -/ def f3 : Result U32 := do let i ← @@ -468,17 +481,17 @@ def f3 : Result U32 := sum2 s s0 /- [array::SZ] - Source: 'src/array.rs', lines 272:0-272:19 -/ + Source: 'src/array.rs', lines 286:0-286:19 -/ def sz_body : Result Usize := Result.ret 32#usize def sz_c : Usize := eval_global sz_body (by simp) /- [array::f5]: forward function - Source: 'src/array.rs', lines 275:0-275:31 -/ + Source: 'src/array.rs', lines 289:0-289:31 -/ def f5 (x : Array U32 32#usize) : Result U32 := Array.index_usize U32 32#usize x 0#usize /- [array::ite]: forward function - Source: 'src/array.rs', lines 280:0-280:12 -/ + Source: 'src/array.rs', lines 294:0-294:12 -/ def ite : Result Unit := do let s ← -- cgit v1.2.3 From bf355187af124706553dbb58ad43bbdbcbbe3acb Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 14:06:16 +0100 Subject: Update flake.lock --- flake.lock | 60 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/flake.lock b/flake.lock index 8a34cfcb..eedf152d 100644 --- a/flake.lock +++ b/flake.lock @@ -8,11 +8,11 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1701097924, - "narHash": "sha256-fIXlINGdx8228emfCSkbqLN7f6mrLvoJc4gmqcyACU0=", + "lastModified": 1701263140, + "narHash": "sha256-rxfTrlSCGZVwcHNV+zqRk8Wh92lojYfdXWmE9oUSp0w=", "owner": "aeneasverif", "repo": "charon", - "rev": "a635cdc69aa3c17e06ebc42e0694b0fcb7fa0fbb", + "rev": "e3718f07206e54458b3fcf0642089c32ee2381f0", "type": "github" }, "original": { @@ -29,11 +29,11 @@ ] }, "locked": { - "lastModified": 1699548976, - "narHash": "sha256-xnpxms0koM8mQpxIup9JnT0F7GrKdvv0QvtxvRuOYR4=", + "lastModified": 1701220101, + "narHash": "sha256-EBuCZ/Vjp3ovx8ZvfALfuUk4/76Ey/6cJmzmeXBRmDk=", "owner": "ipetkov", "repo": "crane", - "rev": "6849911446e18e520970cc6b7a691e64ee90d649", + "rev": "514cd663e5af505a244e55ad013733638574aff9", "type": "github" }, "original": { @@ -131,11 +131,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1700646441, - "narHash": "sha256-yZe9nDY+0nAWATQLorXSJB7yZ6yNyIlz9mT/qxHgNac=", + "lastModified": 1701214966, + "narHash": "sha256-AmvqisPtId4Ej+xga5djjSzdxpRzx7K9CL7JvjE5BLs=", "owner": "fstarlang", "repo": "fstar", - "rev": "fe6dec16fc4f0234663da63de26d9d2e72fe14df", + "rev": "3ad64126966f25423c7fb897412faebc540b864a", "type": "github" }, "original": { @@ -164,11 +164,11 @@ ] }, "locked": { - "lastModified": 1700661621, - "narHash": "sha256-XON6e4x5QRviofMGRyEwd+5PTVWAp/LdFFveC0LQhkY=", + "lastModified": 1701086382, + "narHash": "sha256-g40c06xDz7dkaJIH6Sjo95FN39hJ42O5ANPmYO974D4=", "owner": "hacl-star", "repo": "hacl-star", - "rev": "95112e8dcb1ea3fe7d254290f8864b8f8e2fb6b2", + "rev": "071512259483ac2c8bbb5948634408b523b31335", "type": "github" }, "original": { @@ -194,11 +194,11 @@ ] }, "locked": { - "lastModified": 1700702143, - "narHash": "sha256-BadYV0m36o3T0I7gB8rp7vos2HL6N+9I23+HAZdoZFM=", + "lastModified": 1701220603, + "narHash": "sha256-vQYLDG4+QRpRODMeZ7WLARtoM+IaRmi0hgTmZg4vhl0=", "owner": "hacl-star", "repo": "hacl-nix", - "rev": "84b572dc55ec16eb8403ada9934987fd7ff44f76", + "rev": "05f5ca8e7e4c12cc0bc322b3f6b8c0f8433e232a", "type": "github" }, "original": { @@ -223,11 +223,11 @@ ] }, "locked": { - "lastModified": 1698968585, - "narHash": "sha256-x3ZaGrmuKF5+7xaWHu0yDikl4mrawkY5tQnfovgyPh8=", + "lastModified": 1701110212, + "narHash": "sha256-OrlMYgA8609l8orB41VAFJKDj/0WtiAfdOOaQjMhefs=", "owner": "fstarlang", "repo": "karamel", - "rev": "a7be2a7c43eca637ceb57fe8f3ffd16fc6627ebd", + "rev": "4ad701968346033a986f92d9d91a837e9af95c4e", "type": "github" }, "original": { @@ -265,11 +265,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1701086558, - "narHash": "sha256-Y5d0Ba09Bs8J6rxfH9gTEWEZ/pqDfIPwg73VYWpxIs8=", + "lastModified": 1701259400, + "narHash": "sha256-BZxLzC6mapqUUpL4SUiEy4ZqszTehcTDQRAhThDCMAY=", "owner": "leanprover", "repo": "lean4", - "rev": "9769ad65723866093b35cd2c8875cc45e65d477a", + "rev": "4f2f704962f960c42ca2bc3ca81c4c43767b22f2", "type": "github" }, "original": { @@ -318,11 +318,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1701086558, - "narHash": "sha256-Y5d0Ba09Bs8J6rxfH9gTEWEZ/pqDfIPwg73VYWpxIs8=", + "lastModified": 1701259400, + "narHash": "sha256-BZxLzC6mapqUUpL4SUiEy4ZqszTehcTDQRAhThDCMAY=", "owner": "leanprover", "repo": "lean4", - "rev": "9769ad65723866093b35cd2c8875cc45e65d477a", + "rev": "4f2f704962f960c42ca2bc3ca81c4c43767b22f2", "type": "github" }, "original": { @@ -405,11 +405,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1699099776, - "narHash": "sha256-X09iKJ27mGsGambGfkKzqvw5esP1L/Rf8H3u3fCqIiU=", + "lastModified": 1701068326, + "narHash": "sha256-vmMceA+q6hG1yrjb+MP8T0YFDQIrW3bl45e7z24IEts=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "85f1ba3e51676fa8cc604a3d863d729026a6b8eb", + "rev": "8cfef6986adfb599ba379ae53c9f5631ecd2fd9c", "type": "github" }, "original": { @@ -573,11 +573,11 @@ ] }, "locked": { - "lastModified": 1699582387, - "narHash": "sha256-sPmUXPDl+cEi+zFtM5lnAs7dWOdRn0ptZ4a/qHwvNDk=", + "lastModified": 1701224160, + "narHash": "sha256-qnMmxNMKmd6Soel0cfauyMJ+LzuZbvmiDQPSIuTbQ+M=", "owner": "oxalica", "repo": "rust-overlay", - "rev": "41f7b0618052430d3a050e8f937030d00a2fcced", + "rev": "4a080e26d55eaedb95ab1bf8eeaeb84149c10f12", "type": "github" }, "original": { -- cgit v1.2.3 From dc4b11689131bdb41a43e5aca76538556a3a120c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 15:45:27 +0100 Subject: Add support for more bitwise operations and update the extraction --- Makefile | 19 ++-- backends/coq/Primitives.v | 76 ++++++++++++++ backends/fstar/Primitives.fst | 167 ++++++++++++++++++++++++++++-- backends/lean/Base/Primitives/Scalar.lean | 42 +++++++- compiler/ExtractBase.ml | 12 +-- compiler/ExtractTypes.ml | 14 ++- 6 files changed, 302 insertions(+), 28 deletions(-) diff --git a/Makefile b/Makefile index 88cb7d05..2cce30d9 100644 --- a/Makefile +++ b/Makefile @@ -91,7 +91,7 @@ tests: test-no_nested_borrows test-paper \ testp-polonius_list testp-betree_main \ ctest-testp-betree_main \ test-loops \ - test-array test-traits # TODO: generalize to all backends + test-array test-traits test-bitwise # Verify the F* files generated by the translation .PHONY: verify @@ -139,14 +139,6 @@ tlean-traits: SUBDIR := tlean-traits: OPTIONS += thol4-traits: OPTIONS += -# TODO: activate the arrays for all the backends -thol4-array: - echo "Ignoring the array test for HOL4" - -# TODO: activate the traits for all the backends -thol4-traits: - echo "Ignoring the traits test for HOL4" - test-loops: OPTIONS += test-loops: SUBDIR := misc tfstar-loops: OPTIONS += -decreases-clauses -template-clauses -split-files @@ -198,6 +190,15 @@ tlean-external: OPTIONS += thol4-external: SUBDIR := misc-external thol4-external: OPTIONS += +test-bitwise: OPTIONS += -test-trans-units +test-bitwise: SUBDIR := misc +tfstar-bitwise: OPTIONS += +tcoq-bitwise: OPTIONS += +tlean-bitwise: SUBDIR := +tlean-bitwise: OPTIONS += +thol4-bitwise: SUBDIR := misc-bitwise +thol4-bitwise: OPTIONS += + BETREE_FSTAR_OPTIONS = -decreases-clauses -template-clauses testp-betree_main: OPTIONS += -backward-no-state-update -test-trans-units -state -split-files testp-betree_main: SUBDIR:=betree diff --git a/backends/coq/Primitives.v b/backends/coq/Primitives.v index 83f860b6..99ffe070 100644 --- a/backends/coq/Primitives.v +++ b/backends/coq/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/backends/fstar/Primitives.fst b/backends/fstar/Primitives.fst index 94322ead..dd340c00 100644 --- a/backends/fstar/Primitives.fst +++ b/backends/fstar/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/backends/lean/Base/Primitives/Scalar.lean b/backends/lean/Base/Primitives/Scalar.lean index ec9665a5..cdd6d6f9 100644 --- a/backends/lean/Base/Primitives/Scalar.lean +++ b/backends/lean/Base/Primitives/Scalar.lean @@ -386,10 +386,28 @@ def Scalar.sub {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar def Scalar.mul {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Result (Scalar ty) := Scalar.tryMk ty (x.val * y.val) --- TODO: instances of +, -, * etc. for scalars +-- TODO: shift left +def Scalar.shiftl {ty0 ty1 : ScalarTy} (x : Scalar ty0) (y : Scalar ty1) : Result (Scalar ty0) := + sorry + +-- TODO: shift right +def Scalar.shiftr {ty0 ty1 : ScalarTy} (x : Scalar ty0) (y : Scalar ty1) : Result (Scalar ty0) := + sorry + +-- TODO: xor +def Scalar.xor {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Scalar ty := + sorry + +-- TODO: and +def Scalar.and {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Scalar ty := + sorry + +-- TODO: or +def Scalar.or {ty : ScalarTy} (x : Scalar ty) (y : Scalar ty) : Scalar ty := + sorry -- Cast an integer from a [src_ty] to a [tgt_ty] --- TODO: check the semantics of casts in Rust +-- TODO: double-check the semantics of casts in Rust def Scalar.cast {src_ty : ScalarTy} (tgt_ty : ScalarTy) (x : Scalar src_ty) : Result (Scalar tgt_ty) := Scalar.tryMk tgt_ty x.val @@ -486,6 +504,26 @@ instance {ty} : HDiv (Scalar ty) (Scalar ty) (Result (Scalar ty)) where instance {ty} : HMod (Scalar ty) (Scalar ty) (Result (Scalar ty)) where hMod x y := Scalar.rem x y +-- Shift left +instance {ty0 ty1} : HShiftLeft (Scalar ty0) (Scalar ty1) (Result (Scalar ty0)) where + hShiftLeft x y := Scalar.shiftl x y + +-- Shift right +instance {ty0 ty1} : HShiftRight (Scalar ty0) (Scalar ty1) (Result (Scalar ty0)) where + hShiftRight x y := Scalar.shiftr x y + +-- Xor +instance {ty} : HXor (Scalar ty) (Scalar ty) (Scalar ty) where + hXor x y := Scalar.xor x y + +-- Or +instance {ty} : HOr (Scalar ty) (Scalar ty) (Scalar ty) where + hOr x y := Scalar.or x y + +-- And +instance {ty} : HAnd (Scalar ty) (Scalar ty) (Scalar ty) where + hAnd x y := Scalar.and x y + -- Generic theorem - shouldn't be used much @[cpspec] theorem Scalar.add_spec {ty} {x y : Scalar ty} diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 85ab1112..73ccac44 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -786,7 +786,7 @@ let unop_name (unop : unop) : string = like [<]). *) let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = - let binop = + let binop_s = match binop with | Div -> "div" | Rem -> "rem" @@ -800,16 +800,14 @@ let named_binop_name (binop : E.binop) (int_ty : integer_type) : string = | 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 *) + | Shl -> "shl" + | Shr -> "shr" | _ -> 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 + | Lean -> int_name int_ty ^ "." ^ binop_s + | FStar | Coq | HOL4 -> int_name int_ty ^ "_" ^ binop_s (** A list of keywords/identifiers used by the backend and with which we want to check collision. diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index f61c28e4..66418410 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -163,7 +163,7 @@ let extract_binop (extract_expr : bool -> texpression -> unit) (match (!backend, binop) with | HOL4, (Eq | Ne) | (FStar | Coq | Lean), (Eq | Lt | Le | Ne | Ge | Gt) - | Lean, (Div | Rem | Add | Sub | Mul) -> + | Lean, (Div | Rem | Add | Sub | Mul | Shl | Shr | BitXor | BitOr | BitAnd) -> let binop = match binop with | Eq -> "=" @@ -179,7 +179,9 @@ let extract_binop (extract_expr : bool -> texpression -> unit) | Mul -> "*" | Shl -> "<<<" | Shr -> ">>>" - | BitXor | BitAnd | BitOr -> raise (Failure "Unimplemented") + | BitXor -> "^^^" + | BitOr -> "|||" + | BitAnd -> "&&&" in let binop = match !backend with FStar | Lean | HOL4 -> binop | Coq -> "s" ^ binop @@ -192,6 +194,14 @@ let extract_binop (extract_expr : bool -> texpression -> unit) | _ -> let binop = named_binop_name binop int_ty in F.pp_print_string fmt binop; + (* In the case of F*, because machine integers are simply integers + with a refinement, if the second argument is a constant we + need to provide the second implicit type argument *) + if !backend = FStar && is_const arg1 then ( + F.pp_print_space fmt (); + let ty = ty_as_integer arg1.ty in + F.pp_print_string fmt + ("#" ^ StringUtils.capitalize_first_letter (int_name ty))); F.pp_print_space fmt (); extract_expr true arg0; F.pp_print_space fmt (); -- cgit v1.2.3 From 3aa9c531db4e9cde25a4a149a64e3ff730ed798b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 15:47:42 +0100 Subject: Fix a minor issue with the extraction --- compiler/ExtractTypes.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/compiler/ExtractTypes.ml b/compiler/ExtractTypes.ml index 66418410..3657627b 100644 --- a/compiler/ExtractTypes.ml +++ b/compiler/ExtractTypes.ml @@ -192,12 +192,13 @@ let extract_binop (extract_expr : bool -> texpression -> unit) F.pp_print_space fmt (); extract_expr false arg1 | _ -> + let binop_is_shift = match binop with Shl | Shr -> true | _ -> false in let binop = named_binop_name binop int_ty in F.pp_print_string fmt binop; - (* In the case of F*, because machine integers are simply integers - with a refinement, if the second argument is a constant we - need to provide the second implicit type argument *) - if !backend = FStar && is_const arg1 then ( + (* In the case of F*, for shift operations, because machine integers + are simply integers with a refinement, if the second argument is a + constant we need to provide the second implicit type argument *) + if binop_is_shift && !backend = FStar && is_const arg1 then ( F.pp_print_space fmt (); let ty = ty_as_integer arg1.ty in F.pp_print_string fmt -- cgit v1.2.3 From 5bf73730e13e51f6dc2a46f92d2ddde152c1c5d2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 15:48:07 +0100 Subject: Generate the Bitwise test files --- tests/coq/misc/Bitwise.v | 38 ++++++++++++++++++++++++++++++++++++++ tests/fstar/misc/Bitwise.fst | 32 ++++++++++++++++++++++++++++++++ tests/lean/Bitwise.lean | 37 +++++++++++++++++++++++++++++++++++++ 3 files changed, 107 insertions(+) create mode 100644 tests/coq/misc/Bitwise.v create mode 100644 tests/fstar/misc/Bitwise.fst create mode 100644 tests/lean/Bitwise.lean diff --git a/tests/coq/misc/Bitwise.v b/tests/coq/misc/Bitwise.v new file mode 100644 index 00000000..94771b37 --- /dev/null +++ b/tests/coq/misc/Bitwise.v @@ -0,0 +1,38 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [bitwise] *) +Require Import Primitives. +Import Primitives. +Require Import Coq.ZArith.ZArith. +Require Import List. +Import ListNotations. +Local Open Scope Primitives_scope. +Module Bitwise. + +(** [bitwise::shift_u32]: forward function + Source: 'src/bitwise.rs', lines 3:0-3:31 *) +Definition shift_u32 (a : u32) : result u32 := + t <- u32_shr a 16%usize; u32_shl t 16%usize +. + +(** [bitwise::shift_i32]: forward function + Source: 'src/bitwise.rs', lines 10:0-10:31 *) +Definition shift_i32 (a : i32) : result i32 := + t <- i32_shr a 16%isize; i32_shl t 16%isize +. + +(** [bitwise::xor_u32]: forward function + Source: 'src/bitwise.rs', lines 17:0-17:37 *) +Definition xor_u32 (a : u32) (b : u32) : result u32 := + Return (u32_xor a b). + +(** [bitwise::or_u32]: forward function + Source: 'src/bitwise.rs', lines 21:0-21:36 *) +Definition or_u32 (a : u32) (b : u32) : result u32 := + Return (u32_or a b). + +(** [bitwise::and_u32]: forward function + Source: 'src/bitwise.rs', lines 25:0-25:37 *) +Definition and_u32 (a : u32) (b : u32) : result u32 := + Return (u32_and a b). + +End Bitwise. diff --git a/tests/fstar/misc/Bitwise.fst b/tests/fstar/misc/Bitwise.fst new file mode 100644 index 00000000..d7ba2c57 --- /dev/null +++ b/tests/fstar/misc/Bitwise.fst @@ -0,0 +1,32 @@ +(** THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS *) +(** [bitwise] *) +module Bitwise +open Primitives + +#set-options "--z3rlimit 50 --fuel 1 --ifuel 1" + +(** [bitwise::shift_u32]: forward function + Source: 'src/bitwise.rs', lines 3:0-3:31 *) +let shift_u32 (a : u32) : result u32 = + let* t = u32_shr #Usize a 16 in u32_shl #Usize t 16 + +(** [bitwise::shift_i32]: forward function + Source: 'src/bitwise.rs', lines 10:0-10:31 *) +let shift_i32 (a : i32) : result i32 = + let* t = i32_shr #Isize a 16 in i32_shl #Isize t 16 + +(** [bitwise::xor_u32]: forward function + Source: 'src/bitwise.rs', lines 17:0-17:37 *) +let xor_u32 (a : u32) (b : u32) : result u32 = + Return (u32_xor a b) + +(** [bitwise::or_u32]: forward function + Source: 'src/bitwise.rs', lines 21:0-21:36 *) +let or_u32 (a : u32) (b : u32) : result u32 = + Return (u32_or a b) + +(** [bitwise::and_u32]: forward function + Source: 'src/bitwise.rs', lines 25:0-25:37 *) +let and_u32 (a : u32) (b : u32) : result u32 = + Return (u32_and a b) + diff --git a/tests/lean/Bitwise.lean b/tests/lean/Bitwise.lean new file mode 100644 index 00000000..c8538aa2 --- /dev/null +++ b/tests/lean/Bitwise.lean @@ -0,0 +1,37 @@ +-- THIS FILE WAS AUTOMATICALLY GENERATED BY AENEAS +-- [bitwise] +import Base +open Primitives + +namespace bitwise + +/- [bitwise::shift_u32]: forward function + Source: 'src/bitwise.rs', lines 3:0-3:31 -/ +def shift_u32 (a : U32) : Result U32 := + do + let t ← a >>> 16#usize + t <<< 16#usize + +/- [bitwise::shift_i32]: forward function + Source: 'src/bitwise.rs', lines 10:0-10:31 -/ +def shift_i32 (a : I32) : Result I32 := + do + let t ← a >>> 16#isize + t <<< 16#isize + +/- [bitwise::xor_u32]: forward function + Source: 'src/bitwise.rs', lines 17:0-17:37 -/ +def xor_u32 (a : U32) (b : U32) : Result U32 := + Result.ret (a ^^^ b) + +/- [bitwise::or_u32]: forward function + Source: 'src/bitwise.rs', lines 21:0-21:36 -/ +def or_u32 (a : U32) (b : U32) : Result U32 := + Result.ret (a ||| b) + +/- [bitwise::and_u32]: forward function + Source: 'src/bitwise.rs', lines 25:0-25:37 -/ +def and_u32 (a : U32) (b : U32) : Result U32 := + Result.ret (a &&& b) + +end bitwise -- cgit v1.2.3 From 3b487893b2906e13b2388efc3512f2babc8514bf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 15:48:27 +0100 Subject: Regenerate the other files --- tests/coq/array/Primitives.v | 76 +++++++++++ tests/coq/betree/Primitives.v | 76 +++++++++++ tests/coq/hashmap/Primitives.v | 76 +++++++++++ tests/coq/hashmap_on_disk/Primitives.v | 76 +++++++++++ tests/coq/misc/Primitives.v | 76 +++++++++++ tests/coq/misc/_CoqProject | 1 + tests/coq/traits/Primitives.v | 76 +++++++++++ tests/fstar/array/Primitives.fst | 167 ++++++++++++++++++++++-- tests/fstar/betree/Primitives.fst | 167 ++++++++++++++++++++++-- tests/fstar/betree_back_stateful/Primitives.fst | 167 ++++++++++++++++++++++-- tests/fstar/hashmap/Primitives.fst | 167 ++++++++++++++++++++++-- tests/fstar/hashmap_on_disk/Primitives.fst | 167 ++++++++++++++++++++++-- tests/fstar/misc/Primitives.fst | 167 ++++++++++++++++++++++-- tests/fstar/traits/Primitives.fst | 167 ++++++++++++++++++++++-- 14 files changed, 1570 insertions(+), 56 deletions(-) diff --git a/tests/coq/array/Primitives.v b/tests/coq/array/Primitives.v index 83f860b6..99ffe070 100644 --- a/tests/coq/array/Primitives.v +++ b/tests/coq/array/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/tests/coq/betree/Primitives.v b/tests/coq/betree/Primitives.v index 83f860b6..99ffe070 100644 --- a/tests/coq/betree/Primitives.v +++ b/tests/coq/betree/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/tests/coq/hashmap/Primitives.v b/tests/coq/hashmap/Primitives.v index 83f860b6..99ffe070 100644 --- a/tests/coq/hashmap/Primitives.v +++ b/tests/coq/hashmap/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/tests/coq/hashmap_on_disk/Primitives.v b/tests/coq/hashmap_on_disk/Primitives.v index 83f860b6..99ffe070 100644 --- a/tests/coq/hashmap_on_disk/Primitives.v +++ b/tests/coq/hashmap_on_disk/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/tests/coq/misc/Primitives.v b/tests/coq/misc/Primitives.v index 83f860b6..99ffe070 100644 --- a/tests/coq/misc/Primitives.v +++ b/tests/coq/misc/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/tests/coq/misc/_CoqProject b/tests/coq/misc/_CoqProject index 0828bced..abbf6aa8 100644 --- a/tests/coq/misc/_CoqProject +++ b/tests/coq/misc/_CoqProject @@ -13,5 +13,6 @@ Constants.v PoloniusList.v NoNestedBorrows.v External_FunsExternal.v +Bitwise.v External_TypesExternal_Template.v External_FunsExternal_Template.v diff --git a/tests/coq/traits/Primitives.v b/tests/coq/traits/Primitives.v index 83f860b6..99ffe070 100644 --- a/tests/coq/traits/Primitives.v +++ b/tests/coq/traits/Primitives.v @@ -255,6 +255,12 @@ Definition scalar_rem {ty} (x y: scalar ty) : result (scalar ty) := mk_scalar ty Definition scalar_neg {ty} (x: scalar ty) : result (scalar ty) := mk_scalar ty (-(to_Z x)). +Axiom scalar_xor : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_or : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_and : forall ty, scalar ty -> scalar ty -> scalar ty. (* TODO *) +Axiom scalar_shl : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) +Axiom scalar_shr : forall ty0 ty1, scalar ty0 -> scalar ty1 -> result (scalar ty0). (* TODO *) + (** Cast an integer from a [src_ty] to a [tgt_ty] *) (* TODO: check the semantics of casts in Rust *) Definition scalar_cast (src_ty tgt_ty : scalar_ty) (x : scalar src_ty) : result (scalar tgt_ty) := @@ -372,6 +378,76 @@ Definition u32_mul := @scalar_mul U32. Definition u64_mul := @scalar_mul U64. Definition u128_mul := @scalar_mul U128. +(** Xor *) +Definition u8_xor := @scalar_xor U8. +Definition u16_xor := @scalar_xor U16. +Definition u32_xor := @scalar_xor U32. +Definition u64_xor := @scalar_xor U64. +Definition u128_xor := @scalar_xor U128. +Definition usize_xor := @scalar_xor Usize. +Definition i8_xor := @scalar_xor I8. +Definition i16_xor := @scalar_xor I16. +Definition i32_xor := @scalar_xor I32. +Definition i64_xor := @scalar_xor I64. +Definition i128_xor := @scalar_xor I128. +Definition isize_xor := @scalar_xor Isize. + +(** Or *) +Definition u8_or := @scalar_or U8. +Definition u16_or := @scalar_or U16. +Definition u32_or := @scalar_or U32. +Definition u64_or := @scalar_or U64. +Definition u128_or := @scalar_or U128. +Definition usize_or := @scalar_or Usize. +Definition i8_or := @scalar_or I8. +Definition i16_or := @scalar_or I16. +Definition i32_or := @scalar_or I32. +Definition i64_or := @scalar_or I64. +Definition i128_or := @scalar_or I128. +Definition isize_or := @scalar_or Isize. + +(** And *) +Definition u8_and := @scalar_and U8. +Definition u16_and := @scalar_and U16. +Definition u32_and := @scalar_and U32. +Definition u64_and := @scalar_and U64. +Definition u128_and := @scalar_and U128. +Definition usize_and := @scalar_and Usize. +Definition i8_and := @scalar_and I8. +Definition i16_and := @scalar_and I16. +Definition i32_and := @scalar_and I32. +Definition i64_and := @scalar_and I64. +Definition i128_and := @scalar_and I128. +Definition isize_and := @scalar_and Isize. + +(** Shift left *) +Definition u8_shl {ty} := @scalar_shl U8 ty. +Definition u16_shl {ty} := @scalar_shl U16 ty. +Definition u32_shl {ty} := @scalar_shl U32 ty. +Definition u64_shl {ty} := @scalar_shl U64 ty. +Definition u128_shl {ty} := @scalar_shl U128 ty. +Definition usize_shl {ty} := @scalar_shl Usize ty. +Definition i8_shl {ty} := @scalar_shl I8 ty. +Definition i16_shl {ty} := @scalar_shl I16 ty. +Definition i32_shl {ty} := @scalar_shl I32 ty. +Definition i64_shl {ty} := @scalar_shl I64 ty. +Definition i128_shl {ty} := @scalar_shl I128 ty. +Definition isize_shl {ty} := @scalar_shl Isize ty. + +(** Shift right *) +Definition u8_shr {ty} := @scalar_shr U8 ty. +Definition u16_shr {ty} := @scalar_shr U16 ty. +Definition u32_shr {ty} := @scalar_shr U32 ty. +Definition u64_shr {ty} := @scalar_shr U64 ty. +Definition u128_shr {ty} := @scalar_shr U128 ty. +Definition usize_shr {ty} := @scalar_shr Usize ty. +Definition i8_shr {ty} := @scalar_shr I8 ty. +Definition i16_shr {ty} := @scalar_shr I16 ty. +Definition i32_shr {ty} := @scalar_shr I32 ty. +Definition i64_shr {ty} := @scalar_shr I64 ty. +Definition i128_shr {ty} := @scalar_shr I128 ty. +Definition isize_shr {ty} := @scalar_shr Isize ty. + (** Small utility *) Definition usize_to_nat (x: usize) : nat := Z.to_nat (to_Z x). diff --git a/tests/fstar/array/Primitives.fst b/tests/fstar/array/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/array/Primitives.fst +++ b/tests/fstar/array/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/tests/fstar/betree/Primitives.fst b/tests/fstar/betree/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/betree/Primitives.fst +++ b/tests/fstar/betree/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/tests/fstar/betree_back_stateful/Primitives.fst b/tests/fstar/betree_back_stateful/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/betree_back_stateful/Primitives.fst +++ b/tests/fstar/betree_back_stateful/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/tests/fstar/hashmap/Primitives.fst b/tests/fstar/hashmap/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/hashmap/Primitives.fst +++ b/tests/fstar/hashmap/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/tests/fstar/hashmap_on_disk/Primitives.fst b/tests/fstar/hashmap_on_disk/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/hashmap_on_disk/Primitives.fst +++ b/tests/fstar/hashmap_on_disk/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/tests/fstar/misc/Primitives.fst b/tests/fstar/misc/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/misc/Primitives.fst +++ b/tests/fstar/misc/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) diff --git a/tests/fstar/traits/Primitives.fst b/tests/fstar/traits/Primitives.fst index 94322ead..dd340c00 100644 --- a/tests/fstar/traits/Primitives.fst +++ b/tests/fstar/traits/Primitives.fst @@ -65,6 +65,10 @@ type const_raw_ptr (t : Type0) = { v : t } (*** Scalars *) /// Rem.: most of the following code was partially generated +assume val size_numbits : pos + +// TODO: we could use FStar.Int.int_t and FStar.UInt.int_t + let isize_min : int = -9223372036854775808 // TODO: should be opaque let isize_max : int = 9223372036854775807 // TODO: should be opaque let i8_min : int = -128 @@ -108,7 +112,6 @@ let is_unsigned = function | Isize | I8 | I16 | I32 | I64 | I128 -> false | Usize | U8 | U16 | U32 | U64 | U128 -> true - let scalar_min (ty : scalar_ty) : int = match ty with | Isize -> isize_min @@ -171,7 +174,7 @@ let scalar_sub (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scala let scalar_mul (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : result (scalar ty) = mk_scalar ty (x * y) -let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) +let scalar_xor (#ty : scalar_ty) (x : scalar ty) (y : scalar ty) : scalar ty = match ty with | U8 -> FStar.UInt.logxor #8 x y @@ -179,6 +182,91 @@ let scalar_lxor (#ty : scalar_ty { is_unsigned ty && ty <> Usize }) | U32 -> FStar.UInt.logxor #32 x y | U64 -> FStar.UInt.logxor #64 x y | U128 -> FStar.UInt.logxor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logxor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logxor #16 x y + | I32 -> FStar.Int.logxor #32 x y + | I64 -> FStar.Int.logxor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logxor #128 x y + | Isize -> admit() // TODO + +let scalar_or (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logor #8 x y + | U16 -> FStar.UInt.logor #16 x y + | U32 -> FStar.UInt.logor #32 x y + | U64 -> FStar.UInt.logor #64 x y + | U128 -> FStar.UInt.logor #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logor #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logor #16 x y + | I32 -> FStar.Int.logor #32 x y + | I64 -> FStar.Int.logor #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logor #128 x y + | Isize -> admit() // TODO + +let scalar_and (#ty : scalar_ty) + (x : scalar ty) (y : scalar ty) : scalar ty = + match ty with + | U8 -> FStar.UInt.logand #8 x y + | U16 -> FStar.UInt.logand #16 x y + | U32 -> FStar.UInt.logand #32 x y + | U64 -> FStar.UInt.logand #64 x y + | U128 -> FStar.UInt.logand #128 x y + | Usize -> admit() // TODO + | I8 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 8); + normalize_spec (scalar I8); + FStar.Int.logand #8 x y + | I16 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 16); + normalize_spec (scalar I16); + FStar.Int.logand #16 x y + | I32 -> FStar.Int.logand #32 x y + | I64 -> FStar.Int.logand #64 x y + | I128 -> + // Encoding issues... + normalize_spec (FStar.Int.int_t 128); + normalize_spec (scalar I128); + FStar.Int.logand #128 x y + | Isize -> admit() // TODO + +// Shift left +let scalar_shl (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() + +// Shift right +let scalar_shr (#ty0 #ty1 : scalar_ty) + (x : scalar ty0) (y : scalar ty1) : result (scalar ty0) = + admit() (** Cast an integer from a [src_ty] to a [tgt_ty] *) // TODO: check the semantics of casts in Rust @@ -304,12 +392,75 @@ let u32_mul = scalar_mul #U32 let u64_mul = scalar_mul #U64 let u128_mul = scalar_mul #U128 -/// Logical operators, defined for unsigned types only, so far -let u8_xor = scalar_lxor #U8 -let u16_xor = scalar_lxor #U16 -let u32_xor = scalar_lxor #U32 -let u64_xor = scalar_lxor #U64 -let u128_xor = scalar_lxor #U128 +/// Xor +let u8_xor = scalar_xor #U8 +let u16_xor = scalar_xor #U16 +let u32_xor = scalar_xor #U32 +let u64_xor = scalar_xor #U64 +let u128_xor = scalar_xor #U128 +let usize_xor = scalar_xor #Usize +let i8_xor = scalar_xor #I8 +let i16_xor = scalar_xor #I16 +let i32_xor = scalar_xor #I32 +let i64_xor = scalar_xor #I64 +let i128_xor = scalar_xor #I128 +let isize_xor = scalar_xor #Isize + +/// Or +let u8_or = scalar_or #U8 +let u16_or = scalar_or #U16 +let u32_or = scalar_or #U32 +let u64_or = scalar_or #U64 +let u128_or = scalar_or #U128 +let usize_or = scalar_or #Usize +let i8_or = scalar_or #I8 +let i16_or = scalar_or #I16 +let i32_or = scalar_or #I32 +let i64_or = scalar_or #I64 +let i128_or = scalar_or #I128 +let isize_or = scalar_or #Isize + +/// And +let u8_and = scalar_and #U8 +let u16_and = scalar_and #U16 +let u32_and = scalar_and #U32 +let u64_and = scalar_and #U64 +let u128_and = scalar_and #U128 +let usize_and = scalar_and #Usize +let i8_and = scalar_and #I8 +let i16_and = scalar_and #I16 +let i32_and = scalar_and #I32 +let i64_and = scalar_and #I64 +let i128_and = scalar_and #I128 +let isize_and = scalar_and #Isize + +/// Shift left +let u8_shl #ty = scalar_shl #U8 #ty +let u16_shl #ty = scalar_shl #U16 #ty +let u32_shl #ty = scalar_shl #U32 #ty +let u64_shl #ty = scalar_shl #U64 #ty +let u128_shl #ty = scalar_shl #U128 #ty +let usize_shl #ty = scalar_shl #Usize #ty +let i8_shl #ty = scalar_shl #I8 #ty +let i16_shl #ty = scalar_shl #I16 #ty +let i32_shl #ty = scalar_shl #I32 #ty +let i64_shl #ty = scalar_shl #I64 #ty +let i128_shl #ty = scalar_shl #I128 #ty +let isize_shl #ty = scalar_shl #Isize #ty + +/// Shift right +let u8_shr #ty = scalar_shr #U8 #ty +let u16_shr #ty = scalar_shr #U16 #ty +let u32_shr #ty = scalar_shr #U32 #ty +let u64_shr #ty = scalar_shr #U64 #ty +let u128_shr #ty = scalar_shr #U128 #ty +let usize_shr #ty = scalar_shr #Usize #ty +let i8_shr #ty = scalar_shr #I8 #ty +let i16_shr #ty = scalar_shr #I16 #ty +let i32_shr #ty = scalar_shr #I32 #ty +let i64_shr #ty = scalar_shr #I64 #ty +let i128_shr #ty = scalar_shr #I128 #ty +let isize_shr #ty = scalar_shr #Isize #ty (*** core::ops *) -- cgit v1.2.3 From e732f97d09179fae43fafcb244340f98e3ca9229 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 15:53:46 +0100 Subject: Update the flake.lock --- flake.lock | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/flake.lock b/flake.lock index eedf152d..55f38cfb 100644 --- a/flake.lock +++ b/flake.lock @@ -8,11 +8,11 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1701263140, - "narHash": "sha256-rxfTrlSCGZVwcHNV+zqRk8Wh92lojYfdXWmE9oUSp0w=", + "lastModified": 1701269567, + "narHash": "sha256-3UsioCtoMv+FUPPJaR+sXnKzEnyW45Rl9FrWcNLpDE8=", "owner": "aeneasverif", "repo": "charon", - "rev": "e3718f07206e54458b3fcf0642089c32ee2381f0", + "rev": "013396662cbdb76a09c8b70cfd13606e6c6d428f", "type": "github" }, "original": { @@ -265,11 +265,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1701259400, - "narHash": "sha256-BZxLzC6mapqUUpL4SUiEy4ZqszTehcTDQRAhThDCMAY=", + "lastModified": 1701264285, + "narHash": "sha256-zquq62OOZE5aySVkFi4NnSGVY+YSTzipxLwO8umA4zo=", "owner": "leanprover", "repo": "lean4", - "rev": "4f2f704962f960c42ca2bc3ca81c4c43767b22f2", + "rev": "367ac01279e6a26e65fd8f5ca66ed43709c458ae", "type": "github" }, "original": { @@ -318,11 +318,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1701259400, - "narHash": "sha256-BZxLzC6mapqUUpL4SUiEy4ZqszTehcTDQRAhThDCMAY=", + "lastModified": 1701264285, + "narHash": "sha256-zquq62OOZE5aySVkFi4NnSGVY+YSTzipxLwO8umA4zo=", "owner": "leanprover", "repo": "lean4", - "rev": "4f2f704962f960c42ca2bc3ca81c4c43767b22f2", + "rev": "367ac01279e6a26e65fd8f5ca66ed43709c458ae", "type": "github" }, "original": { -- cgit v1.2.3 From 054d7256ed90f752ae6b39ebba608f89076d38e7 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 29 Nov 2023 17:33:52 +0100 Subject: Update the code following changes in the NameMatcher --- compiler/ExtractName.ml | 17 +++++++++++------ compiler/FunsAnalysis.ml | 2 ++ compiler/LlbcAstUtils.ml | 2 ++ compiler/TranslateCore.ml | 8 ++++++++ 4 files changed, 23 insertions(+), 6 deletions(-) diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index a916bffb..2ccd4af6 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -3,13 +3,14 @@ open Charon.NameMatcher let log = Logging.extract_log +let match_with_trait_decl_refs = true module NameMatcherMap = struct module NMM = NameMatcherMap type 'a t = 'a NMM.t - let config = { map_vars_to_vars = true } + let config = { map_vars_to_vars = true; match_with_trait_decl_refs } let find_opt (ctx : ctx) (name : Types.name) (m : 'a t) : 'a option = NMM.find_opt ctx config name m @@ -85,7 +86,9 @@ let pattern_to_trait_impl_extract_name = pattern_to_extract_name true consistent with the extraction names we derive from the Rust names *) let name_to_simple_name (ctx : ctx) (is_trait_impl : bool) (n : Types.name) : string list = - let c : to_pat_config = { tgt = TkName } in + let c : to_pat_config = + { tgt = TkName; use_trait_decl_refs = match_with_trait_decl_refs } + in pattern_to_extract_name is_trait_impl (name_to_pattern ctx c n) (** If the [prefix] is Some, we attempt to remove the common prefix @@ -93,15 +96,17 @@ let name_to_simple_name (ctx : ctx) (is_trait_impl : bool) (n : Types.name) : let name_with_generics_to_simple_name (ctx : ctx) (is_trait_impl : bool) ?(prefix : Types.name option = None) (name : Types.name) (p : Types.generic_params) (g : Types.generic_args) : string list = - let c : to_pat_config = { tgt = TkName } in - let name = name_with_generics_to_pattern ctx c name p g in + let c : to_pat_config = + { tgt = TkName; use_trait_decl_refs = match_with_trait_decl_refs } + in + let name = name_with_generics_to_pattern ctx c p name g in let name = match prefix with | None -> name | Some prefix -> let prefix = - name_with_generics_to_pattern ctx c prefix - TypesUtils.empty_generic_params TypesUtils.empty_generic_args + name_with_generics_to_pattern ctx c TypesUtils.empty_generic_params + prefix TypesUtils.empty_generic_args in let _, _, name = pattern_common_prefix prefix name in name diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 9ae6ce86..2f950083 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -62,7 +62,9 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) { type_decls = m.type_decls; global_decls = m.global_decls; + fun_decls = m.fun_decls; trait_decls = m.trait_decls; + trait_impls = m.trait_impls; } in diff --git a/compiler/LlbcAstUtils.ml b/compiler/LlbcAstUtils.ml index ffdce481..d3fac032 100644 --- a/compiler/LlbcAstUtils.ml +++ b/compiler/LlbcAstUtils.ml @@ -35,7 +35,9 @@ let crate_get_opaque_non_builtin_decls (k : crate) (filter_assumed : bool) : { type_decls = k.type_decls; global_decls = k.global_decls; + fun_decls = k.fun_decls; trait_decls = k.trait_decls; + trait_impls = k.trait_impls; } in let is_opaque_fun (d : fun_decl) : bool = diff --git a/compiler/TranslateCore.ml b/compiler/TranslateCore.ml index abf4fcf7..88438872 100644 --- a/compiler/TranslateCore.ml +++ b/compiler/TranslateCore.ml @@ -39,7 +39,9 @@ let match_name_find_opt (ctx : trans_ctx) (name : Types.name) { type_decls = ctx.type_ctx.type_decls; global_decls = ctx.global_ctx.global_decls; + fun_decls = ctx.fun_ctx.fun_decls; trait_decls = ctx.trait_decls_ctx.trait_decls; + trait_impls = ctx.trait_impls_ctx.trait_impls; } in NameMatcherMap.find_opt mctx name m @@ -52,7 +54,9 @@ let match_name_with_generics_find_opt (ctx : trans_ctx) (name : Types.name) { type_decls = ctx.type_ctx.type_decls; global_decls = ctx.global_ctx.global_decls; + fun_decls = ctx.fun_ctx.fun_decls; trait_decls = ctx.trait_decls_ctx.trait_decls; + trait_impls = ctx.trait_impls_ctx.trait_impls; } in NameMatcherMap.find_with_generics_opt mctx name generics m @@ -62,7 +66,9 @@ let name_to_simple_name (ctx : trans_ctx) (n : Types.name) : string list = { type_decls = ctx.type_ctx.type_decls; global_decls = ctx.global_ctx.global_decls; + fun_decls = ctx.fun_ctx.fun_decls; trait_decls = ctx.trait_decls_ctx.trait_decls; + trait_impls = ctx.trait_impls_ctx.trait_impls; } in let is_trait_impl = false in @@ -75,7 +81,9 @@ let trait_name_with_generics_to_simple_name (ctx : trans_ctx) { type_decls = ctx.type_ctx.type_decls; global_decls = ctx.global_ctx.global_decls; + fun_decls = ctx.fun_ctx.fun_decls; trait_decls = ctx.trait_decls_ctx.trait_decls; + trait_impls = ctx.trait_impls_ctx.trait_impls; } in let is_trait_impl = true in -- cgit v1.2.3 From 60ce69b83cbd749781543bb16becb5357f0e1a0a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 5 Dec 2023 15:00:46 +0100 Subject: Update following changes in Charon --- compiler/AssociatedTypes.ml | 28 +- compiler/Assumed.ml | 8 +- compiler/Contexts.ml | 2 +- compiler/ExtractBase.ml | 2 +- compiler/ExtractName.ml | 4 +- compiler/FunsAnalysis.ml | 53 +- compiler/Interpreter.ml | 4 +- compiler/InterpreterBorrows.ml | 8 +- compiler/InterpreterExpressions.ml | 1 + compiler/InterpreterLoopsFixedPoint.ml | 2 +- compiler/InterpreterLoopsMatchCtxs.ml | 10 +- compiler/InterpreterStatements.ml | 796 +++++++++++---------- compiler/InterpreterUtils.ml | 8 +- compiler/LlbcAst.ml | 4 +- compiler/Print.ml | 25 +- compiler/PrintPure.ml | 5 +- compiler/RegionsHierarchy.ml | 66 +- compiler/Substitute.ml | 120 +++- compiler/SymbolicToPure.ml | 56 +- compiler/Translate.ml | 2 +- compiler/TypesAnalysis.ml | 2 +- compiler/TypesUtils.ml | 16 +- tests/coq/betree/BetreeMain_Funs.v | 46 +- tests/coq/misc/NoNestedBorrows.v | 204 ++++-- tests/coq/misc/_CoqProject | 2 +- tests/fstar/betree/BetreeMain.Clauses.Template.fst | 14 +- tests/fstar/betree/BetreeMain.Funs.fst | 32 +- .../BetreeMain.Clauses.Template.fst | 14 +- .../fstar/betree_back_stateful/BetreeMain.Funs.fst | 32 +- tests/fstar/misc/NoNestedBorrows.fst | 202 ++++-- tests/lean/BetreeMain/Funs.lean | 30 +- tests/lean/NoNestedBorrows.lean | 204 ++++-- 32 files changed, 1176 insertions(+), 826 deletions(-) diff --git a/compiler/AssociatedTypes.ml b/compiler/AssociatedTypes.ml index 2442f93a..e2f687e8 100644 --- a/compiler/AssociatedTypes.ml +++ b/compiler/AssociatedTypes.ml @@ -92,7 +92,8 @@ let ctx_add_norm_trait_types_from_preds (ctx : eval_ctx) let rec trait_instance_id_is_local_clause (id : trait_instance_id) : bool = match id with | Self | Clause _ -> true - | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ -> + | TraitImpl _ | BuiltinOrAuto _ | TraitRef _ | UnknownTrait _ | FnPointer _ + | Closure _ -> false | ParentClause (id, _, _) | ItemClause (id, _, _, _) -> trait_instance_id_is_local_clause id @@ -118,13 +119,10 @@ let norm_ctx_to_fmt_env (ctx : norm_ctx) : Print.fmt_env = global_decls = ctx.global_decls; trait_decls = ctx.trait_decls; trait_impls = ctx.trait_impls; - generics = - { - types = ctx.type_vars; - const_generics = ctx.const_generic_vars; - regions = []; - trait_clauses = []; - }; + types = ctx.type_vars; + const_generics = ctx.const_generic_vars; + regions = []; + trait_clauses = []; preds = empty_predicates; locals = []; } @@ -220,10 +218,13 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty = | TRawPtr (ty, rkind) -> let ty = norm_ctx_normalize_ty ctx ty in TRawPtr (ty, rkind) - | TArrow (inputs, output) -> + | TArrow (regions, inputs, output) -> + (* TODO: for now it works because we don't support predicates with + bound regions. If we do support them, we probably need to do + something smarter here. *) let inputs = List.map (norm_ctx_normalize_ty ctx) inputs in let output = norm_ctx_normalize_ty ctx output in - TArrow (inputs, output) + TArrow (regions, inputs, output) | TTraitType (trait_ref, generics, type_name) -> ( log#ldebug (lazy @@ -429,6 +430,9 @@ and norm_ctx_normalize_trait_instance_id (ctx : norm_ctx) (* 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) + | Closure (fid, generics) -> + let generics = norm_ctx_normalize_generic_args ctx generics in + (Closure (fid, generics), None) | UnknownTrait _ -> (* This is actually an error case *) (id, None) @@ -562,11 +566,11 @@ let ctx_adt_get_inst_norm_field_etypes (ctx : eval_ctx) (def_id : TypeDeclId.id) (** Same as [substitute_signature] but normalizes the types *) let ctx_subst_norm_signature (ctx : eval_ctx) (asubst : RegionGroupId.id -> AbstractionId.id) - (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) + (r_subst : RegionVarId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) (cg_subst : ConstGenericVarId.id -> const_generic) (tr_subst : TraitClauseId.id -> trait_instance_id) (tr_self : trait_instance_id) (sg : fun_sig) - (regions_hierarchy : region_groups) : inst_fun_sig = + (regions_hierarchy : region_var_groups) : inst_fun_sig = let sg = Subst.substitute_signature asubst r_subst ty_subst cg_subst tr_subst tr_self sg regions_hierarchy diff --git a/compiler/Assumed.ml b/compiler/Assumed.ml index 48b7ee2b..1807add5 100644 --- a/compiler/Assumed.ml +++ b/compiler/Assumed.ml @@ -36,8 +36,8 @@ open LlbcAst module Sig = struct (** A few utilities *) - let rvar_id_0 = RegionId.of_int 0 - let rvar_0 : region = RVar rvar_id_0 + let rvar_id_0 = RegionVarId.of_int 0 + let rvar_0 : region = RBVar (0, rvar_id_0) let rg_id_0 = RegionGroupId.of_int 0 let tvar_id_0 = TypeVarId.of_int 0 let tvar_0 : ty = TVar tvar_id_0 @@ -48,7 +48,7 @@ module Sig = struct let region_param_0 : region_var = { index = rvar_id_0; name = Some "'a" } (** Region group: [{ parent={}; regions:{'a of id 0} }] *) - let region_group_0 : region_group = + let region_group_0 : region_var_group = { id = rg_id_0; regions = [ rvar_id_0 ]; parents = [] } (** Type parameter [T] of id 0 *) @@ -84,6 +84,8 @@ module Sig = struct in { is_unsafe = false; + is_closure = false; + closure_info = None; generics; preds; parent_params_info = None; diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index c93bb213..bbfd31e6 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -190,7 +190,7 @@ type type_context = { type fun_context = { fun_decls : fun_decl FunDeclId.Map.t; fun_infos : FunsAnalysis.fun_info FunDeclId.Map.t; - regions_hierarchies : region_groups FunIdMap.t; + regions_hierarchies : region_var_groups FunIdMap.t; } [@@deriving show] diff --git a/compiler/ExtractBase.ml b/compiler/ExtractBase.ml index 73ccac44..43658b6e 100644 --- a/compiler/ExtractBase.ml +++ b/compiler/ExtractBase.ml @@ -1984,7 +1984,7 @@ let ctx_compute_fun_name (trans_group : pure_fun_translation) (def : fun_decl) let rg = T.RegionGroupId.nth regions_hierarchy rg_id in let region_names = List.map - (fun rid -> (T.RegionId.nth sg.generics.regions rid).name) + (fun rid -> (T.RegionVarId.nth sg.generics.regions rid).name) rg.regions in Some { id = rg_id; region_names } diff --git a/compiler/ExtractName.ml b/compiler/ExtractName.ml index 2ccd4af6..4c1ffb46 100644 --- a/compiler/ExtractName.ml +++ b/compiler/ExtractName.ml @@ -62,7 +62,7 @@ let pattern_to_extract_name (is_trait_impl : bool) (name : pattern) : | TArray -> "Array" | TSlice -> "Slice" else expr_to_string c ty - | ERef _ | EVar _ -> + | ERef _ | EVar _ | EArrow _ | ERawPtr _ -> (* We simply convert the pattern to a string. This is not very satisfying but we should rarely get there. *) expr_to_string c ty) @@ -108,7 +108,7 @@ let name_with_generics_to_simple_name (ctx : ctx) (is_trait_impl : bool) name_with_generics_to_pattern ctx c TypesUtils.empty_generic_params prefix TypesUtils.empty_generic_args in - let _, _, name = pattern_common_prefix prefix name in + let _, _, name = pattern_common_prefix { equiv = true } prefix name in name in pattern_to_extract_name is_trait_impl name diff --git a/compiler/FunsAnalysis.ml b/compiler/FunsAnalysis.ml index 2f950083..f6976f23 100644 --- a/compiler/FunsAnalysis.ml +++ b/compiler/FunsAnalysis.ml @@ -86,6 +86,16 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) method may_fail b = can_fail := !can_fail || b method maybe_stateful b = stateful := !stateful || b + method visit_fid id = + if FunDeclId.Set.mem id fun_ids then ( + can_diverge := true; + is_rec := true) + else + let info = FunDeclId.Map.find id !infos in + self#may_fail info.can_fail; + stateful := !stateful || info.stateful; + can_diverge := !can_diverge || info.can_diverge + method! visit_Assert env a = self#may_fail true; super#visit_Assert env a @@ -97,25 +107,32 @@ let analyze_module (m : crate) (funs_map : fun_decl FunDeclId.Map.t) | BinaryOp (bop, _, _) -> can_fail := binop_can_fail bop || !can_fail + method! visit_Closure env id args = + (* Remark: `Closure` is a trait instance id - TODO: rename this variant *) + self#visit_fid id; + super#visit_Closure env id args + + method! visit_AggregatedClosure env id args = + self#visit_fid id; + super#visit_AggregatedClosure env id args + method! visit_Call env call = - (match call.func.func with - | FunId (FRegular id) -> - if FunDeclId.Set.mem id fun_ids then ( - can_diverge := true; - is_rec := true) - else - let info = FunDeclId.Map.find id !infos in - self#may_fail info.can_fail; - stateful := !stateful || info.stateful; - can_diverge := !can_diverge || info.can_diverge - | FunId (FAssumed id) -> - (* None of the assumed functions can diverge nor are considered stateful *) - can_fail := !can_fail || Assumed.assumed_fun_can_fail id - | TraitMethod _ -> - (* 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); + (match call.func with + | FnOpMove _ -> + (* Ignoring this: we lookup the called function upon creating + the closure *) + () + | FnOpRegular func -> ( + match func.func with + | FunId (FRegular id) -> self#visit_fid id + | FunId (FAssumed id) -> + (* None of the assumed functions can diverge nor are considered stateful *) + can_fail := !can_fail || Assumed.assumed_fun_can_fail id + | TraitMethod _ -> + (* 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/Interpreter.ml b/compiler/Interpreter.ml index c2e47da9..4ecafd31 100644 --- a/compiler/Interpreter.ml +++ b/compiler/Interpreter.ml @@ -68,7 +68,7 @@ let normalize_inst_fun_sig (ctx : eval_ctx) (sg : inst_fun_sig) : inst_fun_sig = normalize because a trait clause was instantiated with a specific trait ref). *) let symbolic_instantiate_fun_sig (ctx : eval_ctx) (sg : fun_sig) - (regions_hierarchy : region_groups) (kind : fun_kind) : + (regions_hierarchy : region_var_groups) (kind : fun_kind) : eval_ctx * inst_fun_sig = let tr_self = match kind with @@ -192,7 +192,7 @@ let initialize_symbolic_context_for_fun (ctx : decls_ctx) (fdef : fun_decl) : FunIdMap.find (FRegular fdef.def_id) ctx.fun_ctx.regions_hierarchies in let region_groups = - List.map (fun (g : region_group) -> g.id) regions_hierarchy + List.map (fun (g : region_var_group) -> g.id) regions_hierarchy in let ctx = initialize_eval_context ctx region_groups sg.generics.types diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 2f793f4a..be556ade 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1870,7 +1870,7 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) match bc with | VSharedBorrow bid -> assert (ty_no_regions ref_ty); - let ty = TRef (RVar r_id, ref_ty, kind) in + let ty = TRef (RFVar r_id, ref_ty, kind) in let value = ABorrow (ASharedBorrow bid) in ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> @@ -1878,7 +1878,7 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) (* We don't support nested borrows for now *) assert (not (value_has_borrows ctx bv.value)); (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) - let ty = TRef (RVar r_id, ref_ty, kind) in + let ty = TRef (RFVar r_id, ref_ty, kind) in let ignored = mk_aignored ref_ty in let av = ABorrow (AMutBorrow (bid, ignored)) in let av = { value = av; ty } in @@ -1899,7 +1899,7 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (RVar r_id) ty RShared in + let ty = mk_ref_ty (RFVar r_id) ty RShared in let ignored = mk_aignored ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in @@ -1917,7 +1917,7 @@ let convert_value_to_abstractions (abs_kind : abs_kind) (can_end : bool) (* Push the avalue - note that we use [AIgnore] for the inner avalue *) (* For avalues, a loan has the borrow type *) assert (ty_no_regions ty); - let ty = mk_ref_ty (RVar r_id) ty RMut in + let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored ty in let av = ALoan (AMutLoan (bid, ignored)) in let av = { value = av; ty } in diff --git a/compiler/InterpreterExpressions.ml b/compiler/InterpreterExpressions.ml index ac6c9ede..eeb6ae1e 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -761,6 +761,7 @@ let eval_rvalue_aggregate (config : config) (aggregate_kind : aggregate_kind) (* Introduce the symbolic value in the AST *) let sv = ValuesUtils.value_as_symbolic saggregated.value in Some (SymbolicAst.IntroSymbolic (ctx, None, sv, VaArray values, e))) + | AggregatedClosure _ -> raise (Failure "Closures are not supported yet") in (* Compose and apply *) comp eval_ops compute cf diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 3cc0a5f0..c4e180fa 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -164,7 +164,7 @@ let prepare_ashared_loans (loop_id : LoopId.id option) : cm_fun = let child_av = mk_aignored child_rty in (* Create the shared loan *) - let loan_rty = TRef (RVar nrid, rty, RShared) in + let loan_rty = TRef (RFVar nrid, rty, RShared) in let loan_value = ALoan (ASharedLoan (BorrowId.Set.singleton nlid, nsv, child_av)) in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index bf459e41..c21dab71 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -439,7 +439,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin bv_ty in - let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) : typed_avalue = @@ -537,7 +537,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let kind = RMut in let bv_ty = bv.ty in assert (ty_no_regions bv_ty); - let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in let borrow_av = let ty = borrow_ty in @@ -586,7 +586,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct mk_fresh_symbolic_typed_value_from_no_regions_ty LoopJoin bv_ty in - let borrow_ty = mk_ref_ty (RVar rid) bv_ty kind in + let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) (bv : typed_value) : typed_avalue = @@ -825,9 +825,9 @@ struct let match_regions r0 r1 = match (r0, r1) with | RStatic, RStatic -> r1 - | RVar rid0, RVar rid1 -> + | RFVar rid0, RFVar rid1 -> let rid = match_rid rid0 rid1 in - RVar rid + RFVar rid | _ -> raise (Distinct "match_rtys") in match_types match_distinct_types match_regions ty0 ty1 diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index 9ea5387f..437b358a 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -493,77 +493,84 @@ let eval_box_free (config : config) (generics : generic_args) (** Evaluate a non-local function call in concrete mode *) let eval_assumed_function_call_concrete (config : config) (fid : assumed_fun_id) (call : call) : cm_fun = - let generics = call.func.generics in let args = call.args in let dest = call.dest in - (* Sanity check: we don't fully handle the const generic vars environment - in concrete mode yet *) - assert (generics.const_generics = []); - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See {!eval_box_free} - *) - match fid with - | BoxFree -> - (* Degenerate case: box_free *) - eval_box_free config generics args dest - | _ -> - (* "Normal" case: not box_free *) - (* Evaluate the operands *) - (* let ctx, args_vl = eval_operands config ctx args in *) - let cf_eval_ops = eval_operands config args in - - (* Evaluate the call - * - * Style note: at some point we used {!comp_transmit} to - * transmit the result of {!eval_operands} above down to {!push_vars} - * below, without having to introduce an intermediary function call, - * but it made it less clear where the computed values came from, - * so we reversed the modifications. *) - let cf_eval_call cf (args_vl : 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 = VarId.zero in - let ret_ty = get_assumed_function_return_type ctx fid generics in - let ret_var = mk_var ret_vid (Some "@return") ret_ty in - let cc = comp cc (push_uninitialized_var ret_var) in - - (* Create and push the input variables *) - let input_vars = - VarId.mapi_from1 - (fun id (v : typed_value) -> (mk_var id None v.ty, v)) - args_vl - in - let cc = comp cc (push_vars input_vars) in - - (* "Execute" the function body. As the functions are assumed, here we call - * custom functions to perform the proper manipulations: we don't have - * access to a body. *) - let cf_eval_body : cm_fun = - match fid with - | BoxNew -> eval_box_new_concrete config generics - | BoxFree -> - (* Should have been treated above *) raise (Failure "Unreachable") - | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared - | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut -> - raise (Failure "Unimplemented") - in + match call.func with + | FnOpMove _ -> + (* Closure case: TODO *) + raise (Failure "Closures are not supported yet") + | FnOpRegular func -> ( + let generics = func.generics in + (* Sanity check: we don't fully handle the const generic vars environment + in concrete mode yet *) + assert (generics.const_generics = []); + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See {!eval_box_free} + *) + match fid with + | BoxFree -> + (* Degenerate case: box_free *) + eval_box_free config generics args dest + | _ -> + (* "Normal" case: not box_free *) + (* Evaluate the operands *) + (* let ctx, args_vl = eval_operands config ctx args in *) + let cf_eval_ops = eval_operands config args in + + (* Evaluate the call + * + * Style note: at some point we used {!comp_transmit} to + * transmit the result of {!eval_operands} above down to {!push_vars} + * below, without having to introduce an intermediary function call, + * but it made it less clear where the computed values came from, + * so we reversed the modifications. *) + let cf_eval_call cf (args_vl : 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 = VarId.zero in + let ret_ty = get_assumed_function_return_type ctx fid generics in + let ret_var = mk_var ret_vid (Some "@return") ret_ty in + let cc = comp cc (push_uninitialized_var ret_var) in + + (* Create and push the input variables *) + let input_vars = + VarId.mapi_from1 + (fun id (v : typed_value) -> (mk_var id None v.ty, v)) + args_vl + in + let cc = comp cc (push_vars input_vars) in + + (* "Execute" the function body. As the functions are assumed, here we call + * custom functions to perform the proper manipulations: we don't have + * access to a body. *) + let cf_eval_body : cm_fun = + match fid with + | BoxNew -> eval_box_new_concrete config generics + | BoxFree -> + (* Should have been treated above *) + raise (Failure "Unreachable") + | ArrayIndexShared | ArrayIndexMut | ArrayToSliceShared + | ArrayToSliceMut | ArrayRepeat | SliceIndexShared | SliceIndexMut + -> + raise (Failure "Unimplemented") + in - let cc = comp cc cf_eval_body in + let cc = comp cc cf_eval_body in - (* Pop the frame *) - let cc = comp cc (pop_frame_assign config dest) in + (* Pop the frame *) + let cc = comp cc (pop_frame_assign config dest) in - (* Continue *) - cc cf ctx - in - (* Compose and apply *) - comp cf_eval_ops cf_eval_call + (* Continue *) + cc cf ctx + in + (* Compose and apply *) + comp cf_eval_ops cf_eval_call) (** Helper @@ -652,6 +659,240 @@ let create_push_abstractions_from_abs_region_groups in List.fold_left insert_abs ctx empty_absl +(** Auxiliary helper for [eval_transparent_function_call_symbolic] + 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. + + 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 (Self : Type) = { + has_value : Self -> result bool + } + + let OptionHasValueImpl.has_value (Self : Type) (self : Self) : 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 + ]} + + # 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 eval_transparent_function_call_symbolic_inst (call : call) (ctx : eval_ctx) + : fun_id_or_trait_method_ref * generic_args * fun_decl * inst_fun_sig = + match call.func with + | FnOpMove _ -> + (* Closure case: TODO *) + raise (Failure "Closures are not supported yet") + | FnOpRegular func -> ( + match func.func with + | FunId (FRegular fid) -> + let def = ctx_lookup_fun_decl ctx fid in + log#ldebug + (lazy + ("fun call:\n- call: " ^ call_to_string ctx call + ^ "\n- call.generics:\n" + ^ generic_args_to_string ctx func.generics + ^ "\n- def.signature:\n" + ^ fun_sig_to_string ctx def.signature)); + let tr_self = UnknownTrait __FUNCTION__ in + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular fid) + ctx.fun_context.regions_hierarchies + in + let inst_sg = + instantiate_fun_sig ctx func.generics tr_self def.signature + regions_hierarchy + in + (func.func, func.generics, def, inst_sg) + | FunId (FAssumed _) -> + (* Unreachable: must be a transparent function *) + raise (Failure "Unreachable") + | 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" + ^ generic_args_to_string ctx func.generics + ^ "\n- trait and method generics:\n" + ^ generic_args_to_string ctx + (Option.get 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 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 *) + match trait_ref.trait_id with + | TraitImpl impl_id -> ( + (* Lookup the trait impl *) + let trait_impl = ctx_lookup_trait_impl ctx impl_id in + log#ldebug + (lazy ("trait impl: " ^ trait_impl_to_string ctx trait_impl)); + (* First look in the required methods *) + let method_id = + List.find_opt + (fun (s, _) -> s = method_name) + trait_impl.required_methods + in + match method_id with + | Some (_, id) -> + (* This is a required method *) + let method_def = ctx_lookup_fun_decl ctx id in + (* Instantiate *) + let tr_self = TraitRef trait_ref in + let fid : fun_id = FRegular id in + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find fid + ctx.fun_context.regions_hierarchies + in + let inst_sg = + instantiate_fun_sig ctx generics tr_self + method_def.signature regions_hierarchy + in + (* Also update the function identifier: we want to forget + the fact that we called a trait method, and treat it as + 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 = FunId fid in + (func, generics, method_def, inst_sg) + | None -> + (* If not found, lookup the methods provided by the trait *declaration* + (remember: for now, we forbid overriding provided methods) *) + assert (trait_impl.provided_methods = []); + let trait_decl = + 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 = ctx_lookup_fun_decl ctx method_id in + (* For the instantiation we have to do something peculiar + because the method was defined for the trait declaration. + We have to group: + - 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 all_generics = + TypesUtils.merge_generic_args + trait_ref.trait_decl_ref.decl_generics func.generics + in + log#ldebug + (lazy + ("provided method call:" ^ "\n- method name: " + ^ method_name ^ "\n- all_generics:\n" + ^ generic_args_to_string ctx all_generics + ^ "\n- parent params info: " + ^ Print.option_to_string show_params_info + method_def.signature.parent_params_info)); + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular method_id) + ctx.fun_context.regions_hierarchies + in + let tr_self = TraitRef trait_ref in + let inst_sg = + instantiate_fun_sig ctx all_generics tr_self + method_def.signature regions_hierarchy + in + (func.func, func.generics, method_def, inst_sg)) + | _ -> + (* We are using a local clause - we lookup the trait decl *) + let trait_decl = + ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id + in + (* Lookup the method decl in the required *and* the provided methods *) + let _, method_id = + 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) + (List.append trait_decl.required_methods provided) + in + let method_def = ctx_lookup_fun_decl ctx method_id in + log#ldebug + (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); + (* Instantiate *) + let regions_hierarchy = + LlbcAstUtils.FunIdMap.find (FRegular method_id) + ctx.fun_context.regions_hierarchies + in + let tr_self = TraitRef trait_ref in + let inst_sg = + instantiate_fun_sig ctx generics tr_self method_def.signature + regions_hierarchy + in + (func.func, func.generics, method_def, inst_sg))) + (** Evaluate a statement *) let rec eval_statement (config : config) (st : statement) : st_cm_fun = fun cf ctx -> @@ -761,7 +1002,7 @@ and eval_global (config : config) (dest : place) (gid : GlobalDeclId.id) : trait_and_method_generic_args = None; } in - let call = { func; args = []; dest } in + let call = { func = FnOpRegular func; args = []; dest } in (eval_transparent_function_call_concrete config global.body call) cf ctx | SymbolicMode -> (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be @@ -915,337 +1156,126 @@ and eval_function_call (config : config) (call : call) : st_cm_fun = and eval_function_call_concrete (config : config) (call : call) : st_cm_fun = fun cf ctx -> - match call.func.func with - | FunId (FRegular fid) -> - eval_transparent_function_call_concrete config fid call cf ctx - | FunId (FAssumed fid) -> - (* Continue - note that we do as if the function call has been successful, - * by giving {!Unit} to the continuation, because we place us in the case - * where we haven't panicked. Of course, the translation needs to take the - * panic case into account... *) - eval_assumed_function_call_concrete config fid call (cf Unit) ctx - | TraitMethod _ -> raise (Failure "Unimplemented") + match call.func with + | FnOpMove _ -> raise (Failure "Closures are not supported yet") + | FnOpRegular func -> ( + match func.func with + | FunId (FRegular fid) -> + eval_transparent_function_call_concrete config fid call cf ctx + | FunId (FAssumed fid) -> + (* Continue - note that we do as if the function call has been successful, + * by giving {!Unit} to the continuation, because we place us in the case + * where we haven't panicked. Of course, the translation needs to take the + * panic case into account... *) + eval_assumed_function_call_concrete config fid call (cf Unit) ctx + | TraitMethod _ -> raise (Failure "Unimplemented")) and eval_function_call_symbolic (config : config) (call : call) : st_cm_fun = - match call.func.func with - | FunId (FRegular _) | TraitMethod _ -> - eval_transparent_function_call_symbolic config call - | FunId (FAssumed fid) -> eval_assumed_function_call_symbolic config fid call + match call.func with + | FnOpMove _ -> raise (Failure "Closures are not supported yet") + | FnOpRegular func -> ( + match func.func with + | FunId (FRegular _) | TraitMethod _ -> + eval_transparent_function_call_symbolic config call + | FunId (FAssumed fid) -> + eval_assumed_function_call_symbolic config fid call func) (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) and eval_transparent_function_call_concrete (config : config) (fid : FunDeclId.id) (call : call) : st_cm_fun = - let generics = call.func.generics in let args = call.args in let dest = call.dest in - (* Sanity check: we don't fully handle the const generic vars environment - in concrete mode yet *) - assert (generics.const_generics = []); - fun cf ctx -> - (* Retrieve the (correctly instantiated) body *) - let def = 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: " - ^ name_to_string ctx def.name)) - | Some body -> body - in - (* TODO: we need to normalize the types if we want to correctly support traits *) - assert (generics.trait_refs = []); - (* There shouldn't be any reference to Self *) - let tr_self = UnknownTrait __FUNCTION__ in - let subst = - Subst.make_subst_from_generics def.signature.generics generics tr_self - in - let locals, body_st = Subst.fun_body_substitute_in_body subst body in - - (* Evaluate the input operands *) - assert (List.length args = body.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.arg_count - in + match call.func with + | FnOpMove _ -> raise (Failure "Closures are not supported yet") + | FnOpRegular func -> + let generics = func.generics in + (* Sanity check: we don't fully handle the const generic vars environment + in concrete mode yet *) + assert (generics.const_generics = []); + fun cf ctx -> + (* Retrieve the (correctly instantiated) body *) + let def = 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: " + ^ name_to_string ctx def.name)) + | Some body -> body + in + (* TODO: we need to normalize the types if we want to correctly support traits *) + assert (generics.trait_refs = []); + (* There shouldn't be any reference to Self *) + let tr_self = UnknownTrait __FUNCTION__ in + let subst = + Subst.make_subst_from_generics def.signature.generics generics tr_self + in + let locals, body_st = Subst.fun_body_substitute_in_body subst body in + + (* Evaluate the input operands *) + assert (List.length args = body.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.arg_count + in - let cc = comp_transmit cc (push_var ret_var (mk_bottom ret_var.var_ty)) 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 - - (* 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 + (* 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 - (* Continue *) - cc cf ctx + (* 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 (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) and eval_transparent_function_call_symbolic (config : config) (call : call) : st_cm_fun = fun cf ctx -> - (* Instantiate the signature and introduce fresh abstractions and region ids while doing so. - - 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. - - 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 (Self : Type) = { - has_value : Self -> result bool - } - - let OptionHasValueImpl.has_value (Self : Type) (self : Self) : 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 - ]} - - # 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, inst_sg = - match call.func.func with - | FunId (FRegular fid) -> - let def = ctx_lookup_fun_decl ctx fid in - log#ldebug - (lazy - ("fun call:\n- call: " ^ call_to_string ctx call - ^ "\n- call.generics:\n" - ^ generic_args_to_string ctx call.func.generics - ^ "\n- def.signature:\n" - ^ fun_sig_to_string ctx def.signature)); - let tr_self = UnknownTrait __FUNCTION__ in - let regions_hierarchy = - LlbcAstUtils.FunIdMap.find (FRegular fid) - ctx.fun_context.regions_hierarchies - in - let inst_sg = - instantiate_fun_sig ctx call.func.generics tr_self def.signature - regions_hierarchy - in - (call.func.func, call.func.generics, def, inst_sg) - | FunId (FAssumed _) -> - (* Unreachable: must be a transparent function *) - raise (Failure "Unreachable") - | 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" - ^ generic_args_to_string ctx call.func.generics - ^ "\n- trait and method generics:\n" - ^ generic_args_to_string ctx - (Option.get call.func.trait_and_method_generic_args))); - (* When instantiating, we need to group the generics for the trait ref - and the method *) - 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 *) - match trait_ref.trait_id with - | TraitImpl impl_id -> ( - (* Lookup the trait impl *) - let trait_impl = ctx_lookup_trait_impl ctx impl_id in - log#ldebug - (lazy ("trait impl: " ^ trait_impl_to_string ctx trait_impl)); - (* First look in the required methods *) - let method_id = - List.find_opt - (fun (s, _) -> s = method_name) - trait_impl.required_methods - in - match method_id with - | Some (_, id) -> - (* This is a required method *) - let method_def = ctx_lookup_fun_decl ctx id in - (* Instantiate *) - let tr_self = TraitRef trait_ref in - let fid : fun_id = FRegular id in - let regions_hierarchy = - LlbcAstUtils.FunIdMap.find fid - ctx.fun_context.regions_hierarchies - in - let inst_sg = - instantiate_fun_sig ctx generics tr_self method_def.signature - regions_hierarchy - in - (* Also update the function identifier: we want to forget - the fact that we called a trait method, and treat it as - 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 = FunId fid in - (func, generics, method_def, inst_sg) - | None -> - (* If not found, lookup the methods provided by the trait *declaration* - (remember: for now, we forbid overriding provided methods) *) - assert (trait_impl.provided_methods = []); - let trait_decl = - 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 = ctx_lookup_fun_decl ctx method_id in - (* For the instantiation we have to do something peculiar - because the method was defined for the trait declaration. - We have to group: - - 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 all_generics = - TypesUtils.merge_generic_args - trait_ref.trait_decl_ref.decl_generics call.func.generics - in - log#ldebug - (lazy - ("provided method call:" ^ "\n- method name: " ^ method_name - ^ "\n- all_generics:\n" - ^ generic_args_to_string ctx all_generics - ^ "\n- parent params info: " - ^ Print.option_to_string show_params_info - method_def.signature.parent_params_info)); - let regions_hierarchy = - LlbcAstUtils.FunIdMap.find (FRegular method_id) - ctx.fun_context.regions_hierarchies - in - let tr_self = TraitRef trait_ref in - let inst_sg = - instantiate_fun_sig ctx all_generics tr_self - method_def.signature regions_hierarchy - in - (call.func.func, call.func.generics, method_def, inst_sg)) - | _ -> - (* We are using a local clause - we lookup the trait decl *) - let trait_decl = - ctx_lookup_trait_decl ctx trait_ref.trait_decl_ref.trait_decl_id - in - (* Lookup the method decl in the required *and* the provided methods *) - let _, method_id = - 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) - (List.append trait_decl.required_methods provided) - in - let method_def = ctx_lookup_fun_decl ctx method_id in - log#ldebug (lazy ("method:\n" ^ fun_decl_to_string ctx method_def)); - (* Instantiate *) - let regions_hierarchy = - LlbcAstUtils.FunIdMap.find (FRegular method_id) - ctx.fun_context.regions_hierarchies - in - let tr_self = TraitRef trait_ref in - let inst_sg = - instantiate_fun_sig ctx generics tr_self method_def.signature - regions_hierarchy - in - (call.func.func, call.func.generics, method_def, inst_sg)) + eval_transparent_function_call_symbolic_inst call ctx in (* Sanity check *) assert (List.length call.args = List.length def.signature.inputs); @@ -1408,9 +1438,9 @@ and eval_function_call_symbolic_from_inst_sig (config : config) (** Evaluate a non-local function call in symbolic mode *) and eval_assumed_function_call_symbolic (config : config) (fid : assumed_fun_id) - (call : call) : st_cm_fun = + (call : call) (func : fn_ptr) : st_cm_fun = fun cf ctx -> - let generics = call.func.generics in + let generics = func.generics in let args = call.args in let dest = call.dest in (* Sanity check: make sure the type parameters don't contain regions - diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index bba88e9f..612d6903 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -455,7 +455,7 @@ let initialize_eval_context (ctx : decls_ctx) *) let instantiate_fun_sig (ctx : eval_ctx) (generics : generic_args) (tr_self : trait_instance_id) (sg : fun_sig) - (regions_hierarchy : region_groups) : inst_fun_sig = + (regions_hierarchy : region_var_groups) : inst_fun_sig = log#ldebug (lazy ("instantiate_fun_sig:" ^ "\n- generics: " @@ -484,7 +484,11 @@ let instantiate_fun_sig (ctx : eval_ctx) (generics : generic_args) RegionGroupId.Map.find rg_id asubst_map in (* Generate fresh regions and their substitutions *) - let _, rsubst, _ = Substitute.fresh_regions_with_substs sg.generics.regions in + let _, rsubst, _ = + Substitute.fresh_regions_with_substs_from_vars ~fail_if_not_found:true + sg.generics.regions + in + let rsubst r = Option.get (rsubst r) in (* Generate the type substitution Note that for now we don't support instantiating the type parameters with types containing regions. *) diff --git a/compiler/LlbcAst.ml b/compiler/LlbcAst.ml index 9772671e..e071b36f 100644 --- a/compiler/LlbcAst.ml +++ b/compiler/LlbcAst.ml @@ -2,7 +2,9 @@ open Types open Values include Charon.LlbcAst -type abs_region_group = AbstractionId.id g_region_group [@@deriving show] +type abs_region_group = (RegionId.id, AbstractionId.id) g_region_group +[@@deriving show] + type abs_region_groups = abs_region_group list [@@deriving show] (** A function signature, after instantiation *) diff --git a/compiler/Print.ml b/compiler/Print.ml index 92ce6f23..0e2ec1fc 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -393,7 +393,6 @@ module Contexts = struct let global_decls = ctx.global_ctx.global_decls in let trait_decls = ctx.trait_decls_ctx.trait_decls in let trait_impls = ctx.trait_impls_ctx.trait_impls in - let generics = TypesUtils.empty_generic_params in let preds = TypesUtils.empty_predicates in { type_decls; @@ -401,7 +400,10 @@ module Contexts = struct global_decls; trait_decls; trait_impls; - generics; + regions = []; + types = []; + const_generics = []; + trait_clauses = []; preds; locals = []; } @@ -415,16 +417,6 @@ module Contexts = struct (* Below: it is always safe to omit fields - if an id can't be found at printing time, we print the id (in raw form) instead of the name it designates. *) - let generics : generic_params = - { - types = ctx.type_vars; - (* The regions have been transformed to region groups *) - regions = []; - const_generics = ctx.const_generic_vars; - (* We don't need the trait clauses so we initialize them to empty *) - trait_clauses = []; - } - in (* We don't need the predicates so we initialize them to empty *) let preds = empty_predicates in (* For the locals: we retrieve the information from the environment. @@ -444,7 +436,12 @@ module Contexts = struct global_decls; trait_decls; trait_impls; - generics; + types = ctx.type_vars; + (* The regions have been transformed to region groups *) + regions = []; + const_generics = ctx.const_generic_vars; + (* We don't need the trait clauses so we initialize them to empty *) + trait_clauses = []; preds; locals; } @@ -596,7 +593,7 @@ module EvalCtx = struct let fun_id_or_trait_method_ref_to_string (ctx : eval_ctx) (x : fun_id_or_trait_method_ref) : string = let env = eval_ctx_to_fmt_env ctx in - fun_id_or_trait_method_ref_to_string env x "..." + fun_id_or_trait_method_ref_to_string env x let statement_to_string (ctx : eval_ctx) (indent : string) (indent_incr : string) (e : statement) : string = diff --git a/compiler/PrintPure.ml b/compiler/PrintPure.ml index 5d8297d3..d33a2f18 100644 --- a/compiler/PrintPure.ml +++ b/compiler/PrintPure.ml @@ -56,7 +56,10 @@ let fmt_env_to_llbc_fmt_env (env : fmt_env) : Print.fmt_env = global_decls = env.global_decls; trait_decls = env.trait_decls; trait_impls = env.trait_impls; - generics = TypesUtils.empty_generic_params; + regions = []; + types = []; + const_generics = []; + trait_clauses = []; preds = TypesUtils.empty_predicates; locals = []; } diff --git a/compiler/RegionsHierarchy.ml b/compiler/RegionsHierarchy.ml index e101ba49..80b67a54 100644 --- a/compiler/RegionsHierarchy.ml +++ b/compiler/RegionsHierarchy.ml @@ -23,6 +23,8 @@ have to compute the SCCs of the lifetimes (two lifetimes 'a and 'b may satisfy 'a : 'b and 'b : 'a, meaning they are actually equal and should be grouped together). + + TODO: we don't handle locally bound regions yet. *) open Types @@ -42,7 +44,7 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) (trait_impls : trait_impl TraitImplId.Map.t) (fun_name : string) - (sg : fun_sig) : region_groups = + (sg : fun_sig) : region_var_groups = log#ldebug (lazy (__FUNCTION__ ^ ": " ^ fun_name)); (* Initialize a normalization context (we may need to normalize some associated types) *) @@ -74,12 +76,27 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) - the region variables - the static region - edges from the region variables to the static region + + Note that we introduce free variables for all the regions bound at the + level of the signature (this excludes the regions locally bound inside + the types, for instance at the level of an arrow type). *) + let bound_regions, bound_regions_id_subst, bound_regions_subst = + Subst.fresh_regions_with_substs_from_vars ~fail_if_not_found:true + sg.generics.regions + in + let region_id_to_var_map : RegionVarId.id RegionId.Map.t = + RegionId.Map.of_list + (List.combine bound_regions + (List.map (fun (r : region_var) -> r.index) sg.generics.regions)) + in + let subst = { Subst.empty_subst with r_subst = bound_regions_subst } in let g : RegionSet.t RegionMap.t ref = let s_set = RegionSet.singleton RStatic in let m = List.map - (fun (r : region_var) -> (RVar r.index, s_set)) + (fun (r : region_var) -> + (RFVar (Option.get (bound_regions_id_subst r.index)), s_set)) sg.generics.regions in let s = (RStatic, RegionSet.empty) in @@ -87,10 +104,17 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) in let add_edge ~(short : region) ~(long : region) = - let m = !g in - let s = RegionMap.find short !g in - let s = RegionSet.add long s in - g := RegionMap.add short s m + (* Sanity checks *) + assert (short <> RErased); + assert (long <> RErased); + (* Ignore the locally bound regions (at the level of arrow types for instance *) + match (short, long) with + | RBVar _, _ | _, RBVar _ -> () + | _, _ -> + let m = !g in + let s = RegionMap.find short !g in + let s = RegionSet.add long s in + g := RegionMap.add short s m in let add_edge_from_region_constraint ((long, short) : region_outlives) = @@ -152,22 +176,30 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id); (* We have nothing to do *) () - | TArrow (inputs, output) -> - (* TODO: this may be too constraining *) - List.iter (explore_ty outer) (output :: inputs) + | TArrow (regions, inputs, output) -> + (* TODO: *) + assert (regions = []); + (* We can ignore the outer regions *) + List.iter (explore_ty []) (output :: inputs) and explore_generics (outer : region list) (generics : generic_args) = let { regions; types; const_generics = _; trait_refs = _ } = generics in List.iter (fun long -> add_edges ~long ~shorts:outer) regions; List.iter (explore_ty outer) types in + (* Substitute the regions in a type, then explore *) + let explore_ty_subst ty = + let ty = Subst.ty_substitute subst ty in + explore_ty [] ty + in + (* Normalize the types then explore *) let tys = List.map (AssociatedTypes.norm_ctx_normalize_ty norm_ctx) (sg.output :: sg.inputs) in - List.iter (explore_ty []) tys; + List.iter explore_ty_subst tys; (* Compute the ordered SCCs *) let module Scc = SCC.Make (RegionOrderedType) in @@ -240,10 +272,12 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t) let id = RegionGroupId.of_int i in (* Retrieve the set of regions in the group *) - let regions = + let regions : RegionVarId.id list = List.map (fun r -> - match r with RVar r -> r | _ -> raise (Failure "Unreachable")) + match r with + | RFVar rid -> RegionId.Map.find rid region_id_to_var_map + | _ -> raise (Failure "Unreachable")) scc in @@ -262,7 +296,8 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) (fun_decls : fun_decl FunDeclId.Map.t) (global_decls : global_decl GlobalDeclId.Map.t) (trait_decls : trait_decl TraitDeclId.Map.t) - (trait_impls : trait_impl TraitImplId.Map.t) : region_groups FunIdMap.t = + (trait_impls : trait_impl TraitImplId.Map.t) : region_var_groups FunIdMap.t + = let open Print in let env : fmt_env = { @@ -271,7 +306,10 @@ let compute_regions_hierarchies (type_decls : type_decl TypeDeclId.Map.t) global_decls; trait_decls; trait_impls; - generics = empty_generic_params; + regions = []; + types = []; + const_generics = []; + trait_clauses = []; preds = empty_predicates; locals = []; } diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index a05b2c5a..e28f005d 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -11,6 +11,9 @@ open Contexts type subst = { r_subst : region -> region; + (** Remark: this might be called with bound regions with a negative + DeBruijn index. A negative DeBruijn index means that the region + is locally bound. *) ty_subst : TypeVarId.id -> ty; cg_subst : ConstGenericVarId.id -> const_generic; (** Substitution from *local* trait clause to trait instance *) @@ -19,11 +22,35 @@ type subst = { tr_self : trait_instance_id; } +let empty_subst : subst = + { + r_subst = (fun x -> x); + ty_subst = (fun id -> TVar id); + cg_subst = (fun id -> CgVar id); + tr_subst = (fun id -> Clause id); + tr_self = Self; + } + let st_substitute_visitor (subst : subst) = - object + object (self) inherit [_] map_statement - method! visit_region _ r = subst.r_subst r - method! visit_TVar _ id = subst.ty_subst id + method! visit_region (subst : subst) r = subst.r_subst r + + (** We need to properly handle the DeBruijn indices *) + method! visit_TArrow subst regions inputs output = + (* Decrement the DeBruijn indices before calling the substitution *) + let r_subst r = + match r with + | RBVar (db, rid) -> subst.r_subst (RBVar (db - 1, rid)) + | _ -> subst.r_subst r + in + let subst = { subst with r_subst } in + (* Note that we ignore the bound regions variables *) + let inputs = List.map (self#visit_ty subst) inputs in + let output = self#visit_ty subst output in + TArrow (regions, inputs, output) + + method! visit_TVar (subst : subst) id = subst.ty_subst id method! visit_type_var_id _ _ = (* We should never get here because we reimplemented [visit_TypeVar] *) @@ -35,8 +62,8 @@ let st_substitute_visitor (subst : subst) = (* 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 + method! visit_Clause (subst : subst) id = subst.tr_subst id + method! visit_Self (subst : subst) = subst.tr_self end (** Substitute types variables and regions in a type. @@ -45,27 +72,27 @@ let st_substitute_visitor (subst : subst) = *) let ty_substitute (subst : subst) (ty : ty) : ty = let visitor = st_substitute_visitor subst in - visitor#visit_ty () ty + visitor#visit_ty subst ty (** **IMPORTANT**: this doesn't normalize the types. *) let trait_ref_substitute (subst : subst) (tr : trait_ref) : trait_ref = let visitor = st_substitute_visitor subst in - visitor#visit_trait_ref () tr + visitor#visit_trait_ref subst tr (** **IMPORTANT**: this doesn't normalize the types. *) let trait_instance_id_substitute (subst : subst) (tr : trait_instance_id) : trait_instance_id = let visitor = st_substitute_visitor subst in - visitor#visit_trait_instance_id () tr + visitor#visit_trait_instance_id subst tr (** **IMPORTANT**: this doesn't normalize the types. *) let generic_args_substitute (subst : subst) (g : generic_args) : generic_args = let visitor = st_substitute_visitor subst in - visitor#visit_generic_args () g + visitor#visit_generic_args subst g let predicates_substitute (subst : subst) (p : predicates) : predicates = let visitor = st_substitute_visitor subst in - visitor#visit_predicates () p + visitor#visit_predicates subst p let erase_regions_subst : subst = { @@ -96,26 +123,40 @@ let generic_args_erase_regions (tr : generic_args) : generic_args = TODO: simplify? we only need the subst [RegionVarId.id -> RegionId.id] *) -let fresh_regions_with_substs (region_vars : region_var list) : - RegionId.id list * (RegionId.id -> RegionId.id) * (region -> region) = +let fresh_regions_with_substs ~(fail_if_not_found : bool) + (region_vars : RegionVarId.id list) : + RegionId.id list + * (RegionVarId.id -> RegionId.id option) + * (region -> region) = (* Generate fresh regions *) let fresh_region_ids = List.map (fun _ -> fresh_region_id ()) region_vars in (* Generate the map from region var ids to regions *) let ls = List.combine region_vars fresh_region_ids in - let rid_map = - List.fold_left - (fun mp ((k : region_var), v) -> RegionId.Map.add k.index v mp) - RegionId.Map.empty ls - in + let rid_map = RegionVarId.Map.of_list ls in (* Generate the substitution from region var id to region *) - let rid_subst id = RegionId.Map.find id rid_map in + let rid_subst id = RegionVarId.Map.find_opt id rid_map in (* Generate the substitution from region to region *) let r_subst (r : region) = - match r with RStatic | RErased -> r | RVar id -> RVar (rid_subst id) + match r with + | RStatic | RErased | RFVar _ -> r + | RBVar (bdid, id) -> + if bdid = 0 then + match rid_subst id with + | None -> if fail_if_not_found then raise Not_found else r + | Some r -> RFVar r + else r in (* Return *) (fresh_region_ids, rid_subst, r_subst) +let fresh_regions_with_substs_from_vars ~(fail_if_not_found : bool) + (region_vars : region_var list) : + RegionId.id list + * (RegionVarId.id -> RegionId.id option) + * (region -> region) = + fresh_regions_with_substs ~fail_if_not_found + (List.map (fun (r : region_var) -> r.index) region_vars) + (** Erase the regions in a type and perform a substitution *) let erase_regions_substitute_types (ty_subst : TypeVarId.id -> ty) (cg_subst : ConstGenericVarId.id -> const_generic) @@ -127,16 +168,21 @@ let erase_regions_substitute_types (ty_subst : TypeVarId.id -> ty) (** Create a region substitution from a list of region variable ids and a list of regions (with which to substitute the region variable ids *) -let make_region_subst (var_ids : RegionId.id list) (regions : region list) : +let make_region_subst (var_ids : RegionVarId.id list) (regions : region list) : region -> region = let ls = List.combine var_ids regions in let mp = List.fold_left - (fun mp (k, v) -> RegionId.Map.add k v mp) - RegionId.Map.empty ls + (fun mp (k, v) -> RegionVarId.Map.add k v mp) + RegionVarId.Map.empty ls in fun r -> - match r with RStatic | RErased -> r | RVar id -> RegionId.Map.find id mp + match r with + | RStatic | RErased -> r + | RFVar _ -> raise (Failure "Unexpected") + | RBVar (bdid, id) -> + (* Only substitute the bound regions with DeBruijn index equal to 0 *) + if bdid = 0 then RegionVarId.Map.find id mp else r let make_region_subst_from_vars (vars : region_var list) (regions : region list) : region -> region = @@ -298,27 +344,27 @@ let ctx_adt_value_get_instantiated_field_types (ctx : eval_ctx) (** Apply a type substitution to a place *) let place_substitute (subst : subst) (p : place) : place = (* There is in fact nothing to do *) - (st_substitute_visitor subst)#visit_place () p + (st_substitute_visitor subst)#visit_place subst p (** Apply a type substitution to an operand *) let operand_substitute (subst : subst) (op : operand) : operand = - (st_substitute_visitor subst)#visit_operand () op + (st_substitute_visitor subst)#visit_operand subst op (** Apply a type substitution to an rvalue *) let rvalue_substitute (subst : subst) (rv : rvalue) : rvalue = - (st_substitute_visitor subst)#visit_rvalue () rv + (st_substitute_visitor subst)#visit_rvalue subst rv (** Apply a type substitution to an assertion *) let assertion_substitute (subst : subst) (a : assertion) : assertion = - (st_substitute_visitor subst)#visit_assertion () a + (st_substitute_visitor subst)#visit_assertion subst a (** Apply a type substitution to a call *) let call_substitute (subst : subst) (call : call) : call = - (st_substitute_visitor subst)#visit_call () call + (st_substitute_visitor subst)#visit_call subst call (** Apply a type substitution to a statement *) let statement_substitute (subst : subst) (st : statement) : statement = - (st_substitute_visitor subst)#visit_statement () st + (st_substitute_visitor subst)#visit_statement subst st (** Apply a type substitution to a function body. Return the local variables and the body. *) @@ -336,9 +382,9 @@ let trait_type_constraint_substitute (subst : subst) (ttc : trait_type_constraint) : trait_type_constraint = let { trait_ref; generics; type_name; ty } = ttc in let visitor = st_substitute_visitor subst in - let trait_ref = visitor#visit_trait_ref () trait_ref in - let generics = visitor#visit_generic_args () generics in - let ty = visitor#visit_ty () ty in + let trait_ref = visitor#visit_trait_ref subst trait_ref in + let generics = visitor#visit_generic_args subst generics in + let ty = visitor#visit_ty subst ty in { trait_ref; generics; type_name; ty } (** Substitute a function signature, together with the regions hierarchy @@ -347,18 +393,20 @@ let trait_type_constraint_substitute (subst : subst) **IMPORTANT:** this function doesn't normalize the types. *) let substitute_signature (asubst : RegionGroupId.id -> AbstractionId.id) - (r_subst : RegionId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) + (r_subst : RegionVarId.id -> RegionId.id) (ty_subst : TypeVarId.id -> ty) (cg_subst : ConstGenericVarId.id -> const_generic) (tr_subst : TraitClauseId.id -> trait_instance_id) (tr_self : trait_instance_id) (sg : fun_sig) - (regions_hierarchy : region_groups) : inst_fun_sig = + (regions_hierarchy : region_var_groups) : inst_fun_sig = let r_subst' (r : region) : region = - match r with RStatic | RErased -> r | RVar rid -> RVar (r_subst rid) + match r with + | RStatic | RErased | RFVar _ -> r + | RBVar (bdid, rid) -> if bdid = 0 then RFVar (r_subst rid) else r in let subst = { r_subst = r_subst'; ty_subst; cg_subst; tr_subst; tr_self } in let inputs = List.map (ty_substitute subst) sg.inputs in let output = ty_substitute subst sg.output in - let subst_region_group (rg : region_group) : abs_region_group = + let subst_region_group (rg : region_var_group) : abs_region_group = let id = asubst rg.id in let regions = List.map r_subst rg.regions in let parents = List.map asubst rg.parents in diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index f5b055fd..b4611b7e 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -47,7 +47,7 @@ type fun_context = { llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; fun_sigs : fun_sig_named_outputs RegularFunIdNotLoopMap.t; (** *) fun_infos : fun_info A.FunDeclId.Map.t; - regions_hierarchies : T.region_groups FunIdMap.t; + regions_hierarchies : T.region_var_groups FunIdMap.t; } [@@deriving show] @@ -214,7 +214,9 @@ let bs_ctx_to_fmt_env (ctx : bs_ctx) : Print.fmt_env = let global_decls = ctx.global_context.llbc_global_decls in let trait_decls = ctx.trait_decls_ctx in let trait_impls = ctx.trait_impls_ctx in - let generics = ctx.fun_decl.signature.generics in + let { regions; types; const_generics; trait_clauses } : T.generic_params = + ctx.fun_decl.signature.generics + in let preds = ctx.fun_decl.signature.preds in { type_decls; @@ -222,7 +224,10 @@ let bs_ctx_to_fmt_env (ctx : bs_ctx) : Print.fmt_env = global_decls; trait_decls; trait_impls; - generics; + regions = [ regions ]; + types; + const_generics; + trait_clauses; preds; locals = []; } @@ -279,6 +284,10 @@ let texpression_to_string (ctx : bs_ctx) (e : texpression) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.texpression_to_string env false "" " " e +let fun_id_to_string (ctx : bs_ctx) (id : A.fun_id) : string = + let env = bs_ctx_to_fmt_env ctx in + Print.Expressions.fun_id_to_string env id + let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = let env = bs_ctx_to_pure_fmt_env ctx in PrintPure.fun_sig_to_string env sg @@ -371,7 +380,7 @@ and translate_trait_instance_id (translate_ty : 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") + | FnPointer _ | Closure _ -> raise (Failure "Closures are not supported yet") | UnknownTrait s -> raise (Failure ("Unknown trait found: " ^ s)) (** Translate a signature type - TODO: factor out the different translation functions *) @@ -873,7 +882,7 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) (* Create the context *) let ctx = let region_groups = - List.map (fun (g : T.region_group) -> g.id) regions_hierarchy + List.map (fun (g : T.region_var_group) -> g.id) regions_hierarchy in let ctx = InterpreterUtils.initialize_eval_context decls_ctx region_groups @@ -905,17 +914,30 @@ let translate_fun_sig (decls_ctx : C.decls_ctx) (fun_id : A.fun_id) * so just check that there aren't parent regions *) assert (T.RegionGroupId.Set.is_empty parents); (* Small helper to translate types for backward functions *) - let translate_back_ty_for_gid (gid : T.RegionGroupId.id) : T.ty -> ty option = + let translate_back_ty_for_gid (gid : T.RegionGroupId.id) (ty : T.ty) : + ty option = let rg = T.RegionGroupId.nth regions_hierarchy gid in - let regions = T.RegionId.Set.of_list rg.regions in + (* Turn *all* the outer bound regions into free regions *) + let _, rid_subst, r_subst = + Substitute.fresh_regions_with_substs_from_vars ~fail_if_not_found:true + sg.generics.regions + in + let subst = { Substitute.empty_subst with r_subst } in + let ty = Substitute.ty_substitute subst ty in + (* Compute the set of regions belonging to this group *) + let gr_regions = + T.RegionId.Set.of_list + (List.map (fun rid -> Option.get (rid_subst rid)) rg.regions) + in let keep_region r = match r with | T.RStatic -> raise Unimplemented - | T.RErased -> raise (Failure "Unexpected erased region") - | T.RVar r -> T.RegionId.Set.mem r regions + | RErased -> raise (Failure "Unexpected erased region") + | RBVar _ -> raise (Failure "Unexpected bound region") + | RFVar rid -> T.RegionId.Set.mem rid gr_regions in let inside_mut = false in - translate_back_ty type_infos keep_region inside_mut + translate_back_ty type_infos keep_region inside_mut ty in (* Compute the additinal inputs for the current function, if it is a backward * function *) @@ -1749,7 +1771,8 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : is_rec = false; } in - (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None)) + (ctx, Unop (Cast (src_ty, tgt_ty)), effect_info, args, None) + | CastFnPtr _ -> raise (Failure "TODO: function casts")) | S.Binop binop -> ( match args with | [ arg0; arg1 ] -> @@ -1758,8 +1781,7 @@ and translate_function_call (call : S.call) (e : S.expression) (ctx : bs_ctx) : (match binop with (* The Rust compiler accepts bitshifts for any integer type combination for ty0, ty1 *) | E.Shl | E.Shr -> () - | _ -> assert (int_ty0 = int_ty1) - ); + | _ -> assert (int_ty0 = int_ty1)); let effect_info = { can_fail = ExpressionsUtils.binop_can_fail binop; @@ -3100,6 +3122,12 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) let translate_one (fun_id : A.fun_id) (input_names : string option list) (sg : A.fun_sig) : (regular_fun_id_not_loop * fun_sig_named_outputs) list = + log#ldebug + (lazy + ("Translating signature of function: " + ^ Print.Expressions.fun_id_to_string + (Print.Contexts.decls_ctx_to_fmt_env decls_ctx) + fun_id)); (* Retrieve the regions hierarchy *) let regions_hierarchy = FunIdMap.find fun_id decls_ctx.fun_ctx.regions_hierarchies @@ -3110,7 +3138,7 @@ let translate_fun_signatures (decls_ctx : C.decls_ctx) (* The backward functions *) let back_sgs = List.map - (fun (rg : T.region_group) -> + (fun (rg : T.region_var_group) -> let tsg = translate_fun_sig decls_ctx fun_id sg input_names (Some rg.id) in diff --git a/compiler/Translate.ml b/compiler/Translate.ml index 37f58140..221d4e73 100644 --- a/compiler/Translate.ml +++ b/compiler/Translate.ml @@ -188,7 +188,7 @@ let translate_function_to_pure (trans_ctx : trans_ctx) in (* Translate the backward functions *) - let translate_backward (rg : region_group) : Pure.fun_decl = + let translate_backward (rg : region_var_group) : Pure.fun_decl = (* For the backward inputs/outputs initialization: we use the fact that * there are no nested borrows for now, and so that the region groups * can't have parents *) diff --git a/compiler/TypesAnalysis.ml b/compiler/TypesAnalysis.ml index eb0aeea9..589c380c 100644 --- a/compiler/TypesAnalysis.ml +++ b/compiler/TypesAnalysis.ml @@ -233,7 +233,7 @@ let analyze_full_ty (updated : bool ref) (infos : type_infos) in (* Return *) ty_info - | TArrow (inputs, output) -> + | TArrow (_regions, inputs, output) -> (* Just dive into the arrow *) let ty_info = List.fold_left diff --git a/compiler/TypesUtils.ml b/compiler/TypesUtils.ml index 76cc710a..c8418ba0 100644 --- a/compiler/TypesUtils.ml +++ b/compiler/TypesUtils.ml @@ -29,16 +29,19 @@ let ty_has_borrow_under_mut (infos : TypesAnalysis.type_infos) (ty : ty) : bool info.TypesAnalysis.contains_borrow_under_mut (** Small helper *) -let raise_if_erased_ty_visitor = +let raise_if_not_rty_visitor = object inherit [_] iter_ty - method! visit_RErased _ = raise Found + + method! visit_region _ r = + match r with RBVar _ | RErased -> raise Found | RStatic | RFVar _ -> () end -(** Return [true] if the type is a region type (i.e., it doesn't contain erased regions) *) +(** Return [true] if the type is a region type (i.e., it doesn't contain erased + regions), and only contains free regions) *) let ty_is_rty (ty : ty) : bool = try - raise_if_erased_ty_visitor#visit_ty () ty; + raise_if_not_rty_visitor#visit_ty () ty; true with Found -> false @@ -46,8 +49,9 @@ let ty_is_rty (ty : ty) : bool = let raise_if_not_erased_ty_visitor = object inherit [_] iter_ty - method! visit_RStatic _ = raise Found - method! visit_RVar _ = raise Found + + method! visit_region _ r = + match r with RStatic | RBVar _ | RFVar _ -> raise Found | RErased -> () end (** Return [true] if the type is a region type (i.e., it doesn't contain erased regions) *) diff --git a/tests/coq/betree/BetreeMain_Funs.v b/tests/coq/betree/BetreeMain_Funs.v index aadaa20d..a5dd4230 100644 --- a/tests/coq/betree/BetreeMain_Funs.v +++ b/tests/coq/betree/BetreeMain_Funs.v @@ -318,6 +318,29 @@ Fixpoint betree_Node_lookup_first_message_for_key_back end . +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 *) +Fixpoint betree_Node_lookup_in_bindings + (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : + result (option u64) + := + match n with + | O => Fail_ OutOfFuel + | S n0 => + match bindings with + | Betree_List_Cons hd tl => + let (i, i0) := hd in + if i s= key + then Return (Some i0) + else + if i s> key + then Return None + else betree_Node_lookup_in_bindings n0 key tl + | Betree_List_Nil => Return None + end + end +. + (** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function Source: 'src/betree.rs', lines 819:4-819:90 *) Fixpoint betree_Node_apply_upserts @@ -382,29 +405,6 @@ Fixpoint betree_Node_apply_upserts_back end . -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function - Source: 'src/betree.rs', lines 636:4-636:80 *) -Fixpoint betree_Node_lookup_in_bindings - (n : nat) (key : u64) (bindings : betree_List_t (u64 * u64)) : - result (option u64) - := - match n with - | O => Fail_ OutOfFuel - | S n0 => - match bindings with - | Betree_List_Cons hd tl => - let (i, i0) := hd in - if i s= key - then Return (Some i0) - else - if i s> key - then Return None - else betree_Node_lookup_in_bindings n0 key tl - | Betree_List_Nil => Return None - end - end -. - (** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function Source: 'src/betree.rs', lines 395:4-395:63 *) Fixpoint betree_Internal_lookup_in_children diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index 16a2e816..1a0014c0 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -59,53 +59,111 @@ Arguments Sum_Right { _ _ }. Definition neg_test (x : i32) : result i32 := i32_neg x. -(** [no_nested_borrows::add_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 54:0-54:38 *) -Definition add_test (x : u32) (y : u32) : result u32 := +(** [no_nested_borrows::add_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 54:0-54:37 *) +Definition add_u32 (x : u32) (y : u32) : result u32 := u32_add x y. -(** [no_nested_borrows::subs_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 60:0-60:39 *) -Definition subs_test (x : u32) (y : u32) : result u32 := +(** [no_nested_borrows::subs_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 60:0-60:38 *) +Definition subs_u32 (x : u32) (y : u32) : result u32 := u32_sub x y. -(** [no_nested_borrows::div_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 66:0-66:38 *) -Definition div_test (x : u32) (y : u32) : result u32 := +(** [no_nested_borrows::div_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 66:0-66:37 *) +Definition div_u32 (x : u32) (y : u32) : result u32 := u32_div x y. -(** [no_nested_borrows::div_test1]: forward function - Source: 'src/no_nested_borrows.rs', lines 73:0-73:31 *) -Definition div_test1 (x : u32) : result u32 := +(** [no_nested_borrows::div_u32_const]: forward function + Source: 'src/no_nested_borrows.rs', lines 73:0-73:35 *) +Definition div_u32_const (x : u32) : result u32 := u32_div x 2%u32. -(** [no_nested_borrows::rem_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 78:0-78:38 *) -Definition rem_test (x : u32) (y : u32) : result u32 := +(** [no_nested_borrows::rem_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 78:0-78:37 *) +Definition rem_u32 (x : u32) (y : u32) : result u32 := u32_rem x y. -(** [no_nested_borrows::mul_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 82:0-82:38 *) -Definition mul_test (x : u32) (y : u32) : result u32 := +(** [no_nested_borrows::mul_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 82:0-82:37 *) +Definition mul_u32 (x : u32) (y : u32) : result u32 := u32_mul x y. +(** [no_nested_borrows::add_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 88:0-88:37 *) +Definition add_i32 (x : i32) (y : i32) : result i32 := + i32_add x y. + +(** [no_nested_borrows::subs_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 92:0-92:38 *) +Definition subs_i32 (x : i32) (y : i32) : result i32 := + i32_sub x y. + +(** [no_nested_borrows::div_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 96:0-96:37 *) +Definition div_i32 (x : i32) (y : i32) : result i32 := + i32_div x y. + +(** [no_nested_borrows::div_i32_const]: forward function + Source: 'src/no_nested_borrows.rs', lines 100:0-100:35 *) +Definition div_i32_const (x : i32) : result i32 := + i32_div x 2%i32. + +(** [no_nested_borrows::rem_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 104:0-104:37 *) +Definition rem_i32 (x : i32) (y : i32) : result i32 := + i32_rem x y. + +(** [no_nested_borrows::mul_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 108:0-108:37 *) +Definition mul_i32 (x : i32) (y : i32) : result i32 := + i32_mul x y. + +(** [no_nested_borrows::mix_arith_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 112:0-112:51 *) +Definition mix_arith_u32 (x : u32) (y : u32) (z : u32) : result u32 := + i <- u32_add x y; + i0 <- u32_div x y; + i1 <- u32_mul i i0; + i2 <- u32_rem z y; + i3 <- u32_sub x i2; + i4 <- u32_add i1 i3; + i5 <- u32_add x y; + i6 <- u32_add i5 z; + u32_rem i4 i6 +. + +(** [no_nested_borrows::mix_arith_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 116:0-116:51 *) +Definition mix_arith_i32 (x : i32) (y : i32) (z : i32) : result i32 := + i <- i32_add x y; + i0 <- i32_div x y; + i1 <- i32_mul i i0; + i2 <- i32_rem z y; + i3 <- i32_sub x i2; + i4 <- i32_add i1 i3; + i5 <- i32_add x y; + i6 <- i32_add i5 z; + i32_rem i4 i6 +. + (** [no_nested_borrows::CONST0] - Source: 'src/no_nested_borrows.rs', lines 91:0-91:23 *) + Source: 'src/no_nested_borrows.rs', lines 125:0-125:23 *) Definition const0_body : result usize := usize_add 1%usize 1%usize. Definition const0_c : usize := const0_body%global. (** [no_nested_borrows::CONST1] - Source: 'src/no_nested_borrows.rs', lines 92:0-92:23 *) + Source: 'src/no_nested_borrows.rs', lines 126:0-126:23 *) Definition const1_body : result usize := usize_mul 2%usize 2%usize. Definition const1_c : usize := const1_body%global. (** [no_nested_borrows::cast_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 94:0-94:31 *) + Source: 'src/no_nested_borrows.rs', lines 128:0-128:31 *) Definition cast_test (x : u32) : result i32 := scalar_cast U32 I32 x. (** [no_nested_borrows::test2]: forward function - Source: 'src/no_nested_borrows.rs', lines 99:0-99:14 *) + Source: 'src/no_nested_borrows.rs', lines 133:0-133:14 *) Definition test2 : result unit := _ <- u32_add 23%u32 44%u32; Return tt. @@ -113,13 +171,13 @@ Definition test2 : result unit := Check (test2 )%return. (** [no_nested_borrows::get_max]: forward function - Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 *) + Source: 'src/no_nested_borrows.rs', lines 145:0-145:37 *) Definition get_max (x : u32) (y : u32) : result u32 := if x s>= y then Return x else Return y . (** [no_nested_borrows::test3]: forward function - Source: 'src/no_nested_borrows.rs', lines 119:0-119:14 *) + Source: 'src/no_nested_borrows.rs', lines 153:0-153:14 *) Definition test3 : result unit := x <- get_max 4%u32 3%u32; y <- get_max 10%u32 11%u32; @@ -131,7 +189,7 @@ Definition test3 : result unit := Check (test3 )%return. (** [no_nested_borrows::test_neg1]: forward function - Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 *) + Source: 'src/no_nested_borrows.rs', lines 160:0-160:18 *) Definition test_neg1 : result unit := y <- i32_neg 3%i32; if negb (y s= (-3)%i32) then Fail_ Failure else Return tt . @@ -140,7 +198,7 @@ Definition test_neg1 : result unit := Check (test_neg1 )%return. (** [no_nested_borrows::refs_test1]: forward function - Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 *) + Source: 'src/no_nested_borrows.rs', lines 167:0-167:19 *) Definition refs_test1 : result unit := if negb (1%i32 s= 1%i32) then Fail_ Failure else Return tt . @@ -149,7 +207,7 @@ Definition refs_test1 : result unit := Check (refs_test1 )%return. (** [no_nested_borrows::refs_test2]: forward function - Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 *) + Source: 'src/no_nested_borrows.rs', lines 178:0-178:19 *) Definition refs_test2 : result unit := if negb (2%i32 s= 2%i32) then Fail_ Failure @@ -166,7 +224,7 @@ Definition refs_test2 : result unit := Check (refs_test2 )%return. (** [no_nested_borrows::test_list1]: forward function - Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 *) + Source: 'src/no_nested_borrows.rs', lines 194:0-194:19 *) Definition test_list1 : result unit := Return tt. @@ -174,7 +232,7 @@ Definition test_list1 : result unit := Check (test_list1 )%return. (** [no_nested_borrows::test_box1]: forward function - Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 *) + Source: 'src/no_nested_borrows.rs', lines 199:0-199:18 *) Definition test_box1 : result unit := let b := 0%i32 in b0 <- alloc_boxed_Box_deref_mut_back i32 b 1%i32; @@ -186,24 +244,24 @@ Definition test_box1 : result unit := Check (test_box1 )%return. (** [no_nested_borrows::copy_int]: forward function - Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 *) + Source: 'src/no_nested_borrows.rs', lines 209:0-209:30 *) Definition copy_int (x : i32) : result i32 := Return x. (** [no_nested_borrows::test_unreachable]: forward function - Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 *) + Source: 'src/no_nested_borrows.rs', lines 215:0-215:32 *) Definition test_unreachable (b : bool) : result unit := if b then Fail_ Failure else Return tt . (** [no_nested_borrows::test_panic]: forward function - Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 *) + Source: 'src/no_nested_borrows.rs', lines 223:0-223:26 *) Definition test_panic (b : bool) : result unit := if b then Fail_ Failure else Return tt . (** [no_nested_borrows::test_copy_int]: forward function - Source: 'src/no_nested_borrows.rs', lines 196:0-196:22 *) + Source: 'src/no_nested_borrows.rs', lines 230:0-230:22 *) Definition test_copy_int : result unit := y <- copy_int 0%i32; if negb (0%i32 s= y) then Fail_ Failure else Return tt . @@ -212,13 +270,13 @@ Definition test_copy_int : result unit := Check (test_copy_int )%return. (** [no_nested_borrows::is_cons]: forward function - Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 *) + Source: 'src/no_nested_borrows.rs', lines 237:0-237:38 *) Definition is_cons (T : Type) (l : List_t T) : result bool := match l with | List_Cons t l0 => Return true | List_Nil => Return false end . (** [no_nested_borrows::test_is_cons]: forward function - Source: 'src/no_nested_borrows.rs', lines 210:0-210:21 *) + Source: 'src/no_nested_borrows.rs', lines 244:0-244:21 *) Definition test_is_cons : result unit := let l := List_Nil in b <- is_cons i32 (List_Cons 0%i32 l); @@ -229,7 +287,7 @@ Definition test_is_cons : result unit := Check (test_is_cons )%return. (** [no_nested_borrows::split_list]: forward function - Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 *) + Source: 'src/no_nested_borrows.rs', lines 250:0-250:48 *) Definition split_list (T : Type) (l : List_t T) : result (T * (List_t T)) := match l with | List_Cons hd tl => Return (hd, tl) @@ -238,7 +296,7 @@ Definition split_list (T : Type) (l : List_t T) : result (T * (List_t T)) := . (** [no_nested_borrows::test_split_list]: forward function - Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 *) + Source: 'src/no_nested_borrows.rs', lines 258:0-258:24 *) Definition test_split_list : result unit := let l := List_Nil in p <- split_list i32 (List_Cons 0%i32 l); @@ -250,20 +308,20 @@ Definition test_split_list : result unit := Check (test_split_list )%return. (** [no_nested_borrows::choose]: forward function - Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) + Source: 'src/no_nested_borrows.rs', lines 265:0-265:70 *) Definition choose (T : Type) (b : bool) (x : T) (y : T) : result T := if b then Return x else Return y . (** [no_nested_borrows::choose]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) + Source: 'src/no_nested_borrows.rs', lines 265:0-265:70 *) Definition choose_back (T : Type) (b : bool) (x : T) (y : T) (ret : T) : result (T * T) := if b then Return (ret, y) else Return (x, ret) . (** [no_nested_borrows::choose_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 *) + Source: 'src/no_nested_borrows.rs', lines 273:0-273:20 *) Definition choose_test : result unit := z <- choose i32 true 0%i32 0%i32; z0 <- i32_add z 1%i32; @@ -281,18 +339,18 @@ Definition choose_test : result unit := Check (choose_test )%return. (** [no_nested_borrows::test_char]: forward function - Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 *) + Source: 'src/no_nested_borrows.rs', lines 285:0-285:26 *) Definition test_char : result char := Return (char_of_byte Coq.Init.Byte.x61). (** [no_nested_borrows::Tree] - Source: 'src/no_nested_borrows.rs', lines 256:0-256:16 *) + Source: 'src/no_nested_borrows.rs', lines 290:0-290:16 *) Inductive Tree_t (T : Type) := | Tree_Leaf : T -> Tree_t T | Tree_Node : T -> NodeElem_t T -> Tree_t T -> Tree_t T (** [no_nested_borrows::NodeElem] - Source: 'src/no_nested_borrows.rs', lines 261:0-261:20 *) + Source: 'src/no_nested_borrows.rs', lines 295:0-295:20 *) with NodeElem_t (T : Type) := | NodeElem_Cons : Tree_t T -> NodeElem_t T -> NodeElem_t T | NodeElem_Nil : NodeElem_t T @@ -305,7 +363,7 @@ Arguments NodeElem_Cons { _ }. Arguments NodeElem_Nil { _ }. (** [no_nested_borrows::list_length]: forward function - Source: 'src/no_nested_borrows.rs', lines 296:0-296:48 *) + Source: 'src/no_nested_borrows.rs', lines 330:0-330:48 *) Fixpoint list_length (T : Type) (l : List_t T) : result u32 := match l with | List_Cons t l1 => i <- list_length T l1; u32_add 1%u32 i @@ -314,7 +372,7 @@ Fixpoint list_length (T : Type) (l : List_t T) : result u32 := . (** [no_nested_borrows::list_nth_shared]: forward function - Source: 'src/no_nested_borrows.rs', lines 304:0-304:62 *) + Source: 'src/no_nested_borrows.rs', lines 338:0-338:62 *) Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := match l with | List_Cons x tl => @@ -326,7 +384,7 @@ Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := . (** [no_nested_borrows::list_nth_mut]: forward function - Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) + Source: 'src/no_nested_borrows.rs', lines 354:0-354:67 *) Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := match l with | List_Cons x tl => @@ -338,7 +396,7 @@ Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result T := . (** [no_nested_borrows::list_nth_mut]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) + Source: 'src/no_nested_borrows.rs', lines 354:0-354:67 *) Fixpoint list_nth_mut_back (T : Type) (l : List_t T) (i : u32) (ret : T) : result (List_t T) := match l with @@ -354,7 +412,7 @@ Fixpoint list_nth_mut_back . (** [no_nested_borrows::list_rev_aux]: forward function - Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 *) + Source: 'src/no_nested_borrows.rs', lines 370:0-370:63 *) Fixpoint list_rev_aux (T : Type) (li : List_t T) (lo : List_t T) : result (List_t T) := match li with @@ -365,14 +423,14 @@ Fixpoint list_rev_aux (** [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/no_nested_borrows.rs', lines 350:0-350:42 *) + Source: 'src/no_nested_borrows.rs', lines 384:0-384:42 *) Definition list_rev (T : Type) (l : List_t T) : result (List_t T) := let li := core_mem_replace (List_t T) l List_Nil in list_rev_aux T li List_Nil . (** [no_nested_borrows::test_list_functions]: forward function - Source: 'src/no_nested_borrows.rs', lines 355:0-355:28 *) + Source: 'src/no_nested_borrows.rs', lines 389:0-389:28 *) Definition test_list_functions : result unit := let l := List_Nil in let l0 := List_Cons 2%i32 l in @@ -410,73 +468,73 @@ Definition test_list_functions : result unit := Check (test_list_functions )%return. (** [no_nested_borrows::id_mut_pair1]: forward function - Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) + Source: 'src/no_nested_borrows.rs', lines 405:0-405:89 *) Definition id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . (** [no_nested_borrows::id_mut_pair1]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) + Source: 'src/no_nested_borrows.rs', lines 405:0-405:89 *) Definition id_mut_pair1_back (T1 T2 : Type) (x : T1) (y : T2) (ret : (T1 * T2)) : result (T1 * T2) := let (t, t0) := ret in Return (t, t0) . (** [no_nested_borrows::id_mut_pair2]: forward function - Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) + Source: 'src/no_nested_borrows.rs', lines 409:0-409:88 *) Definition id_mut_pair2 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . (** [no_nested_borrows::id_mut_pair2]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) + Source: 'src/no_nested_borrows.rs', lines 409:0-409:88 *) Definition id_mut_pair2_back (T1 T2 : Type) (p : (T1 * T2)) (ret : (T1 * T2)) : result (T1 * T2) := let (t, t0) := ret in Return (t, t0) . (** [no_nested_borrows::id_mut_pair3]: forward function - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 *) Definition id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : result (T1 * T2) := Return (x, y) . (** [no_nested_borrows::id_mut_pair3]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 *) Definition id_mut_pair3_back'a (T1 T2 : Type) (x : T1) (y : T2) (ret : T1) : result T1 := Return ret . (** [no_nested_borrows::id_mut_pair3]: backward function 1 - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 *) Definition id_mut_pair3_back'b (T1 T2 : Type) (x : T1) (y : T2) (ret : T2) : result T2 := Return ret . (** [no_nested_borrows::id_mut_pair4]: forward function - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 *) Definition id_mut_pair4 (T1 T2 : Type) (p : (T1 * T2)) : result (T1 * T2) := let (t, t0) := p in Return (t, t0) . (** [no_nested_borrows::id_mut_pair4]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 *) Definition id_mut_pair4_back'a (T1 T2 : Type) (p : (T1 * T2)) (ret : T1) : result T1 := Return ret . (** [no_nested_borrows::id_mut_pair4]: backward function 1 - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 *) Definition id_mut_pair4_back'b (T1 T2 : Type) (p : (T1 * T2)) (ret : T2) : result T2 := Return ret . (** [no_nested_borrows::StructWithTuple] - Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 *) + Source: 'src/no_nested_borrows.rs', lines 424:0-424:34 *) Record StructWithTuple_t (T1 T2 : Type) := mkStructWithTuple_t { structWithTuple_p : (T1 * T2); @@ -487,25 +545,25 @@ Arguments mkStructWithTuple_t { _ _ }. Arguments structWithTuple_p { _ _ }. (** [no_nested_borrows::new_tuple1]: forward function - Source: 'src/no_nested_borrows.rs', lines 394:0-394:48 *) + Source: 'src/no_nested_borrows.rs', lines 428:0-428:48 *) Definition new_tuple1 : result (StructWithTuple_t u32 u32) := Return {| structWithTuple_p := (1%u32, 2%u32) |} . (** [no_nested_borrows::new_tuple2]: forward function - Source: 'src/no_nested_borrows.rs', lines 398:0-398:48 *) + Source: 'src/no_nested_borrows.rs', lines 432:0-432:48 *) Definition new_tuple2 : result (StructWithTuple_t i16 i16) := Return {| structWithTuple_p := (1%i16, 2%i16) |} . (** [no_nested_borrows::new_tuple3]: forward function - Source: 'src/no_nested_borrows.rs', lines 402:0-402:48 *) + Source: 'src/no_nested_borrows.rs', lines 436:0-436:48 *) Definition new_tuple3 : result (StructWithTuple_t u64 i64) := Return {| structWithTuple_p := (1%u64, 2%i64) |} . (** [no_nested_borrows::StructWithPair] - Source: 'src/no_nested_borrows.rs', lines 407:0-407:33 *) + Source: 'src/no_nested_borrows.rs', lines 441:0-441:33 *) Record StructWithPair_t (T1 T2 : Type) := mkStructWithPair_t { structWithPair_p : Pair_t T1 T2; @@ -516,13 +574,13 @@ Arguments mkStructWithPair_t { _ _ }. Arguments structWithPair_p { _ _ }. (** [no_nested_borrows::new_pair1]: forward function - Source: 'src/no_nested_borrows.rs', lines 411:0-411:46 *) + Source: 'src/no_nested_borrows.rs', lines 445:0-445:46 *) Definition new_pair1 : result (StructWithPair_t u32 u32) := Return {| structWithPair_p := {| pair_x := 1%u32; pair_y := 2%u32 |} |} . (** [no_nested_borrows::test_constants]: forward function - Source: 'src/no_nested_borrows.rs', lines 419:0-419:23 *) + Source: 'src/no_nested_borrows.rs', lines 453:0-453:23 *) Definition test_constants : result unit := swt <- new_tuple1; let (i, _) := swt.(structWithTuple_p) in @@ -549,7 +607,7 @@ Definition test_constants : result unit := Check (test_constants )%return. (** [no_nested_borrows::test_weird_borrows1]: forward function - Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 *) + Source: 'src/no_nested_borrows.rs', lines 462:0-462:28 *) Definition test_weird_borrows1 : result unit := Return tt. @@ -558,31 +616,31 @@ Check (test_weird_borrows1 )%return. (** [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/no_nested_borrows.rs', lines 438:0-438:37 *) + Source: 'src/no_nested_borrows.rs', lines 472:0-472:37 *) Definition test_mem_replace (px : u32) : result u32 := let y := core_mem_replace u32 px 1%u32 in if negb (y s= 0%u32) then Fail_ Failure else Return 2%u32 . (** [no_nested_borrows::test_shared_borrow_bool1]: forward function - Source: 'src/no_nested_borrows.rs', lines 445:0-445:47 *) + Source: 'src/no_nested_borrows.rs', lines 479:0-479:47 *) Definition test_shared_borrow_bool1 (b : bool) : result u32 := if b then Return 0%u32 else Return 1%u32 . (** [no_nested_borrows::test_shared_borrow_bool2]: forward function - Source: 'src/no_nested_borrows.rs', lines 458:0-458:40 *) + Source: 'src/no_nested_borrows.rs', lines 492:0-492:40 *) Definition test_shared_borrow_bool2 : result u32 := Return 0%u32. (** [no_nested_borrows::test_shared_borrow_enum1]: forward function - Source: 'src/no_nested_borrows.rs', lines 473:0-473:52 *) + Source: 'src/no_nested_borrows.rs', lines 507:0-507:52 *) Definition test_shared_borrow_enum1 (l : List_t u32) : result u32 := match l with | List_Cons i l0 => Return 1%u32 | List_Nil => Return 0%u32 end . (** [no_nested_borrows::test_shared_borrow_enum2]: forward function - Source: 'src/no_nested_borrows.rs', lines 485:0-485:40 *) + Source: 'src/no_nested_borrows.rs', lines 519:0-519:40 *) Definition test_shared_borrow_enum2 : result u32 := Return 0%u32. diff --git a/tests/coq/misc/_CoqProject b/tests/coq/misc/_CoqProject index abbf6aa8..869cdb4d 100644 --- a/tests/coq/misc/_CoqProject +++ b/tests/coq/misc/_CoqProject @@ -7,10 +7,10 @@ Loops.v External_Types.v Primitives.v External_Funs.v -Paper.v External_TypesExternal.v Constants.v PoloniusList.v +Paper.v NoNestedBorrows.v External_FunsExternal.v Bitwise.v diff --git a/tests/fstar/betree/BetreeMain.Clauses.Template.fst b/tests/fstar/betree/BetreeMain.Clauses.Template.fst index 4ae29302..537705c5 100644 --- a/tests/fstar/betree/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree/BetreeMain.Clauses.Template.fst @@ -33,6 +33,13 @@ let betree_Node_lookup_first_message_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause + Source: 'src/betree.rs', lines 636:4-636:80 *) +unfold +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = + admit () + (** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause Source: 'src/betree.rs', lines 819:4-819:90 *) unfold @@ -41,13 +48,6 @@ let betree_Node_apply_upserts_decreases (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause - Source: 'src/betree.rs', lines 636:4-636:80 *) -unfold -let betree_Node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_List_t (u64 & u64)) : nat = - admit () - (** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause Source: 'src/betree.rs', lines 395:4-395:63 *) unfold diff --git a/tests/fstar/betree/BetreeMain.Funs.fst b/tests/fstar/betree/BetreeMain.Funs.fst index fef8a8e1..f844b0ec 100644 --- a/tests/fstar/betree/BetreeMain.Funs.fst +++ b/tests/fstar/betree/BetreeMain.Funs.fst @@ -258,6 +258,22 @@ let rec betree_Node_lookup_first_message_for_key_back | Betree_List_Nil -> Return ret end +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 *) +let rec betree_Node_lookup_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : + Tot (result (option u64)) + (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) + = + begin match bindings with + | Betree_List_Cons hd tl -> + let (i, i0) = hd in + if i = key + then Return (Some i0) + else if i > key then Return None else betree_Node_lookup_in_bindings key tl + | Betree_List_Nil -> Return None + end + (** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function Source: 'src/betree.rs', lines 819:4-819:90 *) let rec betree_Node_apply_upserts @@ -312,22 +328,6 @@ let rec betree_Node_apply_upserts_back betree_List_push_front (u64 & betree_Message_t) msgs (key, Betree_Message_Insert v) -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function - Source: 'src/betree.rs', lines 636:4-636:80 *) -let rec betree_Node_lookup_in_bindings - (key : u64) (bindings : betree_List_t (u64 & u64)) : - Tot (result (option u64)) - (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) - = - begin match bindings with - | Betree_List_Cons hd tl -> - let (i, i0) = hd in - if i = key - then Return (Some i0) - else if i > key then Return None else betree_Node_lookup_in_bindings key tl - | Betree_List_Nil -> Return None - end - (** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function Source: 'src/betree.rs', lines 395:4-395:63 *) let rec betree_Internal_lookup_in_children diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst index 4ae29302..537705c5 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Clauses.Template.fst @@ -33,6 +33,13 @@ let betree_Node_lookup_first_message_for_key_decreases (key : u64) (msgs : betree_List_t (u64 & betree_Message_t)) : nat = admit () +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause + Source: 'src/betree.rs', lines 636:4-636:80 *) +unfold +let betree_Node_lookup_in_bindings_decreases (key : u64) + (bindings : betree_List_t (u64 & u64)) : nat = + admit () + (** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: decreases clause Source: 'src/betree.rs', lines 819:4-819:90 *) unfold @@ -41,13 +48,6 @@ let betree_Node_apply_upserts_decreases (key : u64) (st : state) : nat = admit () -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: decreases clause - Source: 'src/betree.rs', lines 636:4-636:80 *) -unfold -let betree_Node_lookup_in_bindings_decreases (key : u64) - (bindings : betree_List_t (u64 & u64)) : nat = - admit () - (** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: decreases clause Source: 'src/betree.rs', lines 395:4-395:63 *) unfold diff --git a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst index b912a316..6c3c2161 100644 --- a/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst +++ b/tests/fstar/betree_back_stateful/BetreeMain.Funs.fst @@ -295,6 +295,22 @@ let rec betree_Node_lookup_first_message_for_key_back | Betree_List_Nil -> Return ret end +(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 *) +let rec betree_Node_lookup_in_bindings + (key : u64) (bindings : betree_List_t (u64 & u64)) : + Tot (result (option u64)) + (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) + = + begin match bindings with + | Betree_List_Cons hd tl -> + let (i, i0) = hd in + if i = key + then Return (Some i0) + else if i > key then Return None else betree_Node_lookup_in_bindings key tl + | Betree_List_Nil -> Return None + end + (** [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function Source: 'src/betree.rs', lines 819:4-819:90 *) let rec betree_Node_apply_upserts @@ -351,22 +367,6 @@ let rec betree_Node_apply_upserts_back Betree_Message_Insert v) in Return (st0, msgs0) -(** [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function - Source: 'src/betree.rs', lines 636:4-636:80 *) -let rec betree_Node_lookup_in_bindings - (key : u64) (bindings : betree_List_t (u64 & u64)) : - Tot (result (option u64)) - (decreases (betree_Node_lookup_in_bindings_decreases key bindings)) - = - begin match bindings with - | Betree_List_Cons hd tl -> - let (i, i0) = hd in - if i = key - then Return (Some i0) - else if i > key then Return None else betree_Node_lookup_in_bindings key tl - | Betree_List_Nil -> Return None - end - (** [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function Source: 'src/betree.rs', lines 395:4-395:63 *) let rec betree_Internal_lookup_in_children diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index 2e14d67d..130b02f2 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -42,53 +42,109 @@ type sum_t (t1 t2 : Type0) = let neg_test (x : i32) : result i32 = i32_neg x -(** [no_nested_borrows::add_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 54:0-54:38 *) -let add_test (x : u32) (y : u32) : result u32 = +(** [no_nested_borrows::add_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 54:0-54:37 *) +let add_u32 (x : u32) (y : u32) : result u32 = u32_add x y -(** [no_nested_borrows::subs_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 60:0-60:39 *) -let subs_test (x : u32) (y : u32) : result u32 = +(** [no_nested_borrows::subs_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 60:0-60:38 *) +let subs_u32 (x : u32) (y : u32) : result u32 = u32_sub x y -(** [no_nested_borrows::div_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 66:0-66:38 *) -let div_test (x : u32) (y : u32) : result u32 = +(** [no_nested_borrows::div_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 66:0-66:37 *) +let div_u32 (x : u32) (y : u32) : result u32 = u32_div x y -(** [no_nested_borrows::div_test1]: forward function - Source: 'src/no_nested_borrows.rs', lines 73:0-73:31 *) -let div_test1 (x : u32) : result u32 = +(** [no_nested_borrows::div_u32_const]: forward function + Source: 'src/no_nested_borrows.rs', lines 73:0-73:35 *) +let div_u32_const (x : u32) : result u32 = u32_div x 2 -(** [no_nested_borrows::rem_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 78:0-78:38 *) -let rem_test (x : u32) (y : u32) : result u32 = +(** [no_nested_borrows::rem_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 78:0-78:37 *) +let rem_u32 (x : u32) (y : u32) : result u32 = u32_rem x y -(** [no_nested_borrows::mul_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 82:0-82:38 *) -let mul_test (x : u32) (y : u32) : result u32 = +(** [no_nested_borrows::mul_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 82:0-82:37 *) +let mul_u32 (x : u32) (y : u32) : result u32 = u32_mul x y +(** [no_nested_borrows::add_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 88:0-88:37 *) +let add_i32 (x : i32) (y : i32) : result i32 = + i32_add x y + +(** [no_nested_borrows::subs_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 92:0-92:38 *) +let subs_i32 (x : i32) (y : i32) : result i32 = + i32_sub x y + +(** [no_nested_borrows::div_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 96:0-96:37 *) +let div_i32 (x : i32) (y : i32) : result i32 = + i32_div x y + +(** [no_nested_borrows::div_i32_const]: forward function + Source: 'src/no_nested_borrows.rs', lines 100:0-100:35 *) +let div_i32_const (x : i32) : result i32 = + i32_div x 2 + +(** [no_nested_borrows::rem_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 104:0-104:37 *) +let rem_i32 (x : i32) (y : i32) : result i32 = + i32_rem x y + +(** [no_nested_borrows::mul_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 108:0-108:37 *) +let mul_i32 (x : i32) (y : i32) : result i32 = + i32_mul x y + +(** [no_nested_borrows::mix_arith_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 112:0-112:51 *) +let mix_arith_u32 (x : u32) (y : u32) (z : u32) : result u32 = + let* i = u32_add x y in + let* i0 = u32_div x y in + let* i1 = u32_mul i i0 in + let* i2 = u32_rem z y in + let* i3 = u32_sub x i2 in + let* i4 = u32_add i1 i3 in + let* i5 = u32_add x y in + let* i6 = u32_add i5 z in + u32_rem i4 i6 + +(** [no_nested_borrows::mix_arith_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 116:0-116:51 *) +let mix_arith_i32 (x : i32) (y : i32) (z : i32) : result i32 = + let* i = i32_add x y in + let* i0 = i32_div x y in + let* i1 = i32_mul i i0 in + let* i2 = i32_rem z y in + let* i3 = i32_sub x i2 in + let* i4 = i32_add i1 i3 in + let* i5 = i32_add x y in + let* i6 = i32_add i5 z in + i32_rem i4 i6 + (** [no_nested_borrows::CONST0] - Source: 'src/no_nested_borrows.rs', lines 91:0-91:23 *) + Source: 'src/no_nested_borrows.rs', lines 125:0-125:23 *) let const0_body : result usize = usize_add 1 1 let const0_c : usize = eval_global const0_body (** [no_nested_borrows::CONST1] - Source: 'src/no_nested_borrows.rs', lines 92:0-92:23 *) + Source: 'src/no_nested_borrows.rs', lines 126:0-126:23 *) let const1_body : result usize = usize_mul 2 2 let const1_c : usize = eval_global const1_body (** [no_nested_borrows::cast_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 94:0-94:31 *) + Source: 'src/no_nested_borrows.rs', lines 128:0-128:31 *) let cast_test (x : u32) : result i32 = scalar_cast U32 I32 x (** [no_nested_borrows::test2]: forward function - Source: 'src/no_nested_borrows.rs', lines 99:0-99:14 *) + Source: 'src/no_nested_borrows.rs', lines 133:0-133:14 *) let test2 : result unit = let* _ = u32_add 23 44 in Return () @@ -96,12 +152,12 @@ let test2 : result unit = let _ = assert_norm (test2 = Return ()) (** [no_nested_borrows::get_max]: forward function - Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 *) + Source: 'src/no_nested_borrows.rs', lines 145:0-145:37 *) let get_max (x : u32) (y : u32) : result u32 = if x >= y then Return x else Return y (** [no_nested_borrows::test3]: forward function - Source: 'src/no_nested_borrows.rs', lines 119:0-119:14 *) + Source: 'src/no_nested_borrows.rs', lines 153:0-153:14 *) let test3 : result unit = let* x = get_max 4 3 in let* y = get_max 10 11 in @@ -112,7 +168,7 @@ let test3 : result unit = let _ = assert_norm (test3 = Return ()) (** [no_nested_borrows::test_neg1]: forward function - Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 *) + Source: 'src/no_nested_borrows.rs', lines 160:0-160:18 *) let test_neg1 : result unit = let* y = i32_neg 3 in if not (y = -3) then Fail Failure else Return () @@ -120,7 +176,7 @@ let test_neg1 : result unit = let _ = assert_norm (test_neg1 = Return ()) (** [no_nested_borrows::refs_test1]: forward function - Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 *) + Source: 'src/no_nested_borrows.rs', lines 167:0-167:19 *) let refs_test1 : result unit = if not (1 = 1) then Fail Failure else Return () @@ -128,7 +184,7 @@ let refs_test1 : result unit = let _ = assert_norm (refs_test1 = Return ()) (** [no_nested_borrows::refs_test2]: forward function - Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 *) + Source: 'src/no_nested_borrows.rs', lines 178:0-178:19 *) let refs_test2 : result unit = if not (2 = 2) then Fail Failure @@ -144,7 +200,7 @@ let refs_test2 : result unit = let _ = assert_norm (refs_test2 = Return ()) (** [no_nested_borrows::test_list1]: forward function - Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 *) + Source: 'src/no_nested_borrows.rs', lines 194:0-194:19 *) let test_list1 : result unit = Return () @@ -152,7 +208,7 @@ let test_list1 : result unit = let _ = assert_norm (test_list1 = Return ()) (** [no_nested_borrows::test_box1]: forward function - Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 *) + Source: 'src/no_nested_borrows.rs', lines 199:0-199:18 *) let test_box1 : result unit = let b = 0 in let* b0 = alloc_boxed_Box_deref_mut_back i32 b 1 in @@ -163,22 +219,22 @@ let test_box1 : result unit = let _ = assert_norm (test_box1 = Return ()) (** [no_nested_borrows::copy_int]: forward function - Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 *) + Source: 'src/no_nested_borrows.rs', lines 209:0-209:30 *) let copy_int (x : i32) : result i32 = Return x (** [no_nested_borrows::test_unreachable]: forward function - Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 *) + Source: 'src/no_nested_borrows.rs', lines 215:0-215:32 *) let test_unreachable (b : bool) : result unit = if b then Fail Failure else Return () (** [no_nested_borrows::test_panic]: forward function - Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 *) + Source: 'src/no_nested_borrows.rs', lines 223:0-223:26 *) let test_panic (b : bool) : result unit = if b then Fail Failure else Return () (** [no_nested_borrows::test_copy_int]: forward function - Source: 'src/no_nested_borrows.rs', lines 196:0-196:22 *) + Source: 'src/no_nested_borrows.rs', lines 230:0-230:22 *) let test_copy_int : result unit = let* y = copy_int 0 in if not (0 = y) then Fail Failure else Return () @@ -186,7 +242,7 @@ let test_copy_int : result unit = let _ = assert_norm (test_copy_int = Return ()) (** [no_nested_borrows::is_cons]: forward function - Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 *) + Source: 'src/no_nested_borrows.rs', lines 237:0-237:38 *) let is_cons (t : Type0) (l : list_t t) : result bool = begin match l with | List_Cons x l0 -> Return true @@ -194,7 +250,7 @@ let is_cons (t : Type0) (l : list_t t) : result bool = end (** [no_nested_borrows::test_is_cons]: forward function - Source: 'src/no_nested_borrows.rs', lines 210:0-210:21 *) + Source: 'src/no_nested_borrows.rs', lines 244:0-244:21 *) let test_is_cons : result unit = let l = List_Nil in let* b = is_cons i32 (List_Cons 0 l) in @@ -204,7 +260,7 @@ let test_is_cons : result unit = let _ = assert_norm (test_is_cons = Return ()) (** [no_nested_borrows::split_list]: forward function - Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 *) + Source: 'src/no_nested_borrows.rs', lines 250:0-250:48 *) let split_list (t : Type0) (l : list_t t) : result (t & (list_t t)) = begin match l with | List_Cons hd tl -> Return (hd, tl) @@ -212,7 +268,7 @@ let split_list (t : Type0) (l : list_t t) : result (t & (list_t t)) = end (** [no_nested_borrows::test_split_list]: forward function - Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 *) + Source: 'src/no_nested_borrows.rs', lines 258:0-258:24 *) let test_split_list : result unit = let l = List_Nil in let* p = split_list i32 (List_Cons 0 l) in @@ -223,18 +279,18 @@ let test_split_list : result unit = let _ = assert_norm (test_split_list = Return ()) (** [no_nested_borrows::choose]: forward function - Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) + Source: 'src/no_nested_borrows.rs', lines 265:0-265:70 *) let choose (t : Type0) (b : bool) (x : t) (y : t) : result t = if b then Return x else Return y (** [no_nested_borrows::choose]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 *) + Source: 'src/no_nested_borrows.rs', lines 265:0-265:70 *) let choose_back (t : Type0) (b : bool) (x : t) (y : t) (ret : t) : result (t & t) = if b then Return (ret, y) else Return (x, ret) (** [no_nested_borrows::choose_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 *) + Source: 'src/no_nested_borrows.rs', lines 273:0-273:20 *) let choose_test : result unit = let* z = choose i32 true 0 0 in let* z0 = i32_add z 1 in @@ -250,24 +306,24 @@ let choose_test : result unit = let _ = assert_norm (choose_test = Return ()) (** [no_nested_borrows::test_char]: forward function - Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 *) + Source: 'src/no_nested_borrows.rs', lines 285:0-285:26 *) let test_char : result char = Return 'a' (** [no_nested_borrows::Tree] - Source: 'src/no_nested_borrows.rs', lines 256:0-256:16 *) + Source: 'src/no_nested_borrows.rs', lines 290:0-290:16 *) type tree_t (t : Type0) = | Tree_Leaf : t -> tree_t t | Tree_Node : t -> nodeElem_t t -> tree_t t -> tree_t t (** [no_nested_borrows::NodeElem] - Source: 'src/no_nested_borrows.rs', lines 261:0-261:20 *) + Source: 'src/no_nested_borrows.rs', lines 295:0-295:20 *) and nodeElem_t (t : Type0) = | NodeElem_Cons : tree_t t -> nodeElem_t t -> nodeElem_t t | NodeElem_Nil : nodeElem_t t (** [no_nested_borrows::list_length]: forward function - Source: 'src/no_nested_borrows.rs', lines 296:0-296:48 *) + Source: 'src/no_nested_borrows.rs', lines 330:0-330:48 *) let rec list_length (t : Type0) (l : list_t t) : result u32 = begin match l with | List_Cons x l1 -> let* i = list_length t l1 in u32_add 1 i @@ -275,7 +331,7 @@ let rec list_length (t : Type0) (l : list_t t) : result u32 = end (** [no_nested_borrows::list_nth_shared]: forward function - Source: 'src/no_nested_borrows.rs', lines 304:0-304:62 *) + Source: 'src/no_nested_borrows.rs', lines 338:0-338:62 *) let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with | List_Cons x tl -> @@ -286,7 +342,7 @@ let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = end (** [no_nested_borrows::list_nth_mut]: forward function - Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) + Source: 'src/no_nested_borrows.rs', lines 354:0-354:67 *) let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with | List_Cons x tl -> @@ -295,7 +351,7 @@ let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result t = end (** [no_nested_borrows::list_nth_mut]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 *) + Source: 'src/no_nested_borrows.rs', lines 354:0-354:67 *) let rec list_nth_mut_back (t : Type0) (l : list_t t) (i : u32) (ret : t) : result (list_t t) = begin match l with @@ -310,7 +366,7 @@ let rec list_nth_mut_back end (** [no_nested_borrows::list_rev_aux]: forward function - Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 *) + Source: 'src/no_nested_borrows.rs', lines 370:0-370:63 *) let rec list_rev_aux (t : Type0) (li : list_t t) (lo : list_t t) : result (list_t t) = begin match li with @@ -320,12 +376,12 @@ let rec list_rev_aux (** [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/no_nested_borrows.rs', lines 350:0-350:42 *) + Source: 'src/no_nested_borrows.rs', lines 384:0-384:42 *) let list_rev (t : Type0) (l : list_t t) : result (list_t t) = let li = core_mem_replace (list_t t) l List_Nil in list_rev_aux t li List_Nil (** [no_nested_borrows::test_list_functions]: forward function - Source: 'src/no_nested_borrows.rs', lines 355:0-355:28 *) + Source: 'src/no_nested_borrows.rs', lines 389:0-389:28 *) let test_list_functions : result unit = let l = List_Nil in let l0 = List_Cons 2 l in @@ -362,91 +418,91 @@ let test_list_functions : result unit = let _ = assert_norm (test_list_functions = Return ()) (** [no_nested_borrows::id_mut_pair1]: forward function - Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) + Source: 'src/no_nested_borrows.rs', lines 405:0-405:89 *) let id_mut_pair1 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) (** [no_nested_borrows::id_mut_pair1]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 *) + Source: 'src/no_nested_borrows.rs', lines 405:0-405:89 *) let id_mut_pair1_back (t1 t2 : Type0) (x : t1) (y : t2) (ret : (t1 & t2)) : result (t1 & t2) = let (x0, x1) = ret in Return (x0, x1) (** [no_nested_borrows::id_mut_pair2]: forward function - Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) + Source: 'src/no_nested_borrows.rs', lines 409:0-409:88 *) let id_mut_pair2 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) (** [no_nested_borrows::id_mut_pair2]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 *) + Source: 'src/no_nested_borrows.rs', lines 409:0-409:88 *) let id_mut_pair2_back (t1 t2 : Type0) (p : (t1 & t2)) (ret : (t1 & t2)) : result (t1 & t2) = let (x, x0) = ret in Return (x, x0) (** [no_nested_borrows::id_mut_pair3]: forward function - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 *) let id_mut_pair3 (t1 t2 : Type0) (x : t1) (y : t2) : result (t1 & t2) = Return (x, y) (** [no_nested_borrows::id_mut_pair3]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 *) let id_mut_pair3_back'a (t1 t2 : Type0) (x : t1) (y : t2) (ret : t1) : result t1 = Return ret (** [no_nested_borrows::id_mut_pair3]: backward function 1 - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 *) + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 *) let id_mut_pair3_back'b (t1 t2 : Type0) (x : t1) (y : t2) (ret : t2) : result t2 = Return ret (** [no_nested_borrows::id_mut_pair4]: forward function - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 *) let id_mut_pair4 (t1 t2 : Type0) (p : (t1 & t2)) : result (t1 & t2) = let (x, x0) = p in Return (x, x0) (** [no_nested_borrows::id_mut_pair4]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 *) let id_mut_pair4_back'a (t1 t2 : Type0) (p : (t1 & t2)) (ret : t1) : result t1 = Return ret (** [no_nested_borrows::id_mut_pair4]: backward function 1 - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 *) + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 *) let id_mut_pair4_back'b (t1 t2 : Type0) (p : (t1 & t2)) (ret : t2) : result t2 = Return ret (** [no_nested_borrows::StructWithTuple] - Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 *) + Source: 'src/no_nested_borrows.rs', lines 424:0-424:34 *) type structWithTuple_t (t1 t2 : Type0) = { p : (t1 & t2); } (** [no_nested_borrows::new_tuple1]: forward function - Source: 'src/no_nested_borrows.rs', lines 394:0-394:48 *) + Source: 'src/no_nested_borrows.rs', lines 428:0-428:48 *) let new_tuple1 : result (structWithTuple_t u32 u32) = Return { p = (1, 2) } (** [no_nested_borrows::new_tuple2]: forward function - Source: 'src/no_nested_borrows.rs', lines 398:0-398:48 *) + Source: 'src/no_nested_borrows.rs', lines 432:0-432:48 *) let new_tuple2 : result (structWithTuple_t i16 i16) = Return { p = (1, 2) } (** [no_nested_borrows::new_tuple3]: forward function - Source: 'src/no_nested_borrows.rs', lines 402:0-402:48 *) + Source: 'src/no_nested_borrows.rs', lines 436:0-436:48 *) let new_tuple3 : result (structWithTuple_t u64 i64) = Return { p = (1, 2) } (** [no_nested_borrows::StructWithPair] - Source: 'src/no_nested_borrows.rs', lines 407:0-407:33 *) + Source: 'src/no_nested_borrows.rs', lines 441:0-441:33 *) type structWithPair_t (t1 t2 : Type0) = { p : pair_t t1 t2; } (** [no_nested_borrows::new_pair1]: forward function - Source: 'src/no_nested_borrows.rs', lines 411:0-411:46 *) + Source: 'src/no_nested_borrows.rs', lines 445:0-445:46 *) let new_pair1 : result (structWithPair_t u32 u32) = Return { p = { x = 1; y = 2 } } (** [no_nested_borrows::test_constants]: forward function - Source: 'src/no_nested_borrows.rs', lines 419:0-419:23 *) + Source: 'src/no_nested_borrows.rs', lines 453:0-453:23 *) let test_constants : result unit = let* swt = new_tuple1 in let (i, _) = swt.p in @@ -470,7 +526,7 @@ let test_constants : result unit = let _ = assert_norm (test_constants = Return ()) (** [no_nested_borrows::test_weird_borrows1]: forward function - Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 *) + Source: 'src/no_nested_borrows.rs', lines 462:0-462:28 *) let test_weird_borrows1 : result unit = Return () @@ -479,28 +535,28 @@ let _ = assert_norm (test_weird_borrows1 = Return ()) (** [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/no_nested_borrows.rs', lines 438:0-438:37 *) + Source: 'src/no_nested_borrows.rs', lines 472:0-472:37 *) let test_mem_replace (px : u32) : result u32 = let y = core_mem_replace u32 px 1 in if not (y = 0) then Fail Failure else Return 2 (** [no_nested_borrows::test_shared_borrow_bool1]: forward function - Source: 'src/no_nested_borrows.rs', lines 445:0-445:47 *) + Source: 'src/no_nested_borrows.rs', lines 479:0-479:47 *) let test_shared_borrow_bool1 (b : bool) : result u32 = if b then Return 0 else Return 1 (** [no_nested_borrows::test_shared_borrow_bool2]: forward function - Source: 'src/no_nested_borrows.rs', lines 458:0-458:40 *) + Source: 'src/no_nested_borrows.rs', lines 492:0-492:40 *) let test_shared_borrow_bool2 : result u32 = Return 0 (** [no_nested_borrows::test_shared_borrow_enum1]: forward function - Source: 'src/no_nested_borrows.rs', lines 473:0-473:52 *) + Source: 'src/no_nested_borrows.rs', lines 507:0-507:52 *) let test_shared_borrow_enum1 (l : list_t u32) : result u32 = begin match l with | List_Cons i l0 -> Return 1 | List_Nil -> Return 0 end (** [no_nested_borrows::test_shared_borrow_enum2]: forward function - Source: 'src/no_nested_borrows.rs', lines 485:0-485:40 *) + Source: 'src/no_nested_borrows.rs', lines 519:0-519:40 *) let test_shared_borrow_enum2 : result u32 = Return 0 diff --git a/tests/lean/BetreeMain/Funs.lean b/tests/lean/BetreeMain/Funs.lean index 4c862225..0d7cb984 100644 --- a/tests/lean/BetreeMain/Funs.lean +++ b/tests/lean/BetreeMain/Funs.lean @@ -256,6 +256,21 @@ divergent def betree.Node.lookup_first_message_for_key_back Result.ret (betree.List.Cons (i, m) next_msgs0) | betree.List.Nil => Result.ret ret +/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function + Source: 'src/betree.rs', lines 636:4-636:80 -/ +divergent def betree.Node.lookup_in_bindings + (key : U64) (bindings : betree.List (U64 × U64)) : Result (Option U64) := + match bindings with + | betree.List.Cons hd tl => + let (i, i0) := hd + if i = key + then Result.ret (some i0) + else + if i > key + then Result.ret none + else betree.Node.lookup_in_bindings key tl + | betree.List.Nil => Result.ret none + /- [betree_main::betree::{betree_main::betree::Node#5}::apply_upserts]: forward function Source: 'src/betree.rs', lines 819:4-819:90 -/ divergent def betree.Node.apply_upserts @@ -316,21 +331,6 @@ divergent def betree.Node.apply_upserts_back betree.List.push_front (U64 × betree.Message) msgs (key, betree.Message.Insert v) -/- [betree_main::betree::{betree_main::betree::Node#5}::lookup_in_bindings]: forward function - Source: 'src/betree.rs', lines 636:4-636:80 -/ -divergent def betree.Node.lookup_in_bindings - (key : U64) (bindings : betree.List (U64 × U64)) : Result (Option U64) := - match bindings with - | betree.List.Cons hd tl => - let (i, i0) := hd - if i = key - then Result.ret (some i0) - else - if i > key - then Result.ret none - else betree.Node.lookup_in_bindings key tl - | betree.List.Nil => Result.ret none - /- [betree_main::betree::{betree_main::betree::Internal#4}::lookup_in_children]: forward function Source: 'src/betree.rs', lines 395:4-395:63 -/ mutual divergent def betree.Internal.lookup_in_children diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index ca66c628..0c7dff8e 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -48,53 +48,111 @@ inductive Sum (T1 T2 : Type) := def neg_test (x : I32) : Result I32 := - x -/- [no_nested_borrows::add_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 54:0-54:38 -/ -def add_test (x : U32) (y : U32) : Result U32 := +/- [no_nested_borrows::add_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 54:0-54:37 -/ +def add_u32 (x : U32) (y : U32) : Result U32 := x + y -/- [no_nested_borrows::subs_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 60:0-60:39 -/ -def subs_test (x : U32) (y : U32) : Result U32 := +/- [no_nested_borrows::subs_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 60:0-60:38 -/ +def subs_u32 (x : U32) (y : U32) : Result U32 := x - y -/- [no_nested_borrows::div_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 66:0-66:38 -/ -def div_test (x : U32) (y : U32) : Result U32 := +/- [no_nested_borrows::div_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 66:0-66:37 -/ +def div_u32 (x : U32) (y : U32) : Result U32 := x / y -/- [no_nested_borrows::div_test1]: forward function - Source: 'src/no_nested_borrows.rs', lines 73:0-73:31 -/ -def div_test1 (x : U32) : Result U32 := +/- [no_nested_borrows::div_u32_const]: forward function + Source: 'src/no_nested_borrows.rs', lines 73:0-73:35 -/ +def div_u32_const (x : U32) : Result U32 := x / 2#u32 -/- [no_nested_borrows::rem_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 78:0-78:38 -/ -def rem_test (x : U32) (y : U32) : Result U32 := +/- [no_nested_borrows::rem_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 78:0-78:37 -/ +def rem_u32 (x : U32) (y : U32) : Result U32 := x % y -/- [no_nested_borrows::mul_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 82:0-82:38 -/ -def mul_test (x : U32) (y : U32) : Result U32 := +/- [no_nested_borrows::mul_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 82:0-82:37 -/ +def mul_u32 (x : U32) (y : U32) : Result U32 := x * y +/- [no_nested_borrows::add_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 88:0-88:37 -/ +def add_i32 (x : I32) (y : I32) : Result I32 := + x + y + +/- [no_nested_borrows::subs_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 92:0-92:38 -/ +def subs_i32 (x : I32) (y : I32) : Result I32 := + x - y + +/- [no_nested_borrows::div_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 96:0-96:37 -/ +def div_i32 (x : I32) (y : I32) : Result I32 := + x / y + +/- [no_nested_borrows::div_i32_const]: forward function + Source: 'src/no_nested_borrows.rs', lines 100:0-100:35 -/ +def div_i32_const (x : I32) : Result I32 := + x / 2#i32 + +/- [no_nested_borrows::rem_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 104:0-104:37 -/ +def rem_i32 (x : I32) (y : I32) : Result I32 := + x % y + +/- [no_nested_borrows::mul_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 108:0-108:37 -/ +def mul_i32 (x : I32) (y : I32) : Result I32 := + x * y + +/- [no_nested_borrows::mix_arith_u32]: forward function + Source: 'src/no_nested_borrows.rs', lines 112:0-112:51 -/ +def mix_arith_u32 (x : U32) (y : U32) (z : U32) : Result U32 := + do + let i ← x + y + let i0 ← x / y + let i1 ← i * i0 + let i2 ← z % y + let i3 ← x - i2 + let i4 ← i1 + i3 + let i5 ← x + y + let i6 ← i5 + z + i4 % i6 + +/- [no_nested_borrows::mix_arith_i32]: forward function + Source: 'src/no_nested_borrows.rs', lines 116:0-116:51 -/ +def mix_arith_i32 (x : I32) (y : I32) (z : I32) : Result I32 := + do + let i ← x + y + let i0 ← x / y + let i1 ← i * i0 + let i2 ← z % y + let i3 ← x - i2 + let i4 ← i1 + i3 + let i5 ← x + y + let i6 ← i5 + z + i4 % i6 + /- [no_nested_borrows::CONST0] - Source: 'src/no_nested_borrows.rs', lines 91:0-91:23 -/ + Source: 'src/no_nested_borrows.rs', lines 125:0-125:23 -/ def const0_body : Result Usize := 1#usize + 1#usize def const0_c : Usize := eval_global const0_body (by simp) /- [no_nested_borrows::CONST1] - Source: 'src/no_nested_borrows.rs', lines 92:0-92:23 -/ + Source: 'src/no_nested_borrows.rs', lines 126:0-126:23 -/ def const1_body : Result Usize := 2#usize * 2#usize def const1_c : Usize := eval_global const1_body (by simp) /- [no_nested_borrows::cast_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 94:0-94:31 -/ + Source: 'src/no_nested_borrows.rs', lines 128:0-128:31 -/ def cast_test (x : U32) : Result I32 := Scalar.cast .I32 x /- [no_nested_borrows::test2]: forward function - Source: 'src/no_nested_borrows.rs', lines 99:0-99:14 -/ + Source: 'src/no_nested_borrows.rs', lines 133:0-133:14 -/ def test2 : Result Unit := do let _ ← 23#u32 + 44#u32 @@ -104,14 +162,14 @@ def test2 : Result Unit := #assert (test2 == Result.ret ()) /- [no_nested_borrows::get_max]: forward function - Source: 'src/no_nested_borrows.rs', lines 111:0-111:37 -/ + Source: 'src/no_nested_borrows.rs', lines 145:0-145:37 -/ def get_max (x : U32) (y : U32) : Result U32 := if x >= y then Result.ret x else Result.ret y /- [no_nested_borrows::test3]: forward function - Source: 'src/no_nested_borrows.rs', lines 119:0-119:14 -/ + Source: 'src/no_nested_borrows.rs', lines 153:0-153:14 -/ def test3 : Result Unit := do let x ← get_max 4#u32 3#u32 @@ -125,7 +183,7 @@ def test3 : Result Unit := #assert (test3 == Result.ret ()) /- [no_nested_borrows::test_neg1]: forward function - Source: 'src/no_nested_borrows.rs', lines 126:0-126:18 -/ + Source: 'src/no_nested_borrows.rs', lines 160:0-160:18 -/ def test_neg1 : Result Unit := do let y ← - 3#i32 @@ -137,7 +195,7 @@ def test_neg1 : Result Unit := #assert (test_neg1 == Result.ret ()) /- [no_nested_borrows::refs_test1]: forward function - Source: 'src/no_nested_borrows.rs', lines 133:0-133:19 -/ + Source: 'src/no_nested_borrows.rs', lines 167:0-167:19 -/ def refs_test1 : Result Unit := if not (1#i32 = 1#i32) then Result.fail .panic @@ -147,7 +205,7 @@ def refs_test1 : Result Unit := #assert (refs_test1 == Result.ret ()) /- [no_nested_borrows::refs_test2]: forward function - Source: 'src/no_nested_borrows.rs', lines 144:0-144:19 -/ + Source: 'src/no_nested_borrows.rs', lines 178:0-178:19 -/ def refs_test2 : Result Unit := if not (2#i32 = 2#i32) then Result.fail .panic @@ -165,7 +223,7 @@ def refs_test2 : Result Unit := #assert (refs_test2 == Result.ret ()) /- [no_nested_borrows::test_list1]: forward function - Source: 'src/no_nested_borrows.rs', lines 160:0-160:19 -/ + Source: 'src/no_nested_borrows.rs', lines 194:0-194:19 -/ def test_list1 : Result Unit := Result.ret () @@ -173,7 +231,7 @@ def test_list1 : Result Unit := #assert (test_list1 == Result.ret ()) /- [no_nested_borrows::test_box1]: forward function - Source: 'src/no_nested_borrows.rs', lines 165:0-165:18 -/ + Source: 'src/no_nested_borrows.rs', lines 199:0-199:18 -/ def test_box1 : Result Unit := do let b := 0#i32 @@ -187,26 +245,26 @@ def test_box1 : Result Unit := #assert (test_box1 == Result.ret ()) /- [no_nested_borrows::copy_int]: forward function - Source: 'src/no_nested_borrows.rs', lines 175:0-175:30 -/ + Source: 'src/no_nested_borrows.rs', lines 209:0-209:30 -/ def copy_int (x : I32) : Result I32 := Result.ret x /- [no_nested_borrows::test_unreachable]: forward function - Source: 'src/no_nested_borrows.rs', lines 181:0-181:32 -/ + Source: 'src/no_nested_borrows.rs', lines 215:0-215:32 -/ def test_unreachable (b : Bool) : Result Unit := if b then Result.fail .panic else Result.ret () /- [no_nested_borrows::test_panic]: forward function - Source: 'src/no_nested_borrows.rs', lines 189:0-189:26 -/ + Source: 'src/no_nested_borrows.rs', lines 223:0-223:26 -/ def test_panic (b : Bool) : Result Unit := if b then Result.fail .panic else Result.ret () /- [no_nested_borrows::test_copy_int]: forward function - Source: 'src/no_nested_borrows.rs', lines 196:0-196:22 -/ + Source: 'src/no_nested_borrows.rs', lines 230:0-230:22 -/ def test_copy_int : Result Unit := do let y ← copy_int 0#i32 @@ -218,14 +276,14 @@ def test_copy_int : Result Unit := #assert (test_copy_int == Result.ret ()) /- [no_nested_borrows::is_cons]: forward function - Source: 'src/no_nested_borrows.rs', lines 203:0-203:38 -/ + Source: 'src/no_nested_borrows.rs', lines 237:0-237:38 -/ def is_cons (T : Type) (l : List T) : Result Bool := match l with | List.Cons t l0 => Result.ret true | List.Nil => Result.ret false /- [no_nested_borrows::test_is_cons]: forward function - Source: 'src/no_nested_borrows.rs', lines 210:0-210:21 -/ + Source: 'src/no_nested_borrows.rs', lines 244:0-244:21 -/ def test_is_cons : Result Unit := do let l := List.Nil @@ -238,14 +296,14 @@ def test_is_cons : Result Unit := #assert (test_is_cons == Result.ret ()) /- [no_nested_borrows::split_list]: forward function - Source: 'src/no_nested_borrows.rs', lines 216:0-216:48 -/ + Source: 'src/no_nested_borrows.rs', lines 250:0-250:48 -/ def split_list (T : Type) (l : List T) : Result (T × (List T)) := match l with | List.Cons hd tl => Result.ret (hd, tl) | List.Nil => Result.fail .panic /- [no_nested_borrows::test_split_list]: forward function - Source: 'src/no_nested_borrows.rs', lines 224:0-224:24 -/ + Source: 'src/no_nested_borrows.rs', lines 258:0-258:24 -/ def test_split_list : Result Unit := do let l := List.Nil @@ -259,14 +317,14 @@ def test_split_list : Result Unit := #assert (test_split_list == Result.ret ()) /- [no_nested_borrows::choose]: forward function - Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 -/ + Source: 'src/no_nested_borrows.rs', lines 265:0-265:70 -/ def choose (T : Type) (b : Bool) (x : T) (y : T) : Result T := if b then Result.ret x else Result.ret y /- [no_nested_borrows::choose]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 231:0-231:70 -/ + Source: 'src/no_nested_borrows.rs', lines 265:0-265:70 -/ def choose_back (T : Type) (b : Bool) (x : T) (y : T) (ret : T) : Result (T × T) := if b @@ -274,7 +332,7 @@ def choose_back else Result.ret (x, ret) /- [no_nested_borrows::choose_test]: forward function - Source: 'src/no_nested_borrows.rs', lines 239:0-239:20 -/ + Source: 'src/no_nested_borrows.rs', lines 273:0-273:20 -/ def choose_test : Result Unit := do let z ← choose I32 true 0#i32 0#i32 @@ -294,20 +352,20 @@ def choose_test : Result Unit := #assert (choose_test == Result.ret ()) /- [no_nested_borrows::test_char]: forward function - Source: 'src/no_nested_borrows.rs', lines 251:0-251:26 -/ + Source: 'src/no_nested_borrows.rs', lines 285:0-285:26 -/ def test_char : Result Char := Result.ret 'a' mutual /- [no_nested_borrows::Tree] - Source: 'src/no_nested_borrows.rs', lines 256:0-256:16 -/ + Source: 'src/no_nested_borrows.rs', lines 290:0-290:16 -/ inductive Tree (T : Type) := | Leaf : T → Tree T | Node : T → NodeElem T → Tree T → Tree T /- [no_nested_borrows::NodeElem] - Source: 'src/no_nested_borrows.rs', lines 261:0-261:20 -/ + Source: 'src/no_nested_borrows.rs', lines 295:0-295:20 -/ inductive NodeElem (T : Type) := | Cons : Tree T → NodeElem T → NodeElem T | Nil : NodeElem T @@ -315,7 +373,7 @@ inductive NodeElem (T : Type) := end /- [no_nested_borrows::list_length]: forward function - Source: 'src/no_nested_borrows.rs', lines 296:0-296:48 -/ + Source: 'src/no_nested_borrows.rs', lines 330:0-330:48 -/ divergent def list_length (T : Type) (l : List T) : Result U32 := match l with | List.Cons t l1 => do @@ -324,7 +382,7 @@ divergent def list_length (T : Type) (l : List T) : Result U32 := | List.Nil => Result.ret 0#u32 /- [no_nested_borrows::list_nth_shared]: forward function - Source: 'src/no_nested_borrows.rs', lines 304:0-304:62 -/ + Source: 'src/no_nested_borrows.rs', lines 338:0-338:62 -/ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => @@ -336,7 +394,7 @@ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := | List.Nil => Result.fail .panic /- [no_nested_borrows::list_nth_mut]: forward function - Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 -/ + Source: 'src/no_nested_borrows.rs', lines 354:0-354:67 -/ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => @@ -348,7 +406,7 @@ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result T := | List.Nil => Result.fail .panic /- [no_nested_borrows::list_nth_mut]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 320:0-320:67 -/ + Source: 'src/no_nested_borrows.rs', lines 354:0-354:67 -/ divergent def list_nth_mut_back (T : Type) (l : List T) (i : U32) (ret : T) : Result (List T) := match l with @@ -363,7 +421,7 @@ divergent def list_nth_mut_back | List.Nil => Result.fail .panic /- [no_nested_borrows::list_rev_aux]: forward function - Source: 'src/no_nested_borrows.rs', lines 336:0-336:63 -/ + Source: 'src/no_nested_borrows.rs', lines 370:0-370:63 -/ divergent def list_rev_aux (T : Type) (li : List T) (lo : List T) : Result (List T) := match li with @@ -372,13 +430,13 @@ divergent def list_rev_aux /- [no_nested_borrows::list_rev]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/no_nested_borrows.rs', lines 350:0-350:42 -/ + Source: 'src/no_nested_borrows.rs', lines 384:0-384:42 -/ def list_rev (T : Type) (l : List T) : Result (List T) := let li := core.mem.replace (List T) l List.Nil list_rev_aux T li List.Nil /- [no_nested_borrows::test_list_functions]: forward function - Source: 'src/no_nested_borrows.rs', lines 355:0-355:28 -/ + Source: 'src/no_nested_borrows.rs', lines 389:0-389:28 -/ def test_list_functions : Result Unit := do let l := List.Nil @@ -425,97 +483,97 @@ def test_list_functions : Result Unit := #assert (test_list_functions == Result.ret ()) /- [no_nested_borrows::id_mut_pair1]: forward function - Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 -/ + Source: 'src/no_nested_borrows.rs', lines 405:0-405:89 -/ def id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : Result (T1 × T2) := Result.ret (x, y) /- [no_nested_borrows::id_mut_pair1]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 371:0-371:89 -/ + Source: 'src/no_nested_borrows.rs', lines 405:0-405:89 -/ def id_mut_pair1_back (T1 T2 : Type) (x : T1) (y : T2) (ret : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := ret Result.ret (t, t0) /- [no_nested_borrows::id_mut_pair2]: forward function - Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 -/ + Source: 'src/no_nested_borrows.rs', lines 409:0-409:88 -/ def id_mut_pair2 (T1 T2 : Type) (p : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := p Result.ret (t, t0) /- [no_nested_borrows::id_mut_pair2]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 375:0-375:88 -/ + Source: 'src/no_nested_borrows.rs', lines 409:0-409:88 -/ def id_mut_pair2_back (T1 T2 : Type) (p : (T1 × T2)) (ret : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := ret Result.ret (t, t0) /- [no_nested_borrows::id_mut_pair3]: forward function - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 -/ def id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : Result (T1 × T2) := Result.ret (x, y) /- [no_nested_borrows::id_mut_pair3]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 -/ def id_mut_pair3_back'a (T1 T2 : Type) (x : T1) (y : T2) (ret : T1) : Result T1 := Result.ret ret /- [no_nested_borrows::id_mut_pair3]: backward function 1 - Source: 'src/no_nested_borrows.rs', lines 379:0-379:93 -/ + Source: 'src/no_nested_borrows.rs', lines 413:0-413:93 -/ def id_mut_pair3_back'b (T1 T2 : Type) (x : T1) (y : T2) (ret : T2) : Result T2 := Result.ret ret /- [no_nested_borrows::id_mut_pair4]: forward function - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 -/ def id_mut_pair4 (T1 T2 : Type) (p : (T1 × T2)) : Result (T1 × T2) := let (t, t0) := p Result.ret (t, t0) /- [no_nested_borrows::id_mut_pair4]: backward function 0 - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 -/ def id_mut_pair4_back'a (T1 T2 : Type) (p : (T1 × T2)) (ret : T1) : Result T1 := Result.ret ret /- [no_nested_borrows::id_mut_pair4]: backward function 1 - Source: 'src/no_nested_borrows.rs', lines 383:0-383:92 -/ + Source: 'src/no_nested_borrows.rs', lines 417:0-417:92 -/ def id_mut_pair4_back'b (T1 T2 : Type) (p : (T1 × T2)) (ret : T2) : Result T2 := Result.ret ret /- [no_nested_borrows::StructWithTuple] - Source: 'src/no_nested_borrows.rs', lines 390:0-390:34 -/ + Source: 'src/no_nested_borrows.rs', lines 424:0-424:34 -/ structure StructWithTuple (T1 T2 : Type) where p : (T1 × T2) /- [no_nested_borrows::new_tuple1]: forward function - Source: 'src/no_nested_borrows.rs', lines 394:0-394:48 -/ + Source: 'src/no_nested_borrows.rs', lines 428:0-428:48 -/ def new_tuple1 : Result (StructWithTuple U32 U32) := Result.ret { p := (1#u32, 2#u32) } /- [no_nested_borrows::new_tuple2]: forward function - Source: 'src/no_nested_borrows.rs', lines 398:0-398:48 -/ + Source: 'src/no_nested_borrows.rs', lines 432:0-432:48 -/ def new_tuple2 : Result (StructWithTuple I16 I16) := Result.ret { p := (1#i16, 2#i16) } /- [no_nested_borrows::new_tuple3]: forward function - Source: 'src/no_nested_borrows.rs', lines 402:0-402:48 -/ + Source: 'src/no_nested_borrows.rs', lines 436:0-436:48 -/ def new_tuple3 : Result (StructWithTuple U64 I64) := Result.ret { p := (1#u64, 2#i64) } /- [no_nested_borrows::StructWithPair] - Source: 'src/no_nested_borrows.rs', lines 407:0-407:33 -/ + Source: 'src/no_nested_borrows.rs', lines 441:0-441:33 -/ structure StructWithPair (T1 T2 : Type) where p : Pair T1 T2 /- [no_nested_borrows::new_pair1]: forward function - Source: 'src/no_nested_borrows.rs', lines 411:0-411:46 -/ + Source: 'src/no_nested_borrows.rs', lines 445:0-445:46 -/ def new_pair1 : Result (StructWithPair U32 U32) := Result.ret { p := { x := 1#u32, y := 2#u32 } } /- [no_nested_borrows::test_constants]: forward function - Source: 'src/no_nested_borrows.rs', lines 419:0-419:23 -/ + Source: 'src/no_nested_borrows.rs', lines 453:0-453:23 -/ def test_constants : Result Unit := do let swt ← new_tuple1 @@ -545,7 +603,7 @@ def test_constants : Result Unit := #assert (test_constants == Result.ret ()) /- [no_nested_borrows::test_weird_borrows1]: forward function - Source: 'src/no_nested_borrows.rs', lines 428:0-428:28 -/ + Source: 'src/no_nested_borrows.rs', lines 462:0-462:28 -/ def test_weird_borrows1 : Result Unit := Result.ret () @@ -554,7 +612,7 @@ def test_weird_borrows1 : Result Unit := /- [no_nested_borrows::test_mem_replace]: merged forward/backward function (there is a single backward function, and the forward function returns ()) - Source: 'src/no_nested_borrows.rs', lines 438:0-438:37 -/ + Source: 'src/no_nested_borrows.rs', lines 472:0-472:37 -/ def test_mem_replace (px : U32) : Result U32 := let y := core.mem.replace U32 px 1#u32 if not (y = 0#u32) @@ -562,26 +620,26 @@ def test_mem_replace (px : U32) : Result U32 := else Result.ret 2#u32 /- [no_nested_borrows::test_shared_borrow_bool1]: forward function - Source: 'src/no_nested_borrows.rs', lines 445:0-445:47 -/ + Source: 'src/no_nested_borrows.rs', lines 479:0-479:47 -/ def test_shared_borrow_bool1 (b : Bool) : Result U32 := if b then Result.ret 0#u32 else Result.ret 1#u32 /- [no_nested_borrows::test_shared_borrow_bool2]: forward function - Source: 'src/no_nested_borrows.rs', lines 458:0-458:40 -/ + Source: 'src/no_nested_borrows.rs', lines 492:0-492:40 -/ def test_shared_borrow_bool2 : Result U32 := Result.ret 0#u32 /- [no_nested_borrows::test_shared_borrow_enum1]: forward function - Source: 'src/no_nested_borrows.rs', lines 473:0-473:52 -/ + Source: 'src/no_nested_borrows.rs', lines 507:0-507:52 -/ def test_shared_borrow_enum1 (l : List U32) : Result U32 := match l with | List.Cons i l0 => Result.ret 1#u32 | List.Nil => Result.ret 0#u32 /- [no_nested_borrows::test_shared_borrow_enum2]: forward function - Source: 'src/no_nested_borrows.rs', lines 485:0-485:40 -/ + Source: 'src/no_nested_borrows.rs', lines 519:0-519:40 -/ def test_shared_borrow_enum2 : Result U32 := Result.ret 0#u32 -- cgit v1.2.3 From df3587d14b1137d0961f5607b3d8309eddbe69ce Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 5 Dec 2023 16:01:30 +0100 Subject: Fix a minor issue with the use of const generics --- compiler/Contexts.ml | 6 +++++- compiler/InterpreterBorrows.ml | 4 ++-- compiler/InterpreterExpressions.ml | 30 +++++++++++++++++++++++------- compiler/InterpreterUtils.ml | 4 ++-- compiler/SymbolicToPure.ml | 8 +++++++- compiler/Values.ml | 1 + 6 files changed, 40 insertions(+), 13 deletions(-) diff --git a/compiler/Contexts.ml b/compiler/Contexts.ml index bbfd31e6..a30ed0f1 100644 --- a/compiler/Contexts.ml +++ b/compiler/Contexts.ml @@ -241,7 +241,11 @@ type eval_ctx = { 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) *) + if we run in interpreter mode). + + TODO: this is actually not used in symbolic mode, where we + directly introduce fresh symbolic values. + *) norm_trait_types : ty TraitTypeRefMap.t; (** The normalized trait types (a map from trait types to their representatives). Note that this doesn't take into account higher-order type constraints diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index be556ade..6a7ac095 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -448,8 +448,8 @@ let give_back_symbolic_value (_config : config) (proj_regions : RegionId.Set.t) | SynthInputGivenBack | SynthRetGivenBack | FunCallGivenBack | LoopGivenBack -> () - | FunCallRet | SynthInput | Global | LoopOutput | LoopJoin | Aggregate - | ConstGeneric | TraitConst -> + | FunCallRet | SynthInput | Global | KindConstGeneric | LoopOutput | LoopJoin + | Aggregate | 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 eeb6ae1e..af545fb9 100644 --- a/compiler/InterpreterExpressions.ml +++ b/compiler/InterpreterExpressions.ml @@ -300,13 +300,29 @@ let eval_operand_no_reorganize (config : config) (op : operand) e )))) | CVar vid -> ( let ctx0 = ctx in - (* Lookup the const generic value *) - let cv = ctx_lookup_const_generic_value ctx vid in - (* Copy the value *) - let allow_adt_copy = false in - let ctx, v = copy_value allow_adt_copy config ctx cv in + (* In concrete mode: lookup the const generic value. + In symbolic mode: introduce a fresh symbolic value. + + We have nothing to do: the value is copyable, so we can freely + duplicate it. + *) + let ctx, cv = + let cv = ctx_lookup_const_generic_value ctx vid in + match config.mode with + | ConcreteMode -> + (* Copy the value - this is more of a sanity check *) + let allow_adt_copy = false in + copy_value allow_adt_copy config ctx cv + | SymbolicMode -> + (* We use the looked up value only for its type *) + let v = mk_fresh_symbolic_typed_value KindConstGeneric cv.ty in + (ctx, v) + in (* Continue *) - let e = cf v ctx in + let e = cf cv ctx in + (* 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 (e = None || is_symbolic cv.value); (* We have to wrap the generated expression *) match e with | None -> None @@ -319,7 +335,7 @@ let eval_operand_no_reorganize (config : config) (op : operand) (SymbolicAst.IntroSymbolic ( ctx0, None, - value_as_symbolic v.value, + value_as_symbolic cv.value, SymbolicAst.VaCgValue vid, e ))) | CFnPtr _ -> raise (Failure "TODO")) diff --git a/compiler/InterpreterUtils.ml b/compiler/InterpreterUtils.ml index 612d6903..d3f8f4fa 100644 --- a/compiler/InterpreterUtils.ml +++ b/compiler/InterpreterUtils.ml @@ -273,8 +273,8 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : eval_ctx) raise Found else () | SynthInput | SynthInputGivenBack | FunCallGivenBack - | SynthRetGivenBack | Global | LoopGivenBack | Aggregate | ConstGeneric - | TraitConst -> + | SynthRetGivenBack | Global | KindConstGeneric | LoopGivenBack + | Aggregate | ConstGeneric | TraitConst -> () end in diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index b4611b7e..3b30549c 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -1086,6 +1086,8 @@ let bs_ctx_fresh_state_var (ctx : bs_ctx) : bs_ctx * typed_pattern = (* Return *) (ctx, state_pat) +(** WARNING: do not call this function directly. + Call [fresh_named_var_for_symbolic_value] instead. *) let fresh_var_llbc_ty (basename : string option) (ty : T.ty) (ctx : bs_ctx) : bs_ctx * var = (* Generate the fresh variable *) @@ -2506,9 +2508,13 @@ and translate_ExpandAdt_one_branch (sv : V.symbolic_value) and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option) (sv : V.symbolic_value) (v : S.value_aggregate) (e : S.expression) (ctx : bs_ctx) : texpression = + log#ldebug + (lazy + ("translate_intro_symbolic:" ^ "\n- value aggregate: " + ^ S.show_value_aggregate v)); let mplace = translate_opt_mplace p in - (* Introduce a fresh variable for the symbolic value *) + (* Introduce a fresh variable for the symbolic value. *) let ctx, var = fresh_var_for_symbolic_value sv ctx in (* Translate the next expression *) diff --git a/compiler/Values.ml b/compiler/Values.ml index c1ff9804..60cbcc8b 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -42,6 +42,7 @@ type sv_kind = | SynthInputGivenBack (** The value was given back upon ending one of the input abstractions *) | Global (** The value is a global *) + | KindConstGeneric (** The value is a const generic *) | LoopOutput (** The output of a loop (seen as a forward computation) *) | LoopGivenBack (** A value given back by a loop (when ending abstractions while going backwards) *) -- cgit v1.2.3 From 0f61fa8c6ee1350d71845ae9dd17a488a0af4b68 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 5 Dec 2023 16:19:22 +0100 Subject: Print error messages when the command line arguments are invalid --- compiler/Main.ml | 50 ++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/compiler/Main.ml b/compiler/Main.ml index 7f98f581..835b9088 100644 --- a/compiler/Main.ml +++ b/compiler/Main.ml @@ -66,7 +66,7 @@ let () = (* Print the imported llbc *) let print_llbc = ref false in - let spec = + let spec_ls = [ ( "-backend", Arg.Symbol (backend_names, set_backend), @@ -123,7 +123,7 @@ let () = ] in - let spec = Arg.align spec in + let spec = Arg.align spec_ls in let filenames = ref [] in let add_filename f = filenames := f :: !filenames in Arg.parse spec add_filename usage; @@ -132,20 +132,50 @@ let () = exit 1 in - if !extract_template_decreases_clauses then extract_decreases_clauses := true; + (* Small helper to check the validity of the input arguments and print + an error if necessary *) + let check_arg_name name = + assert (List.exists (fun (n, _, _) -> n = name) spec_ls) + in + let check_arg_implies (arg0 : bool) (name0 : string) (arg1 : bool) + (name1 : string) : unit = + check_arg_name name0; + check_arg_name name1; + if (not arg0) || arg1 then () + else ( + log#error "Invalid command-line arguments: the use of %s requires %s" + name0 name1; + fail ()) + in + + let check_arg_not (arg0 : bool) (name0 : string) (arg1 : bool) + (name1 : string) : unit = + check_arg_name name0; + check_arg_name name1; + if (not arg0) || not arg1 then () + else ( + log#error + "Invalid command-line arguments: the use of %s is incompatible with %s" + name0 name1; + fail ()) + in + 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); + check_arg_implies + !extract_template_decreases_clauses + "-template-clauses" !extract_decreases_clauses "-decreases-clauses"; (* Sanity check: -backward-no-state-update ==> -state *) - assert ((not !backward_no_state_update) || !use_state); + check_arg_implies !backward_no_state_update "-backward-no-state-update" + !use_state "-state"; (* Sanity check: the use of decrease clauses is not compatible with the use of fuel *) - assert ( - (not !use_fuel) - || (not !extract_decreases_clauses) - && not !extract_template_decreases_clauses); + check_arg_not !use_fuel "-use-fuel" !extract_decreases_clauses + "-decreases-clauses"; (* We have: not generate_lib_entry_point ==> split_files *) - assert (!split_files || !generate_lib_entry_point); + check_arg_implies + (not !generate_lib_entry_point) + "-no-gen-lib-entry" !split_files "-split-files"; if !lean_gen_lakefile && not (!backend = Lean) then log#error "The -lean-default-lakefile option is valid only for the Lean backend"; -- cgit v1.2.3 From a212ab42927e0f9ffa3ed0dfa0140b231e725008 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 5 Dec 2023 16:32:02 +0100 Subject: Update the flake.lock --- flake.lock | 72 +++++++++++++++++++++++++++++++------------------------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/flake.lock b/flake.lock index 55f38cfb..11b4cd1b 100644 --- a/flake.lock +++ b/flake.lock @@ -8,11 +8,11 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1701269567, - "narHash": "sha256-3UsioCtoMv+FUPPJaR+sXnKzEnyW45Rl9FrWcNLpDE8=", + "lastModified": 1701790271, + "narHash": "sha256-7lLBI5dPY0VS5s9dcp5GR4myuVgMPxvRDeWXvlJ+708=", "owner": "aeneasverif", "repo": "charon", - "rev": "013396662cbdb76a09c8b70cfd13606e6c6d428f", + "rev": "71fe503c64c14b3de1b4d2dabb406f69637a4c02", "type": "github" }, "original": { @@ -29,11 +29,11 @@ ] }, "locked": { - "lastModified": 1701220101, - "narHash": "sha256-EBuCZ/Vjp3ovx8ZvfALfuUk4/76Ey/6cJmzmeXBRmDk=", + "lastModified": 1701622587, + "narHash": "sha256-o3XhxCCyrUHZ0tlta2W7/MuXzy+n0+BUt3rKFK3DIK4=", "owner": "ipetkov", "repo": "crane", - "rev": "514cd663e5af505a244e55ad013733638574aff9", + "rev": "c09d2cbe84cc2adfe1943cb2a0b55a71c835ca9a", "type": "github" }, "original": { @@ -47,11 +47,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1694529238, - "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "lastModified": 1701680307, + "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", "owner": "numtide", "repo": "flake-utils", - "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", + "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", "type": "github" }, "original": { @@ -82,11 +82,11 @@ "systems": "systems_3" }, "locked": { - "lastModified": 1694529238, - "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "lastModified": 1701680307, + "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", "owner": "numtide", "repo": "flake-utils", - "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", + "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", "type": "github" }, "original": { @@ -131,11 +131,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1701214966, - "narHash": "sha256-AmvqisPtId4Ej+xga5djjSzdxpRzx7K9CL7JvjE5BLs=", + "lastModified": 1701559887, + "narHash": "sha256-le4BDa5vGKWFKtPTyezxJVEmHIYHrfQvUjNN1eXSOVM=", "owner": "fstarlang", "repo": "fstar", - "rev": "3ad64126966f25423c7fb897412faebc540b864a", + "rev": "93bf463c9ee43c5baaabdc35c4b64f812209dcce", "type": "github" }, "original": { @@ -164,11 +164,11 @@ ] }, "locked": { - "lastModified": 1701086382, - "narHash": "sha256-g40c06xDz7dkaJIH6Sjo95FN39hJ42O5ANPmYO974D4=", + "lastModified": 1701614478, + "narHash": "sha256-VBJ4WfrS0uzIZuKjaJFB1hsZdx214TzadduFm0i0IEY=", "owner": "hacl-star", "repo": "hacl-star", - "rev": "071512259483ac2c8bbb5948634408b523b31335", + "rev": "e191abedec3725ddb5b252431cb58e9c84533704", "type": "github" }, "original": { @@ -194,11 +194,11 @@ ] }, "locked": { - "lastModified": 1701220603, - "narHash": "sha256-vQYLDG4+QRpRODMeZ7WLARtoM+IaRmi0hgTmZg4vhl0=", + "lastModified": 1701739023, + "narHash": "sha256-myjbc7KSAnsaBseS7/db1GYXAukPw1U8TcohkjLG+Iw=", "owner": "hacl-star", "repo": "hacl-nix", - "rev": "05f5ca8e7e4c12cc0bc322b3f6b8c0f8433e232a", + "rev": "fad1636fb53319d0d401c843ef23badef3d6ca18", "type": "github" }, "original": { @@ -223,11 +223,11 @@ ] }, "locked": { - "lastModified": 1701110212, - "narHash": "sha256-OrlMYgA8609l8orB41VAFJKDj/0WtiAfdOOaQjMhefs=", + "lastModified": 1701663122, + "narHash": "sha256-iGIl1cFVIC24o/5zrOzqGrLr3GF1+ktLba8j3/UeNQA=", "owner": "fstarlang", "repo": "karamel", - "rev": "4ad701968346033a986f92d9d91a837e9af95c4e", + "rev": "0644e20d7c24958e5de3aeedc47bcda0fd2bf85d", "type": "github" }, "original": { @@ -265,11 +265,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1701264285, - "narHash": "sha256-zquq62OOZE5aySVkFi4NnSGVY+YSTzipxLwO8umA4zo=", + "lastModified": 1701773410, + "narHash": "sha256-Juqn2t5UniRi7D2oGKxDtnofFvoPA3z4qxJzZTiYIRI=", "owner": "leanprover", "repo": "lean4", - "rev": "367ac01279e6a26e65fd8f5ca66ed43709c458ae", + "rev": "d4f10bc07e575de14edd08ccbcda55e6dd3fa823", "type": "github" }, "original": { @@ -318,11 +318,11 @@ "nixpkgs": "nixpkgs_7" }, "locked": { - "lastModified": 1701264285, - "narHash": "sha256-zquq62OOZE5aySVkFi4NnSGVY+YSTzipxLwO8umA4zo=", + "lastModified": 1701773410, + "narHash": "sha256-Juqn2t5UniRi7D2oGKxDtnofFvoPA3z4qxJzZTiYIRI=", "owner": "leanprover", "repo": "lean4", - "rev": "367ac01279e6a26e65fd8f5ca66ed43709c458ae", + "rev": "d4f10bc07e575de14edd08ccbcda55e6dd3fa823", "type": "github" }, "original": { @@ -405,11 +405,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1701068326, - "narHash": "sha256-vmMceA+q6hG1yrjb+MP8T0YFDQIrW3bl45e7z24IEts=", + "lastModified": 1701436327, + "narHash": "sha256-tRHbnoNI8SIM5O5xuxOmtSLnswEByzmnQcGGyNRjxsE=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "8cfef6986adfb599ba379ae53c9f5631ecd2fd9c", + "rev": "91050ea1e57e50388fa87a3302ba12d188ef723a", "type": "github" }, "original": { @@ -573,11 +573,11 @@ ] }, "locked": { - "lastModified": 1701224160, - "narHash": "sha256-qnMmxNMKmd6Soel0cfauyMJ+LzuZbvmiDQPSIuTbQ+M=", + "lastModified": 1701656211, + "narHash": "sha256-lfFXsLWH4hVbEKR6K+UcDiKxeS6Lz4FkC1DZ9LHqf9Y=", "owner": "oxalica", "repo": "rust-overlay", - "rev": "4a080e26d55eaedb95ab1bf8eeaeb84149c10f12", + "rev": "47a276e820ae4ae1b8d98a503bf09d2ceb52dfd8", "type": "github" }, "original": { -- cgit v1.2.3