From 755936c1d14ccba5600259d15eb2747f686dc4ff Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 May 2024 15:03:37 +0200 Subject: Downgrade the version of dune --- tests/test_runner/dune-project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test_runner/dune-project b/tests/test_runner/dune-project index c614e923..dc352bd0 100644 --- a/tests/test_runner/dune-project +++ b/tests/test_runner/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.12) +(lang dune 3.7) (name aeneas_test_runner) -- cgit v1.2.3 From 51c43721beb1f4af1e903360c0fbc5c1790f1ab5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Fri, 24 May 2024 15:56:34 +0200 Subject: Start adding markers --- compiler/InterpreterBorrowsCore.ml | 66 +++++++++++++++++++++++++------------- compiler/InterpreterPaths.ml | 10 +++--- compiler/InterpreterProjectors.ml | 18 +++++------ compiler/Invariants.ml | 16 +++++---- compiler/Print.ml | 18 ++++++++--- compiler/Values.ml | 16 ++++++--- 6 files changed, 94 insertions(+), 50 deletions(-) diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 2628b26a..3bef7b30 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -255,13 +255,17 @@ let lookup_loan_opt (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) (because there are no use cases requiring finer control) *) method! visit_aloan_content env lc = match lc with - | AMutLoan (bid, av) -> + | AMutLoan (pm, bid, av) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then raise (FoundGLoanContent (Abstract lc)) - else super#visit_AMutLoan env bid av - | ASharedLoan (bids, v, av) -> + else super#visit_AMutLoan env pm bid av + | ASharedLoan (pm, bids, v, av) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if BorrowId.Set.mem l bids then raise (FoundGLoanContent (Abstract lc)) - else super#visit_ASharedLoan env bids v av + else super#visit_ASharedLoan env pm bids v av | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan (_, _) | AIgnoredMutLoan (_, _) @@ -396,11 +400,15 @@ let update_aloan (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) method! visit_aloan_content env lc = match lc with - | AMutLoan (bid, av) -> - if bid = l then update () else super#visit_AMutLoan env bid av - | ASharedLoan (bids, v, av) -> + | AMutLoan (pm, bid, av) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + if bid = l then update () else super#visit_AMutLoan env pm bid av + | ASharedLoan (pm, bids, v, av) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if BorrowId.Set.mem l bids then update () - else super#visit_ASharedLoan env bids v av + else super#visit_ASharedLoan env pm bids v av | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan (_, _) | AIgnoredMutLoan (_, _) @@ -422,8 +430,8 @@ let update_aloan (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) ctx (** Lookup a borrow content from a borrow id. *) -let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) - : g_borrow_content option = +let lookup_borrow_opt (span : Meta.span) (ek : exploration_kind) + (l : BorrowId.id) (ctx : eval_ctx) : g_borrow_content option = let obj = object inherit [_] iter_eval_ctx as super @@ -453,12 +461,16 @@ let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) method! visit_aborrow_content env bc = match bc with - | AMutBorrow (bid, av) -> + | AMutBorrow (pm, bid, av) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_AMutBorrow env bid av - | ASharedBorrow bid -> + else super#visit_AMutBorrow env pm bid av + | ASharedBorrow (pm, bid) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_ASharedBorrow env bid + else super#visit_ASharedBorrow env pm bid | AIgnoredMutBorrow (_, _) | AEndedMutBorrow _ | AEndedIgnoredMutBorrow @@ -486,7 +498,7 @@ let lookup_borrow_opt (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) *) let lookup_borrow (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) (ctx : eval_ctx) : g_borrow_content = - match lookup_borrow_opt ek l ctx with + match lookup_borrow_opt span ek l ctx with | None -> craise __FILE__ __LINE__ span "Unreachable" | Some lc -> lc @@ -571,12 +583,16 @@ let update_aborrow (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) method! visit_ABorrow env bc = match bc with - | AMutBorrow (bid, av) -> + | AMutBorrow (pm, bid, av) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then update () - else ABorrow (super#visit_AMutBorrow env bid av) - | ASharedBorrow bid -> + else ABorrow (super#visit_AMutBorrow env pm bid av) + | ASharedBorrow (pm, bid) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then update () - else ABorrow (super#visit_ASharedBorrow env bid) + else ABorrow (super#visit_ASharedBorrow env pm bid) | AIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedSharedBorrow | AEndedIgnoredMutBorrow _ -> super#visit_ABorrow env bc @@ -1182,8 +1198,14 @@ let get_first_non_ignored_aloan_in_abstraction (span : Meta.span) (abs : abs) : method! visit_aloan_content env lc = match lc with - | AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) - | ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) + | AMutLoan (pm, bid, _) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + raise (FoundBorrowIds (Borrow bid)) + | ASharedLoan (pm, bids, _, _) -> + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + raise (FoundBorrowIds (Borrows bids)) | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan (_, _) -> super#visit_aloan_content env lc @@ -1232,7 +1254,7 @@ let lookup_shared_value_opt (span : Meta.span) (ctx : eval_ctx) | None -> None | Some (_, lc) -> ( match lc with - | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, sv, _)) -> + | Concrete (VSharedLoan (_, sv)) | Abstract (ASharedLoan (_, _, sv, _)) -> Some sv | _ -> None) diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index faba1088..a74017d1 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -187,7 +187,7 @@ let rec access_projection (span : Meta.span) (access : projection_access) Ok (ctx, { res with updated = v })) | ( _, Abstract - ( AMutLoan (_, _) + ( AMutLoan (_, _, _) | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan (_, _) @@ -197,7 +197,9 @@ let rec access_projection (span : Meta.span) (access : projection_access) | AIgnoredSharedLoan _ ) ) -> craise __FILE__ __LINE__ span "Expected a shared (abstraction) loan" - | _, Abstract (ASharedLoan (bids, sv, _av)) -> ( + | _, Abstract (ASharedLoan (pm, bids, sv, _av)) -> ( + (* Sanity check: markers can only appear when we're doing a join *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Explore the shared value *) match access_projection span access ctx update p' sv with | Error err -> Error err @@ -205,14 +207,14 @@ let rec access_projection (span : Meta.span) (access : projection_access) (* Relookup the child avalue *) let av = match lookup_loan span ek bid ctx with - | _, Abstract (ASharedLoan (_, _, av)) -> av + | _, Abstract (ASharedLoan (_, _, _, av)) -> av | _ -> craise __FILE__ __LINE__ span "Unexpected" in (* Update the shared loan with the new value returned by {!access_projection} *) let ctx = update_aloan span ek bid - (ASharedLoan (bids, res.updated, av)) + (ASharedLoan (pm, bids, res.updated, av)) ctx in (* Return - note that we don't need to update the borrow itself *) diff --git a/compiler/InterpreterProjectors.ml b/compiler/InterpreterProjectors.ml index a887c44c..0e820982 100644 --- a/compiler/InterpreterProjectors.ml +++ b/compiler/InterpreterProjectors.ml @@ -61,7 +61,7 @@ let rec apply_proj_borrows_on_shared_borrow (span : Meta.span) (ctx : eval_ctx) let asb = match sv with | _, Concrete (VSharedLoan (_, sv)) - | _, Abstract (ASharedLoan (_, sv, _)) -> + | _, Abstract (ASharedLoan (_, _, sv, _)) -> apply_proj_borrows_on_shared_borrow span ctx fresh_reborrow regions sv ref_ty | _ -> craise __FILE__ __LINE__ span "Unexpected" @@ -137,7 +137,7 @@ let rec apply_proj_borrows (span : Meta.span) (check_symbolic_no_ended : bool) apply_proj_borrows span check_symbolic_no_ended ctx fresh_reborrow regions ancestors_regions bv ref_ty in - AMutBorrow (bid, bv) + AMutBorrow (PNone, 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 @@ -150,7 +150,7 @@ let rec apply_proj_borrows (span : Meta.span) (check_symbolic_no_ended : bool) need to lookup the shared value and project it (see the other branch of the [if then else]). *) - ASharedBorrow bid + ASharedBorrow (PNone, bid) | VReservedMutBorrow _, _ -> craise __FILE__ __LINE__ span "Can't apply a proj_borrow over a reserved mutable borrow" @@ -183,7 +183,7 @@ let rec apply_proj_borrows (span : Meta.span) (check_symbolic_no_ended : bool) let asb = match sv with | _, Concrete (VSharedLoan (_, sv)) - | _, Abstract (ASharedLoan (_, sv, _)) -> + | _, Abstract (ASharedLoan (_, _, sv, _)) -> apply_proj_borrows_on_shared_borrow span ctx fresh_reborrow regions sv ref_ty | _ -> craise __FILE__ __LINE__ span "Unexpected" @@ -288,7 +288,7 @@ let apply_proj_loans_on_symbolic_expansion (span : Meta.span) * we never project over static regions) *) if region_in_set r regions then (* In the set: keep *) - (ALoan (AMutLoan (bid, child_av)), ref_ty) + (ALoan (AMutLoan (PNone, bid, child_av)), ref_ty) else (* Not in the set: ignore *) (* If the borrow id is in the ancestor's regions, we still need @@ -307,7 +307,7 @@ let apply_proj_loans_on_symbolic_expansion (span : Meta.span) if region_in_set r regions then (* In the set: keep *) let shared_value = mk_typed_value_from_symbolic_value spc in - (ALoan (ASharedLoan (bids, shared_value, child_av)), ref_ty) + (ALoan (ASharedLoan (PNone, bids, shared_value, child_av)), ref_ty) else (* Not in the set: ignore *) (ALoan (AIgnoredSharedLoan child_av), ref_ty) @@ -441,7 +441,7 @@ let apply_reborrows (span : Meta.span) method! visit_aloan_content env lc = match lc with - | ASharedLoan (bids, sv, av) -> + | ASharedLoan (pm, bids, sv, av) -> (* Insert the reborrows *) let bids = insert_reborrows bids in (* Similarly to the non-abstraction case: check if the shared @@ -453,9 +453,9 @@ let apply_reborrows (span : Meta.span) | Some bid -> insert_reborrows_for_bid bids bid in (* Update and explore *) - super#visit_ASharedLoan env bids sv av + super#visit_ASharedLoan env pm bids sv av | AIgnoredSharedLoan _ - | AMutLoan (_, _) + | AMutLoan (_, _, _) | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan (_, _) | AIgnoredMutLoan (_, _) diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index 51be02c8..bcf92b25 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -246,8 +246,8 @@ let check_loans_borrows_relation_invariant (span : Meta.span) (ctx : eval_ctx) : method! visit_aborrow_content env bc = let _ = match bc with - | AMutBorrow (bid, _) -> register_borrow BMut bid - | ASharedBorrow bid -> register_borrow BShared 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 @@ -341,8 +341,8 @@ let check_borrowed_values_invariant (span : Meta.span) (ctx : eval_ctx) : unit = (* Update the info *) let info = match lc with - | AMutLoan (_, _) -> set_outer_mut info - | ASharedLoan (_, _, _) -> set_outer_shared info + | AMutLoan (_, _, _) -> set_outer_mut info + | ASharedLoan (_, _, _, _) -> set_outer_shared info | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } -> set_outer_mut info | AEndedSharedLoan (_, _) -> set_outer_shared info @@ -359,7 +359,7 @@ let check_borrowed_values_invariant (span : Meta.span) (ctx : eval_ctx) : unit = (* Update the info *) let info = match bc with - | AMutBorrow (_, _) -> set_outer_mut info + | AMutBorrow (_, _, _) -> set_outer_mut info | ASharedBorrow _ | AEndedSharedBorrow -> set_outer_shared info | AIgnoredMutBorrow _ | AEndedMutBorrow _ | AEndedIgnoredMutBorrow _ -> @@ -500,9 +500,11 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan span ek_all bid ctx in match glc with - | Concrete (VSharedLoan (_, sv)) - | Abstract (ASharedLoan (_, sv, _)) -> + | Concrete (VSharedLoan (_, sv)) -> sanity_check __FILE__ __LINE__ (sv.ty = ref_ty) span + | Abstract (ASharedLoan (pm, _, sv, _)) -> + sanity_check __FILE__ __LINE__ (sv.ty = ref_ty) span; + sanity_check __FILE__ __LINE__ (pm = PNone) span | _ -> craise __FILE__ __LINE__ span "Inconsistent context") | VMutBorrow (_, bv), RMut -> sanity_check __FILE__ __LINE__ diff --git a/compiler/Print.ml b/compiler/Print.ml index f7f1f54b..12506274 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -148,6 +148,12 @@ module Values = struct | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" + let add_proj_marker (pm : proj_marker) (s : string) : string = + match pm with + | PNone -> s + | PLeft -> "|" ^ s ^ "|" + | PRight -> "┊" ^ s ^ "┊" + let rec typed_avalue_to_string ?(span : Meta.span option = None) (env : fmt_env) (v : typed_avalue) : string = match v.value with @@ -197,17 +203,19 @@ module Values = struct and aloan_content_to_string ?(span : Meta.span option = None) (env : fmt_env) (lc : aloan_content) : string = match lc with - | AMutLoan (bid, av) -> + | AMutLoan (pm, bid, av) -> "@mut_loan(" ^ BorrowId.to_string bid ^ ", " ^ typed_avalue_to_string ~span env av ^ ")" - | ASharedLoan (loans, v, av) -> + |> add_proj_marker pm + | ASharedLoan (pm, loans, v, av) -> let loans = BorrowId.Set.to_string None loans in "@shared_loan(" ^ loans ^ ", " ^ typed_value_to_string ~span env v ^ ", " ^ typed_avalue_to_string ~span env av ^ ")" + |> add_proj_marker pm | AEndedMutLoan ml -> "@ended_mut_loan{" ^ typed_avalue_to_string ~span env ml.child @@ -238,11 +246,13 @@ module Values = struct and aborrow_content_to_string ?(span : Meta.span option = None) (env : fmt_env) (bc : aborrow_content) : string = match bc with - | AMutBorrow (bid, av) -> + | AMutBorrow (pm, bid, av) -> "mb@" ^ BorrowId.to_string bid ^ " (" ^ typed_avalue_to_string ~span env av ^ ")" - | ASharedBorrow bid -> "sb@" ^ BorrowId.to_string bid + |> add_proj_marker pm + | ASharedBorrow (pm, bid) -> + "sb@" ^ BorrowId.to_string bid |> add_proj_marker pm | AIgnoredMutBorrow (opt_bid, av) -> "@ignored_mut_borrow(" ^ option_to_string BorrowId.to_string opt_bid diff --git a/compiler/Values.ml b/compiler/Values.ml index e7b96051..96d61f88 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -176,6 +176,10 @@ 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] +(** Projection markers: those are used in the joins. + For additional explanations see: https://arxiv.org/pdf/2404.02680#section.5 *) +type proj_marker = PNone | PLeft | PRight [@@deriving show, ord] + (** Ancestor for {!typed_avalue} iter visitor *) class ['self] iter_typed_avalue_base = object (self : 'self) @@ -192,6 +196,8 @@ class ['self] iter_typed_avalue_base = method visit_abstraction_id_set : 'env -> abstraction_id_set -> unit = fun env ids -> AbstractionId.Set.iter (self#visit_abstraction_id env) ids + + method visit_proj_marker : 'env -> proj_marker -> unit = fun _ _ -> () end (** Ancestor for {!typed_avalue} map visitor *) @@ -212,6 +218,8 @@ class ['self] map_typed_avalue_base = method visit_abstraction_id_set : 'env -> abstraction_id_set -> abstraction_id_set = fun env ids -> AbstractionId.Set.map (self#visit_abstraction_id env) ids + + method visit_proj_marker : 'env -> proj_marker -> proj_marker = fun _ x -> x end (** When giving shared borrows to functions (i.e., inserting shared borrows inside @@ -333,7 +341,7 @@ and adt_avalue = { contain other, independent loans. *) and aloan_content = - | AMutLoan of loan_id * typed_avalue + | AMutLoan of proj_marker * loan_id * typed_avalue (** A mutable loan owned by an abstraction. The avalue is the child avalue. @@ -354,7 +362,7 @@ and aloan_content = px -> mut_borrow l0 (mut_borrow @s1) ]} *) - | ASharedLoan of loan_id_set * typed_value * typed_avalue + | ASharedLoan of proj_marker * loan_id_set * typed_value * typed_avalue (** A shared loan owned by an abstraction. The avalue is the child avalue. @@ -507,7 +515,7 @@ and aloan_content = ids)? *) and aborrow_content = - | AMutBorrow of borrow_id * typed_avalue + | AMutBorrow of proj_marker * borrow_id * typed_avalue (** A mutable borrow owned by an abstraction. Is used when an abstraction "consumes" borrows, when giving borrows @@ -528,7 +536,7 @@ and aborrow_content = > abs0 { a_mut_borrow l0 (U32 0) _ } ]} *) - | ASharedBorrow of borrow_id + | ASharedBorrow of proj_marker * borrow_id (** A shared borrow owned by an abstraction. Example: -- cgit v1.2.3 From 506e9dc3f8f2759769c3293e9cbeba5d6fe79a31 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Mon, 27 May 2024 16:03:36 +0200 Subject: Add markers everywhere, do not use them yet --- compiler/InterpreterBorrows.ml | 188 +++++++++++++++++++++++---------- compiler/InterpreterBorrows.mli | 31 +++++- compiler/InterpreterLoops.ml | 16 ++- compiler/InterpreterLoopsCore.ml | 18 +++- compiler/InterpreterLoopsFixedPoint.ml | 33 ++++-- compiler/InterpreterLoopsJoinCtxs.ml | 33 ++++-- compiler/InterpreterLoopsMatchCtxs.ml | 68 +++++++----- compiler/Invariants.ml | 26 +++-- compiler/SymbolicToPure.ml | 16 +-- compiler/Values.ml | 12 +-- 10 files changed, 302 insertions(+), 139 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index ef958d2c..93238729 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -135,17 +135,19 @@ let end_borrow_get_borrow (span : Meta.span) * need it to properly instantiate the backward functions when generating * the pure translation. *) match lc with - | AMutLoan (_, _) -> + | AMutLoan (pm, _, _) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Nothing special to do *) super#visit_ALoan outer lc - | ASharedLoan (bids, v, av) -> + | ASharedLoan (pm, bids, v, av) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* 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 *) - ALoan (ASharedLoan (bids, v, av)) + ALoan (ASharedLoan (pm, bids, v, av)) | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan _ (* The loan has ended, so no need to update the outer borrows *) @@ -159,7 +161,8 @@ let end_borrow_get_borrow (span : Meta.span) method! visit_ABorrow outer bc = match bc with - | AMutBorrow (bid, _) -> + | AMutBorrow (pm, bid, _) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Check if this is the borrow we are looking for *) if bid = l then ( (* TODO: treat this case differently. We should not introduce @@ -188,7 +191,8 @@ let end_borrow_get_borrow (span : Meta.span) (* Update the outer borrows before diving into the child avalue *) let outer = update_outer_borrows outer (Borrow bid) in super#visit_ABorrow outer bc - | ASharedBorrow bid -> + | ASharedBorrow (pm, bid) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* 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 @@ -338,7 +342,7 @@ let give_back_value (config : config) (span : Meta.span) (bid : BorrowId.id) match nv.value with | VSymbolic sv -> let abs = Option.get opt_abs in - (* Remember the given back value as a span-value + (* Remember the given back value as a meta-value * TODO: it is a bit annoying to have to deconstruct * the value... Think about a more elegant way. *) let given_back_span = as_symbolic span nv.value in @@ -377,14 +381,15 @@ let give_back_value (config : config) (span : Meta.span) (bid : BorrowId.id) ty in match lc with - | AMutLoan (bid', child) -> + | AMutLoan (pm, bid', child) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; 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 * an ended loan *) (* Register the insertion *) set_replaced (); - (* Remember the given back value as a span-value *) + (* Remember the given back value as a meta-value *) let given_back_span = nv in (* Apply the projection *) let given_back = @@ -397,7 +402,8 @@ let give_back_value (config : config) (span : Meta.span) (bid : BorrowId.id) ALoan (AEndedMutLoan { child; given_back; given_back_span })) else (* Continue exploring *) super#visit_ALoan opt_abs lc - | ASharedLoan (_, _, _) -> + | ASharedLoan (pm, _, _, _) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* We are giving back a value to a *mutable* loan: nothing special to do *) super#visit_ALoan opt_abs lc | AEndedMutLoan { child = _; given_back = _; given_back_span = _ } @@ -408,7 +414,7 @@ let give_back_value (config : config) (span : Meta.span) (bid : BorrowId.id) (* 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 - (* Remember the given back value as a span-value *) + (* Remember the given back value as a meta-value *) let given_back_span = nv in (* Note that we replace the ignored mut loan by an *ended* ignored * mut loan. Also, this is not the loan we are looking for *per se*: @@ -453,7 +459,7 @@ let give_back_symbolic_value (_config : config) (span : Meta.span) sanity_check __FILE__ __LINE__ (sv.sv_id <> nsv.sv_id && ty_is_rty proj_ty) span; - (* Store the given-back value as a span-value for synthesis purposes *) + (* 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 : abs) local_given_back = @@ -531,7 +537,8 @@ let give_back_avalue_to_same_abstraction (_config : config) (span : Meta.span) method visit_typed_ALoan (opt_abs : abs option) (ty : rty) (lc : aloan_content) : avalue = match lc with - | AMutLoan (bid', child) -> + | AMutLoan (pm, bid', child) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; 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}) @@ -553,12 +560,13 @@ let give_back_avalue_to_same_abstraction (_config : config) (span : Meta.span) (AEndedMutLoan { given_back = nv; child; given_back_span = nsv })) else (* Continue exploring *) super#visit_ALoan opt_abs lc - | ASharedLoan (_, _, _) + | ASharedLoan (PNone, _, _, _) (* We are giving back a value to a *mutable* loan: nothing special to do *) | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } | AEndedSharedLoan (_, _) -> (* Nothing special to do *) super#visit_ALoan opt_abs lc + | ASharedLoan (_, _, _, _) -> internal_error __FILE__ __LINE__ span | AIgnoredMutLoan (bid_opt, child) -> (* This loan is ignored, but we may have to project on a subvalue * of the value which is given back *) @@ -631,10 +639,12 @@ let give_back_shared _config (span : Meta.span) (bid : BorrowId.id) method! visit_ALoan opt_abs lc = match lc with - | AMutLoan (bid, av) -> + | AMutLoan (pm, bid, av) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Nothing special to do (we are giving back a *shared* borrow) *) - ALoan (super#visit_AMutLoan opt_abs bid av) - | ASharedLoan (bids, shared_value, child) -> + ALoan (super#visit_AMutLoan opt_abs pm bid av) + | ASharedLoan (pm, bids, shared_value, child) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; if BorrowId.Set.mem bid bids then ( (* This is the loan we are looking for *) set_replaced (); @@ -646,7 +656,7 @@ let give_back_shared _config (span : Meta.span) (bid : BorrowId.id) else ALoan (ASharedLoan - (BorrowId.Set.remove bid bids, shared_value, child))) + (pm, BorrowId.Set.remove bid bids, shared_value, child))) else (* Not the loan we are looking for: continue exploring *) super#visit_ALoan opt_abs lc @@ -700,13 +710,14 @@ let reborrow_shared (span : Meta.span) (original_bid : BorrowId.id) VSharedLoan (bids', sv)) else super#visit_VSharedLoan env bids sv - method! visit_ASharedLoan env bids v av = + method! visit_ASharedLoan env pm bids v av = + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* This case is similar to the {!SharedLoan} case *) if BorrowId.Set.mem original_bid bids then ( set_ref (); let bids' = BorrowId.Set.add new_bid bids in - ASharedLoan (bids', v, av)) - else super#visit_ASharedLoan env bids v av + ASharedLoan (pm, bids', v, av)) + else super#visit_ASharedLoan env pm bids v av end in @@ -789,8 +800,9 @@ let give_back (config : config) (span : Meta.span) (l : BorrowId.id) span; (* Update the context *) give_back_shared config span l ctx - | Abstract (AMutBorrow (l', av)) -> + | Abstract (AMutBorrow (pm, l', av)) -> (* Sanity check *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; sanity_check __FILE__ __LINE__ (l' = l) span; (* Check that the corresponding loan is somewhere - purely a sanity check *) sanity_check __FILE__ __LINE__ @@ -806,8 +818,9 @@ let give_back (config : config) (span : Meta.span) (l : BorrowId.id) give_back_avalue_to_same_abstraction config span l av (mk_typed_value_from_symbolic_value sv) ctx - | Abstract (ASharedBorrow l') -> + | Abstract (ASharedBorrow (pm, l')) -> (* Sanity check *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; sanity_check __FILE__ __LINE__ (l' = l) span; (* Check that the borrow is somewhere - purely a sanity check *) sanity_check __FILE__ __LINE__ @@ -827,7 +840,7 @@ let give_back (config : config) (span : Meta.span) (l : BorrowId.id) let check_borrow_disappeared (span : Meta.span) (fun_name : string) (l : BorrowId.id) (ctx0 : eval_ctx) (ctx : eval_ctx) : unit = - (match lookup_borrow_opt ek_all l ctx with + (match lookup_borrow_opt span ek_all l ctx with | None -> () (* Ok *) | Some _ -> log#ltrace @@ -1205,7 +1218,8 @@ and end_abstraction_borrows (config : config) (span : Meta.span) ^ aborrow_content_to_string ~span:(Some span) ctx bc)); let ctx = match bc with - | AMutBorrow (bid, av) -> + | AMutBorrow (pm, bid, av) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* First, convert the avalue to a (fresh symbolic) value *) let sv = convert_avalue_to_given_back_value span av in (* Replace the mut borrow to register the fact that we ended @@ -1215,7 +1229,8 @@ and end_abstraction_borrows (config : config) (span : Meta.span) (* Give the value back *) let sv = mk_typed_value_from_symbolic_value sv in give_back_value config span bid sv ctx - | ASharedBorrow bid -> + | ASharedBorrow (pm, bid) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Replace the shared borrow to account for the fact it ended *) let ended_borrow = ABorrow AEndedSharedBorrow in let ctx = update_aborrow span ek_all bid ended_borrow ctx in @@ -1637,7 +1652,8 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) | ALoan lc -> ( (* Explore the loan content *) match lc with - | ASharedLoan (bids, sv, child_av) -> + | ASharedLoan (pm, bids, sv, child_av) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* We don't support nested borrows for now *) cassert __FILE__ __LINE__ (not (value_has_borrows ctx sv.value)) @@ -1648,7 +1664,7 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) in (* Push a value *) let ignored = mk_aignored span child_av.ty in - let value = ALoan (ASharedLoan (bids, sv, ignored)) in + let value = ALoan (ASharedLoan (pm, bids, sv, ignored)) in push { value; ty }; (* Explore the child *) list_avalues false push_fail child_av; @@ -1659,12 +1675,13 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) exactly the same way as [list_avalues] (i.e., with a similar signature) *) List.iter push avl - | AMutLoan (bid, child_av) -> + | AMutLoan (pm, bid, child_av) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Explore the child *) list_avalues false push_fail child_av; (* Explore the whole loan *) let ignored = mk_aignored span child_av.ty in - let value = ALoan (AMutLoan (bid, ignored)) in + let value = ALoan (AMutLoan (pm, bid, ignored)) in push { value; ty } | AIgnoredMutLoan (opt_bid, child_av) -> (* We don't support nested borrows for now *) @@ -1691,14 +1708,16 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) sanity_check __FILE__ __LINE__ allow_borrows span; (* Explore the borrow content *) match bc with - | AMutBorrow (bid, child_av) -> + | AMutBorrow (pm, bid, child_av) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Explore the child *) list_avalues false push_fail child_av; (* Explore the borrow *) let ignored = mk_aignored span child_av.ty in - let value = ABorrow (AMutBorrow (bid, ignored)) in + let value = ABorrow (AMutBorrow (pm, bid, ignored)) in push { value; ty } - | ASharedBorrow _ -> + | ASharedBorrow (pm, _) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Nothing specific to do: keep the value as it is *) push av | AIgnoredMutBorrow (opt_bid, child_av) -> @@ -1777,7 +1796,7 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) let sv = mk_value_with_fresh_sids sv in (* Create the new avalue *) let value = - ALoan (ASharedLoan (bids, sv, mk_aignored span ty)) + ALoan (ASharedLoan (PNone, bids, sv, mk_aignored span ty)) in { value; ty } in @@ -1900,7 +1919,7 @@ let convert_value_to_abstractions (span : Meta.span) (abs_kind : abs_kind) cassert __FILE__ __LINE__ (ty_no_regions ref_ty) span "Nested borrows are not supported yet"; let ty = TRef (RFVar r_id, ref_ty, kind) in - let value = ABorrow (ASharedBorrow bid) in + let value = ABorrow (ASharedBorrow (PNone, bid)) in ([ { value; ty } ], v) | VMutBorrow (bid, bv) -> let r_id = if group then r_id else fresh_region_id () in @@ -1911,7 +1930,7 @@ let convert_value_to_abstractions (span : Meta.span) (abs_kind : abs_kind) (* Create an avalue to push - note that we use [AIgnore] for the inner avalue *) let ty = TRef (RFVar r_id, ref_ty, kind) in let ignored = mk_aignored span ref_ty in - let av = ABorrow (AMutBorrow (bid, ignored)) in + let av = ABorrow (AMutBorrow (PNone, 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) *) @@ -1937,7 +1956,7 @@ let convert_value_to_abstractions (span : Meta.span) (abs_kind : abs_kind) let ignored = mk_aignored span ty in (* Rem.: the shared value might contain loans *) let avl, sv = to_avalues false true true r_id sv in - let av = ALoan (ASharedLoan (bids, sv, ignored)) in + let av = ALoan (ASharedLoan (PNone, 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) *) @@ -1954,7 +1973,7 @@ let convert_value_to_abstractions (span : Meta.span) (abs_kind : abs_kind) "Nested borrows are not supported yet"; let ty = mk_ref_ty (RFVar r_id) ty RMut in let ignored = mk_aignored span ty in - let av = ALoan (AMutLoan (bid, ignored)) in + let av = ALoan (AMutLoan (PNone, bid, ignored)) in let av = { value = av; ty } in ([ av ], v)) | VSymbolic _ -> @@ -2085,8 +2104,14 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) in (* Register the loans *) (match lc with - | ASharedLoan (bids, _, _) -> push_loans bids (Abstract (ty, lc)) - | AMutLoan (bid, _) -> push_loan bid (Abstract (ty, lc)) + | ASharedLoan (pm, bids, _, _) -> + (* TODO: We should keep track of the marker here *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + push_loans bids (Abstract (ty, lc)) + | AMutLoan (pm, bid, _) -> + (* TODO: We should keep track of the marker here *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + push_loan bid (Abstract (ty, lc)) | AEndedMutLoan _ | AEndedSharedLoan _ | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) @@ -2102,8 +2127,14 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) in (* Explore the borrow content *) (match bc with - | AMutBorrow (bid, _) -> push_borrow bid (Abstract (ty, bc)) - | ASharedBorrow bid -> push_borrow bid (Abstract (ty, bc)) + | AMutBorrow (pm, bid, _) -> + (* TODO: We should keep track of the marker here *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + push_borrow bid (Abstract (ty, bc)) + | ASharedBorrow (pm, bid) -> + (* TODO: We should keep track of the marker here *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; + push_borrow bid (Abstract (ty, bc)) | AProjSharedBorrow asb -> let register asb = match asb with @@ -2140,29 +2171,50 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) type merge_duplicates_funcs = { merge_amut_borrows : - borrow_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; + borrow_id -> + rty -> + proj_marker -> + typed_avalue -> + rty -> + proj_marker -> + typed_avalue -> + typed_avalue; (** Parameters: - [id] - [ty0] + - [pm0] - [child0] - [ty1] + - [pm1] - [child1] The children should be [AIgnored]. *) - merge_ashared_borrows : borrow_id -> rty -> rty -> typed_avalue; + merge_ashared_borrows : + borrow_id -> rty -> proj_marker -> rty -> proj_marker -> typed_avalue; (** Parameters: - [id] - [ty0] + - [pm0] - [ty1] + - [pm1] *) merge_amut_loans : - loan_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; + loan_id -> + rty -> + proj_marker -> + typed_avalue -> + rty -> + proj_marker -> + typed_avalue -> + typed_avalue; (** Parameters: - [id] - [ty0] + - [pm0] - [child0] - [ty1] + - [pm1] - [child1] The children should be [AIgnored]. @@ -2170,18 +2222,22 @@ type merge_duplicates_funcs = { merge_ashared_loans : loan_id_set -> rty -> + proj_marker -> typed_value -> typed_avalue -> rty -> + proj_marker -> typed_value -> typed_avalue -> typed_avalue; (** Parameters: - [ids] - [ty0] + - [pm0] - [sv0] - [child0] - [ty1] + - [pm1] - [sv1] - [child1] *) @@ -2301,10 +2357,19 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) let merge_aborrow_contents (ty0 : rty) (bc0 : aborrow_content) (ty1 : rty) (bc1 : aborrow_content) : typed_avalue = match (bc0, bc1) with - | 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 + | AMutBorrow (pm0, id0, child0), AMutBorrow (pm1, id1, child1) -> + (* Sanity-check of the precondition *) + sanity_check __FILE__ __LINE__ (id0 = id1) span; + (* TODO: We should handle the markers here *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; + (Option.get merge_funs).merge_amut_borrows id0 ty0 pm0 child0 ty1 pm1 + child1 + | ASharedBorrow (pm0, id0), ASharedBorrow (pm1, id1) -> + (* Sanity-check of the precondition *) + sanity_check __FILE__ __LINE__ (id0 = id1) span; + (* TODO: We should handle the markers here *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; + (Option.get merge_funs).merge_ashared_borrows id0 ty0 pm0 ty1 pm1 | AProjSharedBorrow _, AProjSharedBorrow _ -> (* Unreachable because requires nested borrows *) craise __FILE__ __LINE__ span "Unreachable" @@ -2330,12 +2395,21 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) (lc1 : aloan_content) : typed_avalue option = match (lc0, lc1) with - | AMutLoan (id, child0), AMutLoan (_, child1) -> + | AMutLoan (pm0, id0, child0), AMutLoan (pm1, id1, child1) -> + (* Sanity-check of the precondition *) + sanity_check __FILE__ __LINE__ (id0 = id1) span; + (* TODO: We should handle the markers here *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; (* Register the loan id *) - set_loan_as_merged id; + set_loan_as_merged id0; (* Merge *) - Some ((Option.get merge_funs).merge_amut_loans id ty0 child0 ty1 child1) - | ASharedLoan (ids0, sv0, child0), ASharedLoan (ids1, sv1, child1) -> + Some + ((Option.get merge_funs).merge_amut_loans id0 ty0 pm0 child0 ty1 pm1 + child1) + | ASharedLoan (pm0, ids0, sv0, child0), ASharedLoan (pm1, ids1, sv1, child1) + -> + (* TODO: We should handle the markers here *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; (* Filter the ids *) let ids0 = filter_bids ids0 in let ids1 = filter_bids ids1 in @@ -2368,8 +2442,8 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) set_loans_as_merged ids; (* Merge *) Some - ((Option.get merge_funs).merge_ashared_loans ids ty0 sv0 child0 ty1 - sv1 child1)) + ((Option.get merge_funs).merge_ashared_loans ids ty0 pm0 sv0 child0 + ty1 pm1 sv1 child1)) | _ -> (* Unreachable because those cases are ignored (ended/ignored borrows) or inconsistent *) @@ -2471,7 +2545,9 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) craise __FILE__ __LINE__ span "Unreachable" | Abstract (ty, lc) -> ( match lc with - | ASharedLoan (bids, sv, child) -> + | ASharedLoan (pm, bids, sv, child) -> + (* TODO: We should handle the markers here *) + sanity_check __FILE__ __LINE__ (pm = PNone) span; let bids = filter_bids bids in sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) @@ -2481,7 +2557,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv.value)) span; - let lc = ASharedLoan (bids, sv, child) in + let lc = ASharedLoan (pm, bids, sv, child) in set_loans_as_merged bids; Some { value = ALoan lc; ty } | AMutLoan _ -> diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 56df9344..c119311f 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -138,29 +138,50 @@ val convert_value_to_abstractions : *) type merge_duplicates_funcs = { merge_amut_borrows : - borrow_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; + borrow_id -> + rty -> + proj_marker -> + typed_avalue -> + rty -> + proj_marker -> + typed_avalue -> + typed_avalue; (** Parameters: - [id] - [ty0] + - [pm0] - [child0] - [ty1] + - [pm1] - [child1] The children should be [AIgnored]. *) - merge_ashared_borrows : borrow_id -> rty -> rty -> typed_avalue; + merge_ashared_borrows : + borrow_id -> rty -> proj_marker -> rty -> proj_marker -> typed_avalue; (** Parameters: - [id] - [ty0] + - [pm0] - [ty1] + - [pm1] *) merge_amut_loans : - loan_id -> rty -> typed_avalue -> rty -> typed_avalue -> typed_avalue; + loan_id -> + rty -> + proj_marker -> + typed_avalue -> + rty -> + proj_marker -> + typed_avalue -> + typed_avalue; (** Parameters: - [id] - [ty0] + - [pm0] - [child0] - [ty1] + - [pm1] - [child1] The children should be [AIgnored]. @@ -168,18 +189,22 @@ type merge_duplicates_funcs = { merge_ashared_loans : loan_id_set -> rty -> + proj_marker -> typed_value -> typed_avalue -> rty -> + proj_marker -> typed_value -> typed_avalue -> typed_avalue; (** Parameters: - [ids] - [ty0] + - [pm0] - [sv0] - [child0] - [ty1] + - [pm1] - [sv1] - [child1] *) diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 776cb6fa..7714f5bb 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -144,7 +144,7 @@ let eval_loop_symbolic (config : config) (span : span) ^ eval_ctx_to_string ~span:(Some span) ctx)); (* Compute the end expression, that is the expresion corresponding to the - end of the functin where we call the loop (for now, when calling a loop + end of the function where we call the loop (for now, when calling a loop we never get out) *) let res_fun_end = comp cf_prepare @@ -255,10 +255,13 @@ let eval_loop_symbolic (config : config) (span : span) List.filter_map (fun (av : typed_avalue) -> match av.value with - | ABorrow (AMutBorrow (bid, child_av)) -> + | ABorrow (AMutBorrow (pm, bid, child_av)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; Some (bid, child_av.ty) - | ABorrow (ASharedBorrow _) -> None + | ABorrow (ASharedBorrow (pm, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + None | _ -> craise __FILE__ __LINE__ span "Unreachable") borrows in @@ -268,10 +271,13 @@ let eval_loop_symbolic (config : config) (span : span) List.filter_map (fun (av : typed_avalue) -> match av.value with - | ALoan (AMutLoan (bid, child_av)) -> + | ALoan (AMutLoan (pm, bid, child_av)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; Some bid - | ALoan (ASharedLoan _) -> None + | ALoan (ASharedLoan (pm, _, _, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + None | _ -> craise __FILE__ __LINE__ span "Unreachable") loans in diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 991f259f..675dc544 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -65,7 +65,7 @@ module type PrimMatcher = sig val match_distinct_adts : eval_ctx -> eval_ctx -> ety -> adt_value -> adt_value -> typed_value - (** The span-value is the result of a match. + (** The meta-value is the result of a match. We take an additional function as input, which acts as a matcher over typed values, to be able to lookup the shared values and match them. @@ -158,8 +158,10 @@ module type PrimMatcher = sig (** Parameters: [ty0] + [pm0] [bid0] [ty1] + [pm1] [bid1] [ty]: result of matching ty0 and ty1 *) @@ -167,17 +169,21 @@ module type PrimMatcher = sig eval_ctx -> eval_ctx -> rty -> + proj_marker -> borrow_id -> rty -> + proj_marker -> borrow_id -> rty -> typed_avalue (** Parameters: [ty0] + [pm0] [bid0] [av0] [ty1] + [pm1] [bid1] [av1] [ty]: result of matching ty0 and ty1 @@ -187,9 +193,11 @@ module type PrimMatcher = sig eval_ctx -> eval_ctx -> rty -> + proj_marker -> borrow_id -> typed_avalue -> rty -> + proj_marker -> borrow_id -> typed_avalue -> rty -> @@ -198,10 +206,12 @@ module type PrimMatcher = sig (** Parameters: [ty0] + [pm0] [ids0] [v0] [av0] [ty1] + [pm1] [ids1] [v1] [av1] @@ -213,10 +223,12 @@ module type PrimMatcher = sig eval_ctx -> eval_ctx -> rty -> + proj_marker -> loan_id_set -> typed_value -> typed_avalue -> rty -> + proj_marker -> loan_id_set -> typed_value -> typed_avalue -> @@ -227,9 +239,11 @@ module type PrimMatcher = sig (** Parameters: [ty0] + [pm0] [id0] [av0] [ty1] + [pm1] [id1] [av1] [ty]: result of matching ty0 and ty1 @@ -239,9 +253,11 @@ module type PrimMatcher = sig eval_ctx -> eval_ctx -> rty -> + proj_marker -> borrow_id -> typed_avalue -> rty -> + proj_marker -> borrow_id -> typed_avalue -> rty -> diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 1a0bb090..599fabfd 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -153,13 +153,19 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) *) let get_borrow_id (av : typed_avalue) : BorrowId.id = match av.value with - | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid + | ABorrow (AMutBorrow (pm, bid, _) | ASharedBorrow (pm, bid)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + bid | _ -> craise __FILE__ __LINE__ span "Unexpected" in 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 + | ALoan (AMutLoan (pm, lid, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + lid + | ALoan (ASharedLoan (pm, lids, _, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + BorrowId.Set.min_elt lids | _ -> craise __FILE__ __LINE__ span "Unexpected" in (* We use ordered maps to reorder the borrows and loans *) @@ -245,7 +251,8 @@ let prepare_ashared_loans (span : Meta.span) (loop_id : LoopId.id option) : SL {l0, l1} s0 ]} - and introduce the corresponding abstraction: + and introduce the corresponding abstraction for the borrow l0 + (and we do something similar for l1): {[ abs'2 { SB l0, SL {l2} s2 } ]} @@ -283,13 +290,13 @@ let prepare_ashared_loans (span : Meta.span) (loop_id : LoopId.id option) : (* Create the shared loan *) let loan_rty = TRef (RFVar nrid, rty, RShared) in let loan_value = - ALoan (ASharedLoan (BorrowId.Set.singleton nlid, nsv, child_av)) + ALoan (ASharedLoan (PNone, BorrowId.Set.singleton nlid, nsv, child_av)) in let loan_value = mk_typed_avalue span loan_rty loan_value in (* Create the shared borrow *) let borrow_rty = loan_rty in - let borrow_value = ABorrow (ASharedBorrow lid) in + let borrow_value = ABorrow (ASharedBorrow (PNone, lid)) in let borrow_value = mk_typed_avalue span borrow_rty borrow_value in (* Create the abstraction *) @@ -344,11 +351,11 @@ let prepare_ashared_loans (span : Meta.span) (loop_id : LoopId.id option) : (* Continue the exploration *) super#visit_VSharedLoan env lids sv - method! visit_ASharedLoan env lids sv av = + method! visit_ASharedLoan env pm lids sv av = collect_shared_value lids sv; (* Continue the exploration *) - super#visit_ASharedLoan env lids sv av + super#visit_ASharedLoan env pm lids sv av (** Check that there are no symbolic values with *borrows* inside the abstraction - shouldn't happen if the symbolic values are greedily @@ -905,7 +912,9 @@ let compute_fixed_point_id_correspondance (span : Meta.span) let lookup_shared_loan lid ctx : typed_value = match snd (lookup_loan span ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v - | Abstract (ASharedLoan (_, v, _)) -> v + | Abstract (ASharedLoan (pm, _, v, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + v | _ -> craise __FILE__ __LINE__ span "Unreachable" in let lookup_in_tgt id = lookup_shared_loan id tgt_ctx in @@ -1044,7 +1053,7 @@ let compute_fp_ctx_symbolic_values (span : Meta.span) (ctx : eval_ctx) object (self) inherit [_] iter_env - method! visit_ASharedLoan inside_shared _ sv child_av = + method! visit_ASharedLoan inside_shared _ _ sv child_av = self#visit_typed_value true sv; self#visit_typed_avalue inside_shared child_av @@ -1094,7 +1103,9 @@ let compute_fp_ctx_symbolic_values (span : Meta.span) (ctx : eval_ctx) let v = match snd (lookup_loan span ek_all bid fp_ctx) with | Concrete (VSharedLoan (_, v)) -> v - | Abstract (ASharedLoan (_, v, _)) -> v + | Abstract (ASharedLoan (pm, _, v, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + v | _ -> craise __FILE__ __LINE__ span "Unreachable" in self#visit_typed_value env v diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index c67869ac..7ea442db 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -39,13 +39,13 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) *) let get_borrow_id (av : typed_avalue) : BorrowId.id = match av.value with - | ABorrow (AMutBorrow (bid, _) | ASharedBorrow bid) -> bid + | ABorrow (AMutBorrow (_, bid, _) | ASharedBorrow (_, bid)) -> bid | _ -> craise __FILE__ __LINE__ span "Unexpected" in 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 + | ALoan (AMutLoan (_, lid, _)) -> lid + | ALoan (ASharedLoan (_, lids, _, _)) -> BorrowId.Set.min_elt lids | _ -> craise __FILE__ __LINE__ span "Unexpected" in (* We use ordered maps to reorder the borrows and loans *) @@ -314,11 +314,14 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) Note that the join matcher doesn't implement match functions for avalues (see the comments in {!MakeJoinMatcher}. *) - let merge_amut_borrows id ty0 child0 _ty1 child1 = + let merge_amut_borrows id ty0 pm0 child0 _ty1 pm1 child1 = (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; + (* TODO: Handle markers *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; + (* 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 the one from the left), because we will merge those regions together @@ -326,11 +329,11 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) *) let ty = ty0 in let child = child0 in - let value = ABorrow (AMutBorrow (id, child)) in + let value = ABorrow (AMutBorrow (PNone, id, child)) in { value; ty } in - let merge_ashared_borrows id ty0 ty1 = + let merge_ashared_borrows id ty0 pm0 ty1 pm1 = (* Sanity checks *) let _ = let _, ty0, _ = ty_as_ref ty0 in @@ -343,23 +346,28 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) span in + (* TODO: Handle markers *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; + (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in - let value = ABorrow (ASharedBorrow id) in + let value = ABorrow (ASharedBorrow (PNone, id)) in { value; ty } in - let merge_amut_loans id ty0 child0 _ty1 child1 = + let merge_amut_loans id ty0 pm0 child0 _ty1 pm1 child1 = (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; + (* TODO: Handle markers *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in - let value = ALoan (AMutLoan (id, child)) in + let value = ALoan (AMutLoan (PNone, id, child)) in { value; ty } in - let merge_ashared_loans ids ty0 (sv0 : typed_value) child0 _ty1 + let merge_ashared_loans ids ty0 pm0 (sv0 : typed_value) child0 _ty1 pm1 (sv1 : typed_value) child1 = (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; @@ -375,10 +383,13 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv1.value)) span; + (* TODO: Handle markers *) + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; + let ty = ty0 in let child = child0 in let sv = M.match_typed_values ctx ctx sv0 sv1 in - let value = ALoan (ASharedLoan (ids, sv, child)) in + let value = ALoan (ASharedLoan (PNone, ids, sv, child)) in { value; ty } in { diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index e25adb2c..729b248f 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -353,10 +353,10 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct | ABorrow bc0, ABorrow bc1 -> ( log#ldebug (lazy "match_typed_avalues: borrows"); match (bc0, bc1) with - | ASharedBorrow bid0, ASharedBorrow bid1 -> + | ASharedBorrow (pm0, bid0), ASharedBorrow (pm1, bid1) -> log#ldebug (lazy "match_typed_avalues: shared borrows"); - M.match_ashared_borrows ctx0 ctx1 v0.ty bid0 v1.ty bid1 ty - | AMutBorrow (bid0, av0), AMutBorrow (bid1, av1) -> + M.match_ashared_borrows ctx0 ctx1 v0.ty pm0 bid0 v1.ty pm1 bid1 ty + | AMutBorrow (pm0, bid0, av0), AMutBorrow (pm1, bid1, av1) -> log#ldebug (lazy "match_typed_avalues: mut borrows"); log#ldebug (lazy @@ -364,7 +364,8 @@ 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 ctx0 ctx1 v0.ty bid0 av0 v1.ty bid1 av1 ty av + M.match_amut_borrows ctx0 ctx1 v0.ty pm0 bid0 av0 v1.ty pm1 bid1 av1 + ty av | AIgnoredMutBorrow _, AIgnoredMutBorrow _ -> (* The abstractions are destructured: we shouldn't get there *) craise __FILE__ __LINE__ M.span "Unexpected" @@ -393,23 +394,25 @@ module MakeMatcher (M : PrimMatcher) : Matcher = struct (* TODO: maybe we should enforce that the ids are always exactly the same - without matching *) match (lc0, lc1) with - | ASharedLoan (ids0, sv0, av0), ASharedLoan (ids1, sv1, av1) -> + | ASharedLoan (pm0, ids0, sv0, av0), ASharedLoan (pm1, ids1, sv1, av1) + -> log#ldebug (lazy "match_typed_avalues: shared loans"); let sv = match_rec sv0 sv1 in let av = match_arec av0 av1 in sanity_check __FILE__ __LINE__ (not (value_has_borrows sv.value)) M.span; - M.match_ashared_loans ctx0 ctx1 v0.ty ids0 sv0 av0 v1.ty ids1 sv1 - av1 ty sv av - | AMutLoan (id0, av0), AMutLoan (id1, av1) -> + M.match_ashared_loans ctx0 ctx1 v0.ty pm0 ids0 sv0 av0 v1.ty pm1 + ids1 sv1 av1 ty sv av + | AMutLoan (pm0, id0, av0), AMutLoan (pm1, id1, av1) -> log#ldebug (lazy "match_typed_avalues: mut loans"); log#ldebug (lazy "match_typed_avalues: mut loans: matching children values"); let av = match_arec av0 av1 in log#ldebug (lazy "match_typed_avalues: mut loans: matched children values"); - M.match_amut_loans ctx0 ctx1 v0.ty id0 av0 v1.ty id1 av1 ty av + M.match_amut_loans ctx0 ctx1 v0.ty pm0 id0 av0 v1.ty pm1 id1 av1 ty + av | AIgnoredMutLoan _, AIgnoredMutLoan _ | AIgnoredSharedLoan _, AIgnoredSharedLoan _ -> (* Those should have been filtered when destructuring the abstractions - @@ -504,13 +507,14 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* Generate the avalues for the abstraction *) let mk_aborrow (bid : borrow_id) : typed_avalue = - let value = ABorrow (ASharedBorrow bid) in + let value = ABorrow (ASharedBorrow (PNone, bid)) in { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in let loan = - ASharedLoan (BorrowId.Set.singleton bid2, sv, mk_aignored span bv_ty) + ASharedLoan + (PNone, BorrowId.Set.singleton bid2, sv, mk_aignored span bv_ty) in (* Note that an aloan has a borrow type *) let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in @@ -604,13 +608,15 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let borrow_av = let ty = borrow_ty in - let value = ABorrow (AMutBorrow (bid0, mk_aignored span bv_ty)) in + let value = + ABorrow (AMutBorrow (PNone, bid0, mk_aignored span bv_ty)) + in mk_typed_avalue span ty value in let loan_av = let ty = borrow_ty in - let value = ALoan (AMutLoan (nbid, mk_aignored span bv_ty)) in + let value = ALoan (AMutLoan (PNone, nbid, mk_aignored span bv_ty)) in mk_typed_avalue span ty value in @@ -654,12 +660,12 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let bv_ty = bv.ty in cassert __FILE__ __LINE__ (ty_no_regions bv_ty) span "Nested borrows are not supported yet"; - let value = ABorrow (AMutBorrow (bid, mk_aignored span bv_ty)) in + let value = ABorrow (AMutBorrow (PNone, bid, mk_aignored span bv_ty)) in { value; ty = borrow_ty } in let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in - let loan = AMutLoan (bid2, mk_aignored span bv_ty) in + let loan = AMutLoan (PNone, bid2, mk_aignored span bv_ty) in (* Note that an aloan has a borrow type *) let loan : typed_avalue = { value = ALoan loan; ty = borrow_ty } in @@ -1213,26 +1219,30 @@ struct let match_distinct_aadts _ _ _ _ _ _ _ = raise (Distinct "match_distinct_adts") - let match_ashared_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _ty1 bid1 ty - = + let match_ashared_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 pm0 bid0 _ty1 pm1 + bid1 ty = + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let bid = match_borrow_id bid0 bid1 in - let value = ABorrow (ASharedBorrow bid) in + let value = ABorrow (ASharedBorrow (PNone, bid)) in { value; ty } - let match_amut_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 bid0 _av0 _ty1 bid1 - _av1 ty av = + let match_amut_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 pm0 bid0 _av0 _ty1 + pm1 bid1 _av1 ty av = + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let bid = match_borrow_id bid0 bid1 in - let value = ABorrow (AMutBorrow (bid, av)) in + let value = ABorrow (AMutBorrow (PNone, bid, av)) in { value; ty } - let match_ashared_loans (_ : eval_ctx) (_ : eval_ctx) _ty0 ids0 _v0 _av0 _ty1 - ids1 _v1 _av1 ty v av = + let match_ashared_loans (_ : eval_ctx) (_ : eval_ctx) _ty0 pm0 ids0 _v0 _av0 + _ty1 pm1 ids1 _v1 _av1 ty v av = + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let bids = match_loan_ids ids0 ids1 in - let value = ALoan (ASharedLoan (bids, v, av)) in + let value = ALoan (ASharedLoan (PNone, bids, v, av)) in { value; ty } - let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 id0 _av0 _ty1 - id1 _av1 ty av = + let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 pm0 id0 _av0 + _ty1 pm1 id1 _av1 ty av = + sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; log#ldebug (lazy ("MakeCheckEquivMatcher:match_amut_loans:" ^ "\n- id0: " @@ -1241,7 +1251,7 @@ struct ^ typed_avalue_to_string ~span:(Some span) ctx1 av)); let id = match_loan_id id0 id1 in - let value = ALoan (AMutLoan (id, av)) in + let value = ALoan (AMutLoan (PNone, id, av)) in { value; ty } let match_avalues (ctx0 : eval_ctx) (ctx1 : eval_ctx) v0 v1 = @@ -1706,7 +1716,9 @@ let match_ctx_with_target (config : config) (span : Meta.span) let lookup_shared_loan lid ctx : typed_value = match snd (lookup_loan span ek_all lid ctx) with | Concrete (VSharedLoan (_, v)) -> v - | Abstract (ASharedLoan (_, v, _)) -> v + | Abstract (ASharedLoan (pm, _, v, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + v | _ -> craise __FILE__ __LINE__ span "Unreachable" in let lookup_in_src id = lookup_shared_loan id src_ctx in diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index bcf92b25..fc882423 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -150,8 +150,8 @@ let check_loans_borrows_relation_invariant (span : Meta.span) (ctx : eval_ctx) : method! visit_aloan_content inside_abs lc = let _ = match lc with - | AMutLoan (bid, _) -> register_mut_loan inside_abs bid - | ASharedLoan (bids, _, _) -> register_shared_loan inside_abs bids + | AMutLoan (_, bid, _) -> register_mut_loan inside_abs bid + | ASharedLoan (_, bids, _, _) -> register_shared_loan inside_abs bids | AIgnoredMutLoan (Some bid, _) -> register_ignored_loan RMut bid | AIgnoredMutLoan (None, _) | AIgnoredSharedLoan _ @@ -522,7 +522,8 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = match glc with | Concrete (VMutBorrow (_, bv)) -> sanity_check __FILE__ __LINE__ (bv.ty = ty) span - | Abstract (AMutBorrow (_, sv)) -> + | Abstract (AMutBorrow (pm, _, sv)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; sanity_check __FILE__ __LINE__ (Substitute.erase_regions sv.ty = ty) span @@ -612,15 +613,17 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = | ABottom, _ -> (* Nothing to check *) () | ABorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with - | AMutBorrow (_, av), RMut -> + | AMutBorrow (pm, _, av), RMut -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Check that the child value has the proper type *) sanity_check __FILE__ __LINE__ (av.ty = ref_ty) span - | ASharedBorrow bid, RShared -> ( + | ASharedBorrow (pm, bid), RShared -> ( + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Lookup the borrowed value to check it has the proper type *) let _, glc = lookup_loan span ek_all bid ctx in match glc with | Concrete (VSharedLoan (_, sv)) - | Abstract (ASharedLoan (_, sv, _)) -> + | Abstract (ASharedLoan (_, _, sv, _)) -> sanity_check __FILE__ __LINE__ (sv.ty = Substitute.erase_regions ref_ty) span @@ -635,8 +638,8 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = | _ -> craise __FILE__ __LINE__ span "Inconsistent context") | ALoan lc, aty -> ( match lc with - | AMutLoan (bid, child_av) | AIgnoredMutLoan (Some bid, child_av) - -> ( + | AMutLoan (PNone, bid, child_av) + | AIgnoredMutLoan (Some bid, child_av) -> ( let borrowed_aty = aloan_get_expected_child_type aty in sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) span; (* Lookup the borrowed value to check it has the proper type *) @@ -646,22 +649,25 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = sanity_check __FILE__ __LINE__ (bv.ty = Substitute.erase_regions borrowed_aty) span - | Abstract (AMutBorrow (_, sv)) -> + | Abstract (AMutBorrow (_, _, sv)) -> sanity_check __FILE__ __LINE__ (Substitute.erase_regions sv.ty = Substitute.erase_regions borrowed_aty) span | _ -> craise __FILE__ __LINE__ span "Inconsistent context") + | AMutLoan (_, _, _) -> internal_error __FILE__ __LINE__ span | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) span - | ASharedLoan (_, sv, child_av) | AEndedSharedLoan (sv, child_av) -> + | ASharedLoan (PNone, _, sv, child_av) + | AEndedSharedLoan (sv, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in sanity_check __FILE__ __LINE__ (sv.ty = Substitute.erase_regions borrowed_aty) span; (* TODO: the type of aloans doesn't make sense, see above *) sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) span + | ASharedLoan (_, _, _, _) -> internal_error __FILE__ __LINE__ span | AEndedMutLoan { given_back; child; given_back_span = _ } | AEndedIgnoredMutLoan { given_back; child; given_back_span = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in diff --git a/compiler/SymbolicToPure.ml b/compiler/SymbolicToPure.ml index 8dfe0abe..71f8e4fc 100644 --- a/compiler/SymbolicToPure.ml +++ b/compiler/SymbolicToPure.ml @@ -1666,7 +1666,7 @@ let rec typed_value_to_texpression (ctx : bs_ctx) (ectx : C.eval_ctx) value (** Explore an abstraction value and convert it to a consumed value - by collecting all the span-values from the ended *loans*. + by collecting all the meta-values from the ended *loans*. Consumed values are rvalues because when an abstraction ends we introduce a call to a backward function in the synthesized program, @@ -1720,10 +1720,10 @@ let rec typed_avalue_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) (lc : V.aloan_content) : texpression option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> + | AMutLoan (_, _, _) | ASharedLoan (_, _, _, _) -> craise __FILE__ __LINE__ ctx.span "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_span } -> - (* Return the span-value *) + (* Return the meta-value *) Some (typed_value_to_texpression ctx ectx given_back_span) | AEndedSharedLoan (_, _) -> (* We don't dive into shared loans: there is nothing to give back @@ -1744,7 +1744,7 @@ and aloan_content_to_consumed (ctx : bs_ctx) (ectx : C.eval_ctx) and aborrow_content_to_consumed (_ctx : bs_ctx) (bc : V.aborrow_content) : texpression option = match bc with - | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> + | V.AMutBorrow (_, _, _) | ASharedBorrow (_, _) | AIgnoredMutBorrow (_, _) -> craise __FILE__ __LINE__ _ctx.span "Unreachable" | AEndedMutBorrow (_, _) -> (* We collect consumed values: ignore *) @@ -1804,7 +1804,7 @@ let translate_opt_mplace (p : S.mplace option) : mplace option = match p with None -> None | Some p -> Some (translate_mplace p) (** Explore an abstraction value and convert it to a given back value - by collecting all the span-values from the ended *borrows*. + by collecting all the meta-values from the ended *borrows*. Given back values are patterns, because when an abstraction ends, we introduce a call to a backward function in the synthesized program, @@ -1867,7 +1867,7 @@ let rec typed_avalue_to_given_back (mp : mplace option) (av : V.typed_avalue) and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match lc with - | AMutLoan (_, _) | ASharedLoan (_, _, _) -> + | AMutLoan (_, _, _) | ASharedLoan (_, _, _, _) -> craise __FILE__ __LINE__ ctx.span "Unreachable" | AEndedMutLoan { child = _; given_back = _; given_back_span = _ } | AEndedSharedLoan (_, _) -> @@ -1886,7 +1886,7 @@ and aloan_content_to_given_back (_mp : mplace option) (lc : V.aloan_content) and aborrow_content_to_given_back (mp : mplace option) (bc : V.aborrow_content) (ctx : bs_ctx) : bs_ctx * typed_pattern option = match bc with - | V.AMutBorrow (_, _) | ASharedBorrow _ | AIgnoredMutBorrow (_, _) -> + | V.AMutBorrow (_, _, _) | ASharedBorrow (_, _) | AIgnoredMutBorrow (_, _) -> craise __FILE__ __LINE__ ctx.span "Unreachable" | AEndedMutBorrow (msv, _) -> (* Return the span-symbolic-value *) @@ -1912,7 +1912,7 @@ and aproj_to_given_back (mp : mplace option) (aproj : V.aproj) (ctx : bs_ctx) : ctx.span "Nested borrows are not supported yet"; (ctx, None) | AEndedProjBorrows mv -> - (* Return the span-value *) + (* Return the meta-value *) let ctx, var = fresh_var_for_symbolic_value mv ctx in (ctx, Some (mk_typed_pattern_from_var var mp)) | AIgnoredProjBorrows | AProjLoans (_, _) | AProjBorrows (_, _) -> diff --git a/compiler/Values.ml b/compiler/Values.ml index 96d61f88..ca33604d 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -153,7 +153,7 @@ and typed_value = { value : value; ty : ty } (** "Meta"-value: information we store for the synthesis. - Note that we never automatically visit the span-values with the + Note that we never automatically visit the meta-values with the visitors: they really are span information, and shouldn't be considered as part of the environment during a symbolic execution. @@ -166,7 +166,7 @@ type mvalue = typed_value [@@deriving show, ord] See the explanations for {!mvalue} - TODO: we may want to create wrappers, to prevent mixing span values + TODO: we may want to create wrappers, to prevent mixing meta values and regular values. *) type msymbolic_value = symbolic_value [@@deriving show, ord] @@ -278,7 +278,7 @@ and aproj = 'a and one for 'b. We accumulate those values in the list of projections (note that - the span value stores the value which was given back). + the meta value stores the value which was given back). We can later end the projector of loans if [s@0] is not referenced anywhere in the context below a projector of borrows which intersects @@ -290,14 +290,14 @@ and aproj = Also note that once given to a borrow projection, a symbolic value can't get updated/expanded: this means that we don't need to save - any span-value here. + any meta-value here. *) | AEndedProjLoans of msymbolic_value * (msymbolic_value * aproj) list (** An ended projector of loans over a symbolic value. See the explanations for {!AProjLoans} - Note that we keep the original symbolic value as a span-value. + Note that we keep the original symbolic value as a meta-value. *) | AEndedProjBorrows of msymbolic_value (** The only purpose of {!AEndedProjBorrows} is to store, for synthesis @@ -621,7 +621,7 @@ and aborrow_content = *) | AEndedMutBorrow of msymbolic_value * typed_avalue (** The sole purpose of {!AEndedMutBorrow} is to store the (symbolic) value - that we gave back as a span-value, to help with the synthesis. + that we gave back as a meta-value, to help with the synthesis. *) | AEndedSharedBorrow (** We don't really need {!AEndedSharedBorrow}: we simply want to be -- cgit v1.2.3 From c236ccfb22e64f56f4398d067582ebd570bf1a0b Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Mon, 27 May 2024 16:44:28 +0200 Subject: Add projection markers when joining environments --- compiler/InterpreterLoopsJoinCtxs.ml | 59 ++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 7ea442db..0f61f619 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -467,6 +467,65 @@ let join_ctxs (span : Meta.span) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* This should have been eliminated *) craise __FILE__ __LINE__ span "Unreachable" in + + (* Add a projection marker to a typed avalue *) + let add_marker_avalue (pm : proj_marker) (av : typed_avalue) : typed_avalue + = + let obj = + object + inherit [_] map_typed_avalue as super + + method! visit_borrow_content _ _ = + craise __FILE__ __LINE__ span "Unexpected borrow" + + method! visit_loan_content _ _ = + craise __FILE__ __LINE__ span "Unexpected loan" + + method! visit_symbolic_value _ sv = + (* While ctx0 and ctx1 are different, we assume that the type info context is + the same in both. Hence, we can use ctx0's types wlog *) + sanity_check __FILE__ __LINE__ + (not (symbolic_value_has_borrows ctx0 sv)) + span; + sv + + method! visit_aloan_content env lc = + match lc with + | AMutLoan (pm0, bid, av) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aloan_content env (AMutLoan (pm, bid, av)) + | ASharedLoan (pm0, bids, av, child) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aloan_content env + (ASharedLoan (pm, bids, av, child)) + | _ -> craise __FILE__ __LINE__ span "Unsupported yet" + + method! visit_aborrow_content env bc = + match bc with + | AMutBorrow (pm0, bid, av) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aborrow_content env (AMutBorrow (pm, bid, av)) + | ASharedBorrow (pm0, bid) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aborrow_content env (ASharedBorrow (pm, bid)) + | _ -> craise __FILE__ __LINE__ span "Unsupported yet" + end + in + obj#visit_typed_avalue () av + in + + (* Add projection marker to all abstractions in the left and right environments *) + let add_marker (pm : proj_marker) (ee : env_elem) : env_elem = + match ee with + | EAbs abs -> + EAbs + { abs with avalues = List.map (add_marker_avalue pm) abs.avalues } + | x -> x + in + + let env0 = List.map (add_marker PLeft) env0 in + let env1 = List.map (add_marker PRight) env1 in + List.iter check_valid env0; List.iter check_valid env1; (* Concatenate the suffixes and append the abstractions introduced while -- cgit v1.2.3 From 309435d24edb689736da83025eb08a6761b28b8b Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Mon, 27 May 2024 17:51:50 +0200 Subject: Split collapse into collapse and reduce, rename accordingly --- compiler/InterpreterBorrows.ml | 1 + compiler/InterpreterLoopsFixedPoint.ml | 2 +- compiler/InterpreterLoopsJoinCtxs.ml | 193 +++++++++++++++++++++++++++++++-- compiler/InterpreterLoopsMatchCtxs.mli | 2 +- 4 files changed, 185 insertions(+), 13 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 93238729..94f32b73 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2291,6 +2291,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then ( + (* TODO: In this case, there should be no proj markers *) sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint borrows0 borrows1) span; diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 599fabfd..26505902 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -131,7 +131,7 @@ let cleanup_fresh_values_and_abs (config : config) (span : Meta.span) We do this in order to enforce some structure in the environments: this allows us to find fixed-points. Note that this function needs to be called typically after we merge abstractions together (see {!collapse_ctx} - for instance). + and {!reduce_ctx} for instance). *) let reorder_loans_borrows_in_fresh_abs (span : Meta.span) (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 0f61f619..960edb99 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -17,7 +17,7 @@ let log = Logging.loops_join_ctxs_log We do this in order to enforce some structure in the environments: this allows us to find fixed-points. Note that this function needs to be called typically after we merge abstractions together (see {!collapse_ctx} - for instance). + and {!reduce_ctx} for instance). *) let reorder_loans_borrows_in_fresh_abs (span : Meta.span) (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = @@ -70,7 +70,7 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) { ctx with env } -(** Collapse an environment. +(** Reduce an environment. We do this to simplify an environment, for the purpose of finding a loop fixed point. @@ -129,6 +129,171 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) This can happen when merging environments (note that such environments are not well-formed - they become well formed again after collapsing). *) +let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) + (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) + (ctx0 : eval_ctx) : eval_ctx = + (* Debug *) + log#ldebug + (lazy + ("reduce_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- ctx0:\n" + ^ eval_ctx_to_string ~span:(Some span) ctx0 + ^ "\n\n")); + + 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 : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id old_ids.aids) + in + 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) *) + (* Note that we preserve the order of the dummy values: we replace them with + abstractions in place - this makes matching easier *) + let env = + List.concat + (List.map + (fun ee -> + match ee with + | EAbs _ | EFrame | EBinding (BVar _, _) -> [ ee ] + | EBinding (BDummy id, v) -> + if is_fresh_did id then + let absl = + convert_value_to_abstractions span abs_kind can_end + destructure_shared_values ctx0 v + in + List.map (fun abs -> EAbs abs) absl + else [ ee ]) + ctx0.env) + in + let ctx = { ctx0 with env } in + log#ldebug + (lazy + ("reduce_ctx: after converting values to abstractions:\n" + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" + ^ eval_ctx_to_string ~span:(Some span) ctx + ^ "\n\n")); + + log#ldebug + (lazy + ("reduce_ctx: after decomposing the shared values in the abstractions:\n" + ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" + ^ eval_ctx_to_string ~span:(Some span) ctx + ^ "\n\n")); + + (* Explore all the *new* abstractions, and compute various maps *) + let explore (abs : abs) = is_fresh_abs_id abs.abs_id in + let ids_maps = + compute_abs_borrows_loans_maps span (merge_funs = None) explore env + in + let { + abs_ids; + abs_to_borrows; + abs_to_loans = _; + abs_to_borrows_loans; + borrow_to_abs = _; + loan_to_abs; + borrow_loan_to_abs; + } = + ids_maps + in + + (* Change the merging behaviour depending on the input parameters *) + let abs_to_borrows, loan_to_abs = + if merge_funs <> None then (abs_to_borrows_loans, borrow_loan_to_abs) + else (abs_to_borrows, loan_to_abs) + in + + (* Merge the abstractions together *) + 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 + + (* Merge all the mergeable abs. + + We iterate over the abstractions, then over the borrows in the abstractions. + We do this because we want to control the order in which abstractions + are merged (the ids are iterated in increasing order). Otherwise, we + could simply iterate over all the borrows in [borrow_to_abs]... + *) + List.iter + (fun abs_id0 -> + let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in + let bids = BorrowId.Set.elements bids in + List.iter + (fun bid -> + match BorrowId.Map.find_opt bid loan_to_abs with + | None -> (* Nothing to do *) () + | Some abs_ids1 -> + 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 = + UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) + in + let abs_id0 = UnionFind.get abs_ref0 in + let abs_ref1 = + UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) + 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 ( + (* We actually need to merge the abstractions *) + + (* Debug *) + log#ldebug + (lazy + ("reduce_ctx: merging abstraction " + ^ AbstractionId.to_string abs_id1 + ^ " into " + ^ AbstractionId.to_string abs_id0 + ^ ":\n\n" + ^ eval_ctx_to_string ~span:(Some span) !ctx)); + + (* Update the environment - pay attention to the order: we + we merge [abs_id1] *into* [abs_id0] *) + let nctx, abs_id = + merge_into_abstraction span abs_kind can_end merge_funs + !ctx abs_id1 abs_id0 + in + ctx := nctx; + + (* Update the union find *) + let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in + UnionFind.set abs_ref_merged abs_id)) + abs_ids1) + bids) + abs_ids; + + log#ldebug + (lazy + ("reduce_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids + ^ "\n\n- after reduce:\n" + ^ eval_ctx_to_string ~span:(Some span) !ctx + ^ "\n\n")); + + (* Reorder the loans and borrows in the fresh abstractions *) + let ctx = reorder_loans_borrows_in_fresh_abs span old_ids.aids !ctx in + + log#ldebug + (lazy + ("reduce_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids + ^ "\n\n- after reduce and reorder borrows/loans:\n" + ^ eval_ctx_to_string ~span:(Some span) ctx + ^ "\n\n")); + + (* Return the new context *) + ctx + +(* TODO Adapt and comment *) let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = @@ -523,9 +688,10 @@ let join_ctxs (span : Meta.span) (loop_id : LoopId.id) (fixed_ids : ids_sets) | x -> x in - let env0 = List.map (add_marker PLeft) env0 in - let env1 = List.map (add_marker PRight) env1 in - + (* TODO: Readd this + let env0 = List.map (add_marker PLeft) env0 in + let env1 = List.map (add_marker PRight) env1 in + *) List.iter check_valid env0; List.iter check_valid env1; (* Concatenate the suffixes and append the abstractions introduced while @@ -776,11 +942,11 @@ let loop_join_origin_with_continue_ctxs (config : config) (span : Meta.span) ("loop_join_origin_with_continue_ctxs:join_one: after destructure:\n" ^ eval_ctx_to_string ~span:(Some span) ctx)); - (* Collapse the context we want to add to the join *) - let ctx = collapse_ctx span loop_id None fixed_ids ctx in + (* Reduce the context we want to add to the join *) + let ctx = reduce_ctx span loop_id None fixed_ids ctx in log#ldebug (lazy - ("loop_join_origin_with_continue_ctxs:join_one: after collapse:\n" + ("loop_join_origin_with_continue_ctxs:join_one: after reduce:\n" ^ eval_ctx_to_string ~span:(Some span) ctx)); (* Refresh the fresh abstractions *) @@ -793,15 +959,20 @@ let loop_join_origin_with_continue_ctxs (config : config) (span : Meta.span) ("loop_join_origin_with_continue_ctxs:join_one: after join:\n" ^ eval_ctx_to_string ~span:(Some span) ctx1)); - (* Collapse again - the join might have introduce abstractions we want - to merge with the others (note that those abstractions may actually - lead to borrows/loans duplications) *) + (* Collapse to eliminate the markers *) joined_ctx := collapse_ctx_with_merge span loop_id fixed_ids !joined_ctx; log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after join-collapse:\n" ^ eval_ctx_to_string ~span:(Some span) !joined_ctx)); + (* Reduce again to reach fixed point *) + joined_ctx := reduce_ctx span loop_id None fixed_ids !joined_ctx; + log#ldebug + (lazy + ("loop_join_origin_with_continue_ctxs:join_one: after last reduce:\n" + ^ eval_ctx_to_string ~span:(Some span) !joined_ctx)); + (* Sanity check *) if !Config.sanity_checks then Invariants.check_invariants span !joined_ctx; (* Return *) diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index ab585220..7d214cb6 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -188,7 +188,7 @@ val prepare_match_ctx_with_target : We want to introduce an abstraction [abs@2], which has the same shape as [abs@fp] above (the fixed-point abstraction), and which is actually the identity. If we do so, - we get an environment which is actually also a fixed point (we can collapse + we get an environment which is actually also a fixed point (we can reduce the dummy variables and [abs@1] to actually retrieve the fixed point we computed, and we use the fact that those values and abstractions can't be *directly* manipulated unless we end this newly introduced [abs@2], which we -- cgit v1.2.3 From 3c1e6d37a2b40b880b04b2d2aac95d6f06822327 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Mon, 27 May 2024 17:56:10 +0200 Subject: Simplify reduce_ctx --- compiler/InterpreterLoopsJoinCtxs.ml | 27 ++++++--------------------- 1 file changed, 6 insertions(+), 21 deletions(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 960edb99..5b9022b2 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -122,15 +122,8 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) i -> s@7 : u32 abs@4 { MB l0, ML l4 } ]} - - [merge_funs]: those are used to merge loans or borrows which appear in both - abstractions (rem.: here we mean that, for instance, both abstractions - contain a shared loan with id l0). - This can happen when merging environments (note that such environments are not well-formed - - they become well formed again after collapsing). *) -let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) - (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) +let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = (* Debug *) log#ldebug @@ -185,9 +178,7 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = - compute_abs_borrows_loans_maps span (merge_funs = None) explore env - in + let ids_maps = compute_abs_borrows_loans_maps span true explore env in let { abs_ids; abs_to_borrows; @@ -200,12 +191,6 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) ids_maps in - (* Change the merging behaviour depending on the input parameters *) - let abs_to_borrows, loan_to_abs = - if merge_funs <> None then (abs_to_borrows_loans, borrow_loan_to_abs) - else (abs_to_borrows, loan_to_abs) - in - (* Merge the abstractions together *) let merged_abs : AbstractionId.id UnionFind.elem AbstractionId.Map.t = AbstractionId.Map.of_list @@ -261,8 +246,8 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction span abs_kind can_end merge_funs - !ctx abs_id1 abs_id0 + merge_into_abstraction span abs_kind can_end None !ctx + abs_id1 abs_id0 in ctx := nctx; @@ -943,7 +928,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (span : Meta.span) ^ eval_ctx_to_string ~span:(Some span) ctx)); (* Reduce the context we want to add to the join *) - let ctx = reduce_ctx span loop_id None fixed_ids ctx in + let ctx = reduce_ctx span loop_id fixed_ids ctx in log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after reduce:\n" @@ -967,7 +952,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (span : Meta.span) ^ eval_ctx_to_string ~span:(Some span) !joined_ctx)); (* Reduce again to reach fixed point *) - joined_ctx := reduce_ctx span loop_id None fixed_ids !joined_ctx; + joined_ctx := reduce_ctx span loop_id fixed_ids !joined_ctx; log#ldebug (lazy ("loop_join_origin_with_continue_ctxs:join_one: after last reduce:\n" -- cgit v1.2.3 From 4b14d42b2c2eff3104f0bc342f0bc5ff7cecd5e9 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Mon, 27 May 2024 17:57:50 +0200 Subject: Simplify collapse_ctx --- compiler/InterpreterLoopsJoinCtxs.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 5b9022b2..81e5004f 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -280,7 +280,7 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) (* TODO Adapt and comment *) let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) - (merge_funs : merge_duplicates_funcs option) (old_ids : ids_sets) + (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = (* Debug *) log#ldebug @@ -337,7 +337,7 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in let ids_maps = - compute_abs_borrows_loans_maps span (merge_funs = None) explore env + compute_abs_borrows_loans_maps span false explore env in let { abs_ids; @@ -353,8 +353,7 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Change the merging behaviour depending on the input parameters *) let abs_to_borrows, loan_to_abs = - if merge_funs <> None then (abs_to_borrows_loans, borrow_loan_to_abs) - else (abs_to_borrows, loan_to_abs) + (abs_to_borrows_loans, borrow_loan_to_abs) in (* Merge the abstractions together *) @@ -412,7 +411,7 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction span abs_kind can_end merge_funs + merge_into_abstraction span abs_kind can_end (Some merge_funs) !ctx abs_id1 abs_id0 in ctx := nctx; @@ -566,7 +565,7 @@ let merge_into_abstraction (span : Meta.span) (loop_id : LoopId.id) let collapse_ctx_with_merge (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) (ctx : eval_ctx) : eval_ctx = let merge_funs = mk_collapse_ctx_merge_duplicate_funs span loop_id ctx in - try collapse_ctx span loop_id (Some merge_funs) old_ids ctx + try collapse_ctx span loop_id merge_funs old_ids ctx with ValueMatchFailure _ -> craise __FILE__ __LINE__ span "Unexpected" let join_ctxs (span : Meta.span) (loop_id : LoopId.id) (fixed_ids : ids_sets) -- cgit v1.2.3 From 445c566f11dcc9ba8c69a154902a12a18ba3a2aa Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Tue, 28 May 2024 14:28:40 +0200 Subject: Add type and set/map for marker and borrow id --- compiler/InterpreterLoopsCore.ml | 14 ++++++++++++++ compiler/InterpreterLoopsJoinCtxs.ml | 14 ++++++-------- compiler/InterpreterLoopsMatchCtxs.ml | 2 +- tests/test_runner/aeneas_test_runner.opam | 2 +- 4 files changed, 22 insertions(+), 10 deletions(-) diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 675dc544..9aee361d 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -26,6 +26,20 @@ type ctx_or_update = (eval_ctx, updt_env_kind) result (** Union Find *) module UF = UnionFind.Make (UnionFind.StoreMap) +type marker_borrow_id = proj_marker * BorrowId.id [@@deriving show, ord] + +module MarkerBorrowIdOrd = struct + type t = marker_borrow_id + + let compare = compare_marker_borrow_id + let to_string = show_marker_borrow_id + let pp_t = pp_marker_borrow_id + let show_t = show_marker_borrow_id +end + +module MarkerBorrowIdSet = Collections.MakeSet (MarkerBorrowIdOrd) +module MarkerBorrowIdMap = Collections.MakeMap (MarkerBorrowIdOrd) + (** A small utility - Rem.: some environments may be ill-formed (they may contain several times diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 81e5004f..5c3ce66d 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -280,8 +280,8 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) (* TODO Adapt and comment *) let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) - (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) - (ctx0 : eval_ctx) : eval_ctx = + (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) + : eval_ctx = (* Debug *) log#ldebug (lazy @@ -336,9 +336,7 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = - compute_abs_borrows_loans_maps span false explore env - in + let ids_maps = compute_abs_borrows_loans_maps span false explore env in let { abs_ids; abs_to_borrows; @@ -353,7 +351,7 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Change the merging behaviour depending on the input parameters *) let abs_to_borrows, loan_to_abs = - (abs_to_borrows_loans, borrow_loan_to_abs) + (abs_to_borrows_loans, borrow_loan_to_abs) in (* Merge the abstractions together *) @@ -411,8 +409,8 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction span abs_kind can_end (Some merge_funs) - !ctx abs_id1 abs_id0 + merge_into_abstraction span abs_kind can_end + (Some merge_funs) !ctx abs_id1 abs_id0 in ctx := nctx; diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 729b248f..9fe4638d 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -32,7 +32,7 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) let module R (Id0 : Identifiers.Id) (Id1 : Identifiers.Id) = struct (* - [check_singleton_sets]: check that the mapping maps to a singletong. + [check_singleton_sets]: check that the mapping maps to a singleton. [check_not_already_registered]: check if the mapping was not already registered. *) let register_mapping (check_singleton_sets : bool) diff --git a/tests/test_runner/aeneas_test_runner.opam b/tests/test_runner/aeneas_test_runner.opam index b57cc9f6..1539c521 100644 --- a/tests/test_runner/aeneas_test_runner.opam +++ b/tests/test_runner/aeneas_test_runner.opam @@ -7,7 +7,7 @@ homepage: "https://github.com/AeneasVerif/aeneas" bug-reports: "https://github.com/AeneasVerif/aeneas/issues" depends: [ "ocaml" - "dune" {>= "3.12"} + "dune" {>= "3.7"} "odoc" {with-doc} ] build: [ -- cgit v1.2.3 From 96d803a7aefe27d4401a336c426161d387987b63 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Tue, 28 May 2024 14:51:25 +0200 Subject: Compute marker information for borrow/loan maps --- compiler/InterpreterLoopsCore.ml | 25 +++++++--- compiler/InterpreterLoopsJoinCtxs.ml | 8 ++-- compiler/InterpreterLoopsMatchCtxs.ml | 90 +++++++++++++++++++---------------- 3 files changed, 73 insertions(+), 50 deletions(-) diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 9aee361d..23e05e06 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -40,6 +40,19 @@ end module MarkerBorrowIdSet = Collections.MakeSet (MarkerBorrowIdOrd) module MarkerBorrowIdMap = Collections.MakeMap (MarkerBorrowIdOrd) +module MarkerBorrowId : sig + type t + + module Set : Collections.Set with type elt = t + module Map : Collections.Map with type key = t +end +with type t = marker_borrow_id = struct + type t = marker_borrow_id + + module Set = MarkerBorrowIdSet + module Map = MarkerBorrowIdMap +end + (** A small utility - Rem.: some environments may be ill-formed (they may contain several times @@ -49,12 +62,12 @@ module MarkerBorrowIdMap = Collections.MakeMap (MarkerBorrowIdOrd) *) type abs_borrows_loans_maps = { 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; + abs_to_borrows : MarkerBorrowId.Set.t AbstractionId.Map.t; + abs_to_loans : MarkerBorrowId.Set.t AbstractionId.Map.t; + abs_to_borrows_loans : MarkerBorrowId.Set.t AbstractionId.Map.t; + borrow_to_abs : AbstractionId.Set.t MarkerBorrowId.Map.t; + loan_to_abs : AbstractionId.Set.t MarkerBorrowId.Map.t; + borrow_loan_to_abs : AbstractionId.Set.t MarkerBorrowId.Map.t; } (** See {!module:Aeneas.InterpreterLoopsMatchCtxs.MakeMatcher} and [Matcher]. diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 5c3ce66d..7f80e496 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -209,10 +209,10 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) List.iter (fun abs_id0 -> let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in - let bids = BorrowId.Set.elements bids in + let bids = MarkerBorrowId.Set.elements bids in List.iter (fun bid -> - match BorrowId.Map.find_opt bid loan_to_abs with + match MarkerBorrowId.Map.find_opt bid loan_to_abs with | None -> (* Nothing to do *) () | Some abs_ids1 -> AbstractionId.Set.iter @@ -372,10 +372,10 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) List.iter (fun abs_id0 -> let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in - let bids = BorrowId.Set.elements bids in + let bids = MarkerBorrowId.Set.elements bids in List.iter (fun bid -> - match BorrowId.Map.find_opt bid loan_to_abs with + match MarkerBorrowId.Map.find_opt bid loan_to_abs with | None -> (* Nothing to do *) () | Some abs_ids1 -> AbstractionId.Set.iter diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 9fe4638d..be6f3ade 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -26,59 +26,59 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) 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 borrow_to_abs = ref MarkerBorrowId.Map.empty in + let loan_to_abs = ref MarkerBorrowId.Map.empty in + let borrow_loan_to_abs = ref MarkerBorrowId.Map.empty in - let module R (Id0 : Identifiers.Id) (Id1 : Identifiers.Id) = struct + let module R (M : Collections.Map) (S : Collections.Set) = struct (* [check_singleton_sets]: check that the mapping maps to a singleton. [check_not_already_registered]: check if the mapping was not already registered. *) let register_mapping (check_singleton_sets : bool) - (check_not_already_registered : bool) (map : Id1.Set.t Id0.Map.t ref) - (id0 : Id0.id) (id1 : Id1.id) : unit = + (check_not_already_registered : bool) (map : S.t M.t ref) (id0 : M.key) + (id1 : S.elt) : unit = (* Sanity check *) (if check_singleton_sets || check_not_already_registered then - match Id0.Map.find_opt id0 !map with + match M.find_opt id0 !map with | None -> () | Some set -> sanity_check __FILE__ __LINE__ - ((not check_not_already_registered) || not (Id1.Set.mem id1 set)) + ((not check_not_already_registered) || not (S.mem id1 set)) span); (* Update the mapping *) map := - Id0.Map.update id0 + M.update id0 (fun ids -> match ids with - | None -> Some (Id1.Set.singleton id1) + | None -> Some (S.singleton id1) | Some ids -> (* Sanity check *) sanity_check __FILE__ __LINE__ (not check_singleton_sets) span; sanity_check __FILE__ __LINE__ - ((not check_not_already_registered) - || not (Id1.Set.mem id1 ids)) + ((not check_not_already_registered) || not (S.mem id1 ids)) span; (* Update *) - Some (Id1.Set.add id1 ids)) + Some (S.add id1 ids)) !map end 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; - RBorrowAbs.register_mapping no_duplicates no_duplicates borrow_to_abs bid - abs_id; - RBorrowAbs.register_mapping false false borrow_loan_to_abs bid abs_id + let module RAbsBorrow = R (AbstractionId.Map) (MarkerBorrowId.Set) in + let module RBorrowAbs = R (MarkerBorrowId.Map) (AbstractionId.Set) in + let register_borrow_id abs_id pm bid = + RAbsBorrow.register_mapping false no_duplicates abs_to_borrows abs_id + (pm, bid); + RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id (pm, bid); + RBorrowAbs.register_mapping no_duplicates no_duplicates borrow_to_abs + (pm, bid) abs_id; + RBorrowAbs.register_mapping false false borrow_loan_to_abs (pm, bid) abs_id in - let register_loan_id abs_id bid = - RAbsBorrow.register_mapping false no_duplicates abs_to_loans abs_id bid; - RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id bid; - RBorrowAbs.register_mapping no_duplicates no_duplicates loan_to_abs bid - abs_id; - RBorrowAbs.register_mapping false false borrow_loan_to_abs bid abs_id + let register_loan_id abs_id pm bid = + RAbsBorrow.register_mapping false no_duplicates abs_to_loans abs_id (pm, bid); + RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id (pm, bid); + RBorrowAbs.register_mapping no_duplicates no_duplicates loan_to_abs + (pm, bid) abs_id; + RBorrowAbs.register_mapping false false borrow_loan_to_abs (pm, bid) abs_id in let explore_abs = @@ -86,35 +86,43 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) inherit [_] iter_typed_avalue as super (** Make sure we don't register the ignored ids *) - method! visit_aloan_content abs_id lc = + method! visit_aloan_content (abs_id, pm) lc = match lc with - | AMutLoan _ | ASharedLoan _ -> + | AMutLoan (pm, _, _) | ASharedLoan (pm, _, _, _) -> (* Process those normally *) - super#visit_aloan_content abs_id lc + super#visit_aloan_content (abs_id, pm) lc | AIgnoredMutLoan (_, child) | AEndedIgnoredMutLoan { child; given_back = _; given_back_span = _ } | AIgnoredSharedLoan child -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Ignore the id of the loan, if there is *) - self#visit_typed_avalue abs_id child + self#visit_typed_avalue (abs_id, pm) child | AEndedMutLoan _ | AEndedSharedLoan _ -> craise __FILE__ __LINE__ span "Unreachable" (** Make sure we don't register the ignored ids *) - method! visit_aborrow_content abs_id bc = + method! visit_aborrow_content (abs_id, pm) bc = match bc with - | AMutBorrow _ | ASharedBorrow _ | AProjSharedBorrow _ -> + | AMutBorrow (pm, _, _) | ASharedBorrow (pm, _) -> + (* Add the current marker, and process them recursively *) + super#visit_aborrow_content (abs_id, pm) bc + | AProjSharedBorrow _ -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Process those normally *) - super#visit_aborrow_content abs_id bc + super#visit_aborrow_content (abs_id, pm) bc | AIgnoredMutBorrow (_, child) | AEndedIgnoredMutBorrow { child; given_back = _; given_back_span = _ } -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Ignore the id of the borrow, if there is *) - self#visit_typed_avalue abs_id child + self#visit_typed_avalue (abs_id, pm) child | AEndedMutBorrow _ | AEndedSharedBorrow -> craise __FILE__ __LINE__ span "Unreachable" - method! visit_borrow_id abs_id bid = register_borrow_id abs_id bid - method! visit_loan_id abs_id lid = register_loan_id abs_id lid + method! visit_borrow_id (abs_id, pm) bid = + register_borrow_id abs_id pm bid + + method! visit_loan_id (abs_id, pm) lid = register_loan_id abs_id pm lid end in @@ -123,11 +131,13 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) let abs_id = abs.abs_id in if explore abs then ( abs_to_borrows := - AbstractionId.Map.add abs_id BorrowId.Set.empty !abs_to_borrows; + AbstractionId.Map.add abs_id MarkerBorrowId.Set.empty !abs_to_borrows; abs_to_loans := - AbstractionId.Map.add abs_id BorrowId.Set.empty !abs_to_loans; + AbstractionId.Map.add abs_id MarkerBorrowId.Set.empty !abs_to_loans; abs_ids := abs.abs_id :: !abs_ids; - List.iter (explore_abs#visit_typed_avalue abs.abs_id) abs.avalues) + List.iter + (explore_abs#visit_typed_avalue (abs.abs_id, PNone)) + abs.avalues) else ()) env; -- cgit v1.2.3 From ce8614be6bd96c51756bf5922b5dfd4c59650dd4 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Thu, 30 May 2024 12:33:05 +0200 Subject: Implement two phases of loops join + collapse --- compiler/InterpreterBorrows.ml | 531 +++++++++++++-------- compiler/InterpreterLoopsCore.ml | 27 -- compiler/InterpreterLoopsJoinCtxs.ml | 346 ++++++++------ compiler/Values.ml | 31 ++ tests/coq/arrays/Arrays.v | 68 +-- tests/coq/demo/Demo.v | 27 +- tests/coq/hashmap/Hashmap_Funs.v | 198 +------- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 205 +------- tests/coq/misc/Loops.v | 446 +---------------- tests/fstar/arrays/Arrays.Clauses.Template.fst | 19 - tests/fstar/arrays/Arrays.Funs.fst | 54 +-- tests/fstar/demo/Demo.fst | 24 +- tests/fstar/hashmap/Hashmap.Clauses.Template.fst | 56 --- tests/fstar/hashmap/Hashmap.Funs.fst | 154 +----- .../HashmapMain.Clauses.Template.fst | 57 --- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 164 +------ tests/fstar/misc/Loops.Clauses.Template.fst | 105 ---- tests/fstar/misc/Loops.Funs.fst | 364 +------------- tests/lean/Arrays.lean | 53 +- tests/lean/Demo/Demo.lean | 25 +- tests/lean/Hashmap/Funs.lean | 148 +----- tests/lean/HashmapMain/Funs.lean | 154 +----- tests/lean/Loops.lean | 375 +-------------- 23 files changed, 660 insertions(+), 2971 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 94f32b73..e9be07aa 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1993,7 +1993,9 @@ let convert_value_to_abstractions (span : Meta.span) (abs_kind : abs_kind) (* Return *) List.rev !absl -type borrow_or_loan_id = BorrowId of borrow_id | LoanId of loan_id +type marker_borrow_or_loan_id = + | BorrowId of proj_marker * borrow_id + | LoanId of proj_marker * loan_id type g_loan_content_with_ty = (ety * loan_content, rty * aloan_content) concrete_or_abs @@ -2002,12 +2004,12 @@ type g_borrow_content_with_ty = (ety * borrow_content, rty * aborrow_content) concrete_or_abs type merge_abstraction_info = { - loans : loan_id_set; - borrows : borrow_id_set; - borrows_loans : borrow_or_loan_id list; + loans : MarkerBorrowId.Set.t; + borrows : MarkerBorrowId.Set.t; + borrows_loans : marker_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 BorrowId.Map.t; - borrow_to_content : g_borrow_content_with_ty BorrowId.Map.t; + loan_to_content : g_loan_content_with_ty MarkerBorrowId.Map.t; + borrow_to_content : g_borrow_content_with_ty MarkerBorrowId.Map.t; } (** Small utility to help merging abstractions. @@ -2023,46 +2025,57 @@ type merge_abstraction_info = { contain shared loans). *) let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) - (abs : abs) : merge_abstraction_info = - let loans : loan_id_set ref = ref BorrowId.Set.empty in - let borrows : borrow_id_set ref = ref BorrowId.Set.empty in - let borrows_loans : borrow_or_loan_id list ref = ref [] in - let loan_to_content : g_loan_content_with_ty BorrowId.Map.t ref = - ref BorrowId.Map.empty + (avalues : typed_avalue list) : merge_abstraction_info = + let loans : MarkerBorrowId.Set.t ref = ref MarkerBorrowId.Set.empty in + let borrows : MarkerBorrowId.Set.t ref = ref MarkerBorrowId.Set.empty in + let borrows_loans : marker_borrow_or_loan_id list ref = ref [] in + let loan_to_content : g_loan_content_with_ty MarkerBorrowId.Map.t ref = + ref MarkerBorrowId.Map.empty in - let borrow_to_content : g_borrow_content_with_ty BorrowId.Map.t ref = - ref BorrowId.Map.empty + let borrow_to_content : g_borrow_content_with_ty MarkerBorrowId.Map.t ref = + ref MarkerBorrowId.Map.empty in - let push_loans ids (lc : g_loan_content_with_ty) : unit = - sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint !loans ids) span; - loans := BorrowId.Set.union !loans ids; - BorrowId.Set.iter - (fun id -> + let push_loans pm ids (lc : g_loan_content_with_ty) : unit = + let pm_ids = + BorrowId.Set.to_seq ids + |> Seq.map (fun x -> (pm, x)) + |> MarkerBorrowId.Set.of_seq + in + sanity_check __FILE__ __LINE__ + (MarkerBorrowId.Set.disjoint !loans pm_ids) + span; + loans := MarkerBorrowId.Set.union !loans pm_ids; + MarkerBorrowId.Set.iter + (fun (pm, id) -> sanity_check __FILE__ __LINE__ - (not (BorrowId.Map.mem id !loan_to_content)) + (not (MarkerBorrowId.Map.mem (pm, id) !loan_to_content)) span; - loan_to_content := BorrowId.Map.add id lc !loan_to_content; - borrows_loans := LoanId id :: !borrows_loans) - ids + loan_to_content := MarkerBorrowId.Map.add (pm, id) lc !loan_to_content; + borrows_loans := LoanId (pm, id) :: !borrows_loans) + pm_ids in - let push_loan id (lc : g_loan_content_with_ty) : unit = - sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem id !loans)) span; - loans := BorrowId.Set.add id !loans; + let push_loan pm id (lc : g_loan_content_with_ty) : unit = + sanity_check __FILE__ __LINE__ + (not (MarkerBorrowId.Set.mem (pm, id) !loans)) + span; + loans := MarkerBorrowId.Set.add (pm, id) !loans; sanity_check __FILE__ __LINE__ - (not (BorrowId.Map.mem id !loan_to_content)) + (not (MarkerBorrowId.Map.mem (pm, id) !loan_to_content)) span; - loan_to_content := BorrowId.Map.add id lc !loan_to_content; - borrows_loans := LoanId id :: !borrows_loans + loan_to_content := MarkerBorrowId.Map.add (pm, id) lc !loan_to_content; + borrows_loans := LoanId (pm, id) :: !borrows_loans in - let push_borrow id (bc : g_borrow_content_with_ty) : unit = - sanity_check __FILE__ __LINE__ (not (BorrowId.Set.mem id !borrows)) span; - borrows := BorrowId.Set.add id !borrows; + let push_borrow pm id (bc : g_borrow_content_with_ty) : unit = + sanity_check __FILE__ __LINE__ + (not (MarkerBorrowId.Set.mem (pm, id) !borrows)) + span; + borrows := MarkerBorrowId.Set.add (pm, id) !borrows; sanity_check __FILE__ __LINE__ - (not (BorrowId.Map.mem id !borrow_to_content)) + (not (MarkerBorrowId.Map.mem (pm, id) !borrow_to_content)) span; - borrow_to_content := BorrowId.Map.add id bc !borrow_to_content; - borrows_loans := BorrowId id :: !borrows_loans + borrow_to_content := MarkerBorrowId.Map.add (pm, id) bc !borrow_to_content; + borrows_loans := BorrowId (pm, id) :: !borrows_loans in let iter_avalues = @@ -2086,7 +2099,7 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) | Abstract _ -> craise __FILE__ __LINE__ span "Unreachable" in (match lc with - | VSharedLoan (bids, _) -> push_loans bids (Concrete (ty, lc)) + | VSharedLoan (bids, _) -> push_loans PNone bids (Concrete (ty, lc)) | VMutLoan _ -> craise __FILE__ __LINE__ span "Unreachable"); (* Continue *) super#visit_loan_content env lc @@ -2104,14 +2117,8 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) in (* Register the loans *) (match lc with - | ASharedLoan (pm, bids, _, _) -> - (* TODO: We should keep track of the marker here *) - sanity_check __FILE__ __LINE__ (pm = PNone) span; - push_loans bids (Abstract (ty, lc)) - | AMutLoan (pm, bid, _) -> - (* TODO: We should keep track of the marker here *) - sanity_check __FILE__ __LINE__ (pm = PNone) span; - push_loan bid (Abstract (ty, lc)) + | ASharedLoan (pm, bids, _, _) -> push_loans pm bids (Abstract (ty, lc)) + | AMutLoan (pm, bid, _) -> push_loan pm bid (Abstract (ty, lc)) | AEndedMutLoan _ | AEndedSharedLoan _ | AIgnoredMutLoan _ | AEndedIgnoredMutLoan _ | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) @@ -2127,18 +2134,12 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) in (* Explore the borrow content *) (match bc with - | AMutBorrow (pm, bid, _) -> - (* TODO: We should keep track of the marker here *) - sanity_check __FILE__ __LINE__ (pm = PNone) span; - push_borrow bid (Abstract (ty, bc)) - | ASharedBorrow (pm, bid) -> - (* TODO: We should keep track of the marker here *) - sanity_check __FILE__ __LINE__ (pm = PNone) span; - push_borrow bid (Abstract (ty, bc)) + | AMutBorrow (pm, bid, _) | ASharedBorrow (pm, bid) -> + push_borrow pm bid (Abstract (ty, bc)) | AProjSharedBorrow asb -> let register asb = match asb with - | AsbBorrow bid -> push_borrow bid (Abstract (ty, bc)) + | AsbBorrow bid -> push_borrow PNone bid (Abstract (ty, bc)) | AsbProjReborrows _ -> (* Can only happen if the symbolic value (potentially) contains borrows - i.e., we have nested borrows *) @@ -2159,7 +2160,7 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) end in - List.iter (iter_avalues#visit_typed_avalue None) abs.avalues; + List.iter (iter_avalues#visit_typed_avalue None) avalues; { loans = !loans; @@ -2275,7 +2276,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) loan_to_content = loan_to_content0; borrow_to_content = borrow_to_content0; } = - compute_merge_abstraction_info span ctx abs0 + compute_merge_abstraction_info span ctx abs0.avalues in let { @@ -2285,17 +2286,28 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) loan_to_content = loan_to_content1; borrow_to_content = borrow_to_content1; } = - compute_merge_abstraction_info span ctx abs1 + compute_merge_abstraction_info span ctx abs1.avalues in (* Sanity check: there is no loan/borrows which appears in both abstractions, unless we allow to merge duplicates *) if merge_funs = None then ( - (* TODO: In this case, there should be no proj markers *) sanity_check __FILE__ __LINE__ - (BorrowId.Set.disjoint borrows0 borrows1) + (List.for_all + (function LoanId (pm, _) | BorrowId (pm, _) -> pm = PNone) + borrows_loans0) + span; + sanity_check __FILE__ __LINE__ + (List.for_all + (function LoanId (pm, _) | BorrowId (pm, _) -> pm = PNone) + borrows_loans1) span; - sanity_check __FILE__ __LINE__ (BorrowId.Set.disjoint loans0 loans1) span); + sanity_check __FILE__ __LINE__ + (MarkerBorrowId.Set.disjoint borrows0 borrows1) + span; + sanity_check __FILE__ __LINE__ + (MarkerBorrowId.Set.disjoint loans0 loans1) + span); (* Merge. There are several cases: @@ -2315,8 +2327,8 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) 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 BorrowId.Set.empty in - let merged_loans = ref BorrowId.Set.empty in + let merged_borrows = ref MarkerBorrowId.Set.empty in + let merged_loans = ref MarkerBorrowId.Set.empty in let avalues = ref [] in let push_avalue av = log#ldebug @@ -2329,142 +2341,43 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) match av with None -> () | Some av -> push_avalue av in - let intersect = - BorrowId.Set.union - (BorrowId.Set.inter loans0 borrows1) - (BorrowId.Set.inter loans1 borrows0) - in - let filter_bids (bids : BorrowId.Set.t) : BorrowId.Set.t = - let bids = BorrowId.Set.diff bids intersect in - sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) span; - bids + (* Phase 1 of the merge: We want to simplify all loan/borrow pairs. *) + + (* There is an asymetry in the merge: We only simplify a loan/borrow pair if the loan is in + the abstraction on the left *) + let intersect = MarkerBorrowId.Set.inter loans0 borrows1 in + + (* This function is called when handling shared loans, where the projection marker is global to a set of borrow ids. + Tracking this requires some set transformations *) + let filter_bids (pm : proj_marker) (bids : BorrowId.Set.t) : BorrowId.Set.t = + let bids = + BorrowId.Set.to_seq bids + |> Seq.map (fun x -> (pm, x)) + |> MarkerBorrowId.Set.of_seq + in + let bids = MarkerBorrowId.Set.diff bids intersect in + sanity_check __FILE__ __LINE__ (not (MarkerBorrowId.Set.is_empty bids)) span; + MarkerBorrowId.Set.to_seq bids |> Seq.map snd |> BorrowId.Set.of_seq in - let filter_bid (bid : BorrowId.id) : BorrowId.id option = - if BorrowId.Set.mem bid intersect then None else Some bid + let filter_bid (bid : marker_borrow_id) : marker_borrow_id option = + if MarkerBorrowId.Set.mem bid intersect then None else Some bid in - let borrow_is_merged id = BorrowId.Set.mem id !merged_borrows in + let borrow_is_merged id = MarkerBorrowId.Set.mem id !merged_borrows in let set_borrow_as_merged id = - merged_borrows := BorrowId.Set.add id !merged_borrows + merged_borrows := MarkerBorrowId.Set.add id !merged_borrows in - let loan_is_merged id = BorrowId.Set.mem id !merged_loans in + let loan_is_merged id = MarkerBorrowId.Set.mem id !merged_loans in let set_loan_as_merged id = - merged_loans := BorrowId.Set.add id !merged_loans + merged_loans := MarkerBorrowId.Set.add id !merged_loans 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 : rty) (bc0 : aborrow_content) (ty1 : rty) - (bc1 : aborrow_content) : typed_avalue = - match (bc0, bc1) with - | AMutBorrow (pm0, id0, child0), AMutBorrow (pm1, id1, child1) -> - (* Sanity-check of the precondition *) - sanity_check __FILE__ __LINE__ (id0 = id1) span; - (* TODO: We should handle the markers here *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; - (Option.get merge_funs).merge_amut_borrows id0 ty0 pm0 child0 ty1 pm1 - child1 - | ASharedBorrow (pm0, id0), ASharedBorrow (pm1, id1) -> - (* Sanity-check of the precondition *) - sanity_check __FILE__ __LINE__ (id0 = id1) span; - (* TODO: We should handle the markers here *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; - (Option.get merge_funs).merge_ashared_borrows id0 ty0 pm0 ty1 pm1 - | AProjSharedBorrow _, AProjSharedBorrow _ -> - (* Unreachable because requires nested borrows *) - craise __FILE__ __LINE__ span "Unreachable" - | _ -> - (* Unreachable because those cases are ignored (ended/ignored borrows) - or inconsistent *) - craise __FILE__ __LINE__ span "Unreachable" - in - - let merge_g_borrow_contents (bc0 : g_borrow_content_with_ty) - (bc1 : g_borrow_content_with_ty) : typed_avalue = - match (bc0, bc1) with - | Concrete _, Concrete _ -> - (* This can happen only in case of nested borrows *) - craise __FILE__ __LINE__ span "Unreachable" - | Abstract (ty0, bc0), Abstract (ty1, bc1) -> - merge_aborrow_contents ty0 bc0 ty1 bc1 - | Concrete _, Abstract _ | Abstract _, Concrete _ -> - (* TODO: is it really unreachable? *) - craise __FILE__ __LINE__ span "Unreachable" - in - - let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) - (lc1 : aloan_content) : typed_avalue option = - match (lc0, lc1) with - | AMutLoan (pm0, id0, child0), AMutLoan (pm1, id1, child1) -> - (* Sanity-check of the precondition *) - sanity_check __FILE__ __LINE__ (id0 = id1) span; - (* TODO: We should handle the markers here *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; - (* Register the loan id *) - set_loan_as_merged id0; - (* Merge *) - Some - ((Option.get merge_funs).merge_amut_loans id0 ty0 pm0 child0 ty1 pm1 - child1) - | ASharedLoan (pm0, ids0, sv0, child0), ASharedLoan (pm1, ids1, sv1, child1) - -> - (* TODO: We should handle the markers here *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; - (* Filter the ids *) - let ids0 = filter_bids ids0 in - let ids1 = filter_bids ids1 in - (* 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 *) - sanity_check __FILE__ __LINE__ (BorrowId.Set.equal ids0 ids1) span; - let ids = ids0 in - 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. - A more complete approach would be to explore the value and introduce - as many shared loans/borrows/etc. as necessary for the sub-values. - For now, we check that there are no such values that we would need - to preserve (in practice it works because we destructure the - shared values in the abstractions, and forbid nested borrows). - *) - sanity_check __FILE__ __LINE__ - (not (value_has_loans_or_borrows ctx sv0.value)) - span; - sanity_check __FILE__ __LINE__ - (not (value_has_loans_or_borrows ctx sv0.value)) - span; - sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; - sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; - None) - else ( - (* Register the loan ids *) - set_loans_as_merged ids; - (* Merge *) - Some - ((Option.get merge_funs).merge_ashared_loans ids ty0 pm0 sv0 child0 - ty1 pm1 sv1 child1)) - | _ -> - (* Unreachable because those cases are ignored (ended/ignored borrows) - or inconsistent *) - craise __FILE__ __LINE__ span "Unreachable" - in - - (* Note that because we may filter ids from a set of id, this function has - 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) : typed_avalue option = - match (lc0, lc1) with - | Concrete _, Concrete _ -> - (* This can not happen: the values should have been destructured *) - craise __FILE__ __LINE__ span "Unreachable" - | Abstract (ty0, lc0), Abstract (ty1, lc1) -> - merge_aloan_contents ty0 lc0 ty1 lc1 - | Concrete _, Abstract _ | Abstract _, Concrete _ -> - (* TODO: is it really unreachable? *) - craise __FILE__ __LINE__ span "Unreachable" + let set_loans_as_merged pm ids = + let ids = + BorrowId.Set.to_seq ids + |> Seq.map (fun x -> (pm, x)) + |> MarkerBorrowId.Set.of_seq + in + MarkerBorrowId.Set.iter set_loan_as_merged ids in (* Note that we first explore the borrows/loans of [abs1], because we @@ -2475,11 +2388,12 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) List.iter (fun bl -> match bl with - | BorrowId bid -> + | BorrowId (pm, bid) -> + let bid = (pm, bid) in log#ldebug (lazy ("merge_into_abstraction_aux: merging borrow " - ^ BorrowId.to_string bid)); + ^ MarkerBorrowId.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* @@ -2493,8 +2407,8 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | None -> () | Some bid -> (* Lookup the contents *) - let bc0 = BorrowId.Map.find_opt bid borrow_to_content0 in - let bc1 = BorrowId.Map.find_opt bid borrow_to_content1 in + let bc0 = MarkerBorrowId.Map.find_opt bid borrow_to_content0 in + let bc1 = MarkerBorrowId.Map.find_opt bid borrow_to_content1 in (* Merge *) let av : typed_avalue = match (bc0, bc1) with @@ -2508,12 +2422,15 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) craise __FILE__ __LINE__ span "Unreachable" | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some bc0, Some bc1 -> - sanity_check __FILE__ __LINE__ (merge_funs <> None) span; - merge_g_borrow_contents bc0 bc1 + (* With markers, the case where the same borrow is duplicated should now be unreachable. + Note, this is due to all shared borrows currently taking different ids, this will + not be the case anymore when shared loans will take a unique id instead of a set *) + craise __FILE__ __LINE__ span "Unreachable" | None, None -> craise __FILE__ __LINE__ span "Unreachable" in push_avalue av) - | LoanId bid -> + | LoanId (pm, bid) -> + let bid = (pm, bid) in if (* Check if the loan has already been treated - it can happen for the same reason as for borrows, and also because shared @@ -2526,15 +2443,15 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) log#ldebug (lazy ("merge_into_abstraction_aux: merging loan " - ^ BorrowId.to_string bid)); + ^ MarkerBorrowId.to_string bid)); (* Check if we need to filter it *) match filter_bid bid with | None -> () | Some bid -> (* Lookup the contents *) - let lc0 = BorrowId.Map.find_opt bid loan_to_content0 in - let lc1 = BorrowId.Map.find_opt bid loan_to_content1 in + let lc0 = MarkerBorrowId.Map.find_opt bid loan_to_content0 in + let lc1 = MarkerBorrowId.Map.find_opt bid loan_to_content1 in (* Merge *) let av : typed_avalue option = match (lc0, lc1) with @@ -2547,9 +2464,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | Abstract (ty, lc) -> ( match lc with | ASharedLoan (pm, bids, sv, child) -> - (* TODO: We should handle the markers here *) - sanity_check __FILE__ __LINE__ (pm = PNone) span; - let bids = filter_bids bids in + let bids = filter_bids pm bids in sanity_check __FILE__ __LINE__ (not (BorrowId.Set.is_empty bids)) span; @@ -2559,7 +2474,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (not (value_has_loans_or_borrows ctx sv.value)) span; let lc = ASharedLoan (pm, bids, sv, child) in - set_loans_as_merged bids; + set_loans_as_merged pm bids; Some { value = ALoan lc; ty } | AMutLoan _ -> set_loan_as_merged bid; @@ -2570,8 +2485,8 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (* The abstraction has been destructured, so those shouldn't appear *) craise __FILE__ __LINE__ span "Unreachable")) | Some lc0, Some lc1 -> - sanity_check __FILE__ __LINE__ (merge_funs <> None) span; - merge_g_loan_contents lc0 lc1 + (* With projection markers, shared loans should not be duplicated *) + craise __FILE__ __LINE__ span "Unreachable" | None, None -> craise __FILE__ __LINE__ span "Unreachable" in push_opt_avalue av)) @@ -2579,7 +2494,209 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (* Reverse the avalues (we visited the loans/borrows in order, but pushed new values at the beggining of the stack of avalues) *) - let avalues = List.rev !avalues in + let abs_values = List.rev !avalues in + + (* Phase 2: We now remove markers, by replacing pairs of the same element with left/right markers into one element + with only one marker. To do so, we linearly traverse the abstraction created through the first phase *) + + (* We first reset the list of avalues, and will construct avalues similarly to the previous phase *) + avalues := []; + + (* We recompute the relevant information on the abstraction after phase 1 *) + let { loans; borrows; borrows_loans; loan_to_content; borrow_to_content } = + compute_merge_abstraction_info span ctx abs_values + in + + (* We will merge elements with the same borrow/loan id, but with different markers. + Hence, we only keep track of the id here: if Borrow PLeft bid has been merged + and we see Borrow PRight bid, we should ignore Borrow PRight bid *) + let merged_borrows = ref BorrowId.Set.empty in + let merged_loans = ref BorrowId.Set.empty in + + let borrow_is_merged id = BorrowId.Set.mem id !merged_borrows in + let set_borrow_as_merged id = + merged_borrows := BorrowId.Set.add id !merged_borrows + in + + let loan_is_merged id = BorrowId.Set.mem id !merged_loans in + let set_loan_as_merged id = + merged_loans := BorrowId.Set.add id !merged_loans + in + let set_loans_as_merged ids = BorrowId.Set.iter set_loan_as_merged ids in + + (* Recreates an avalue from a borrow_content. *) + let avalue_from_bc = function + | Concrete (_, _) -> + (* This can happen only in case of nested borrows, and should have been filtered during phase 1 *) + craise __FILE__ __LINE__ span "Unreachable" + | Abstract (ty, bc) -> { value = ABorrow bc; ty } + in + + (* Recreates an avalue from a loan_content *) + let avalue_from_lc = function + | Concrete (_, _) -> + (* This can happen only in case of nested borrows, and should have been filtered during phase 1 *) + craise __FILE__ __LINE__ span "Unreachable" + | Abstract (ty, bc) -> { value = ALoan bc; ty } + in + + (* Some utility functions *) + (* Merge two aborrow contents - note that those contents must have the same id *) + let merge_aborrow_contents (ty0 : rty) (bc0 : aborrow_content) (ty1 : rty) + (bc1 : aborrow_content) : typed_avalue = + match (bc0, bc1) with + | AMutBorrow (pm0, id0, child0), AMutBorrow (pm1, id1, child1) -> + (* Sanity-check of the precondition *) + sanity_check __FILE__ __LINE__ (id0 = id1) span; + sanity_check __FILE__ __LINE__ + ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) + span; + (Option.get merge_funs).merge_amut_borrows id0 ty0 pm0 child0 ty1 pm1 + child1 + | ASharedBorrow (pm0, id0), ASharedBorrow (pm1, id1) -> + (* Sanity-check of the precondition *) + sanity_check __FILE__ __LINE__ (id0 = id1) span; + sanity_check __FILE__ __LINE__ + ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) + span; + (Option.get merge_funs).merge_ashared_borrows id0 ty0 pm0 ty1 pm1 + | AProjSharedBorrow _, AProjSharedBorrow _ -> + (* Unreachable because requires nested borrows *) + craise __FILE__ __LINE__ span "Unreachable" + | _ -> + (* Unreachable because those cases are ignored (ended/ignored borrows) + or inconsistent *) + craise __FILE__ __LINE__ span "Unreachable" + in + + let merge_g_borrow_contents (bc0 : g_borrow_content_with_ty) + (bc1 : g_borrow_content_with_ty) : typed_avalue = + match (bc0, bc1) with + | Concrete _, Concrete _ -> + (* This can happen only in case of nested borrows *) + craise __FILE__ __LINE__ span "Unreachable" + | Abstract (ty0, bc0), Abstract (ty1, bc1) -> + merge_aborrow_contents ty0 bc0 ty1 bc1 + | Concrete _, Abstract _ | Abstract _, Concrete _ -> + (* TODO: is it really unreachable? *) + craise __FILE__ __LINE__ span "Unreachable" + in + + let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) + (lc1 : aloan_content) : typed_avalue = + match (lc0, lc1) with + | AMutLoan (pm0, id0, child0), AMutLoan (pm1, id1, child1) -> + (* Sanity-check of the precondition *) + sanity_check __FILE__ __LINE__ (id0 = id1) span; + sanity_check __FILE__ __LINE__ + ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) + span; + (* Register the loan id *) + set_loan_as_merged id0; + (* Merge *) + (Option.get merge_funs).merge_amut_loans id0 ty0 pm0 child0 ty1 pm1 + child1 + | ASharedLoan (pm0, ids0, sv0, child0), ASharedLoan (pm1, ids1, sv1, child1) + -> + sanity_check __FILE__ __LINE__ + ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) + span; + (* 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 *) + sanity_check __FILE__ __LINE__ (BorrowId.Set.equal ids0 ids1) span; + let ids = ids0 in + (* Register the loan ids *) + set_loans_as_merged ids; + (* Merge *) + (Option.get merge_funs).merge_ashared_loans ids ty0 pm0 sv0 child0 ty1 + pm1 sv1 child1 + | _ -> + (* Unreachable because those cases are ignored (ended/ignored borrows) + or inconsistent *) + craise __FILE__ __LINE__ span "Unreachable" + in + + (* Note that because we may filter ids from a set of id, this function has + 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) : typed_avalue = + match (lc0, lc1) with + | Concrete _, Concrete _ -> + (* This can not happen: the values should have been destructured *) + craise __FILE__ __LINE__ span "Unreachable" + | Abstract (ty0, lc0), Abstract (ty1, lc1) -> + merge_aloan_contents ty0 lc0 ty1 lc1 + | Concrete _, Abstract _ | Abstract _, Concrete _ -> + (* TODO: is it really unreachable? *) + craise __FILE__ __LINE__ span "Unreachable" + in + + let invert_proj_marker = function + | PNone -> craise __FILE__ __LINE__ span "Unreachable" + | PLeft -> PRight + | PRight -> PLeft + in + + (* We now iter over all elements in the current abstraction. For each element with a marker + (i.e., not PNone), we attempt to find the dual element in the rest of the list. If so, + we remove both elements, and insert the same element but with no marker. + + Importantly, attempting the merge when first seeing a marked element allows us to preserve + the structure of the abstraction we are merging into (abs1). During phase1, we traversed + the borrow_loans of the abs1 first, and hence these elements are at the top of the list *) + List.iter + (function + | BorrowId (PNone, bid) -> + (* This element has no marker. We do not filter it, hence we retrieve the contents and inject it into + the avalues list *) + let bc = MarkerBorrowId.Map.find (PNone, bid) borrow_to_content in + push_avalue (avalue_from_bc bc) + | BorrowId (pm, bid) -> + (* Check if the borrow has already been merged. If so, it was already added to the avalues list, we skip it *) + if borrow_is_merged bid then () + else ( + set_borrow_as_merged bid; + let bc0 = MarkerBorrowId.Map.find (pm, bid) borrow_to_content in + let obc1 = + MarkerBorrowId.Map.find_opt + (invert_proj_marker pm, bid) + borrow_to_content + in + match obc1 with + | None -> + (* No dual element found, we keep the current one in the list of avalues, with the same marker *) + push_avalue (avalue_from_bc bc0) + | Some bc1 -> + (* We have borrows with left and right markers in the environment. + We merge their values, and push the result to the list of avalues. The merge will also remove the projection marker *) + push_avalue (merge_g_borrow_contents bc0 bc1)) + | LoanId (PNone, bid) -> + (* Same as BorrowId PNone above. We do not filter this element *) + let lc = MarkerBorrowId.Map.find (PNone, bid) loan_to_content in + push_avalue (avalue_from_lc lc) + | LoanId (pm, bid) -> ( + if + (* Check if the loan has already been merged. If so, we skip it *) + loan_is_merged bid + then () + else + let lc0 = MarkerBorrowId.Map.find (pm, bid) loan_to_content in + let olc1 = + MarkerBorrowId.Map.find_opt + (invert_proj_marker pm, bid) + loan_to_content + in + match olc1 with + | None -> + (* No dual element found, we keep the current one with the same marker *) + push_avalue (avalue_from_lc lc0) + | Some lc1 -> push_avalue (merge_g_loan_contents lc0 lc1))) + borrows_loans; + + (* We traversed and pushed elements in the same order as the traversal, so we do not need to reverse the list *) + let avalues = !avalues in (* Reorder the avalues. We want the avalues to have the borrows first, then the loans (this structure is more stable when we merge abstractions together, diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 23e05e06..cd609ab0 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -26,33 +26,6 @@ type ctx_or_update = (eval_ctx, updt_env_kind) result (** Union Find *) module UF = UnionFind.Make (UnionFind.StoreMap) -type marker_borrow_id = proj_marker * BorrowId.id [@@deriving show, ord] - -module MarkerBorrowIdOrd = struct - type t = marker_borrow_id - - let compare = compare_marker_borrow_id - let to_string = show_marker_borrow_id - let pp_t = pp_marker_borrow_id - let show_t = show_marker_borrow_id -end - -module MarkerBorrowIdSet = Collections.MakeSet (MarkerBorrowIdOrd) -module MarkerBorrowIdMap = Collections.MakeMap (MarkerBorrowIdOrd) - -module MarkerBorrowId : sig - type t - - module Set : Collections.Set with type elt = t - module Map : Collections.Map with type key = t -end -with type t = marker_borrow_id = struct - type t = marker_borrow_id - - module Set = MarkerBorrowIdSet - module Map = MarkerBorrowIdMap -end - (** A small utility - Rem.: some environments may be ill-formed (they may contain several times diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 7f80e496..1e099d96 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -122,8 +122,13 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) i -> s@7 : u32 abs@4 { MB l0, ML l4 } ]} + + If [merge_funs] is None, we ensure that there are no markers in the environments. + If [merge_funs] is Some _, we merge environments that contain borrow/loan pairs with the same markers, omitting + pairs with the PNone marker (i.e., no marker) *) -let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) +let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) + (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = (* Debug *) log#ldebug @@ -132,6 +137,8 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) ^ eval_ctx_to_string ~span:(Some span) ctx0 ^ "\n\n")); + let allow_markers = merge_funs <> None in + let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in let destructure_shared_values = true in @@ -212,49 +219,53 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) let bids = MarkerBorrowId.Set.elements bids in List.iter (fun bid -> + if not allow_markers then + sanity_check __FILE__ __LINE__ (fst bid = PNone) span; match MarkerBorrowId.Map.find_opt bid loan_to_abs with | None -> (* Nothing to do *) () | Some abs_ids1 -> - 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 = - UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) - in - let abs_id0 = UnionFind.get abs_ref0 in - let abs_ref1 = - UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) - 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 ( - (* We actually need to merge the abstractions *) - - (* Debug *) - log#ldebug - (lazy - ("reduce_ctx: merging abstraction " - ^ AbstractionId.to_string abs_id1 - ^ " into " - ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx)); - - (* Update the environment - pay attention to the order: we - we merge [abs_id1] *into* [abs_id0] *) - let nctx, abs_id = - merge_into_abstraction span abs_kind can_end None !ctx - abs_id1 abs_id0 + if allow_markers && fst bid = PNone then () + else + 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 = + UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) in - ctx := nctx; - - (* Update the union find *) - let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in - UnionFind.set abs_ref_merged abs_id)) - abs_ids1) + let abs_id0 = UnionFind.get abs_ref0 in + let abs_ref1 = + UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) + 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 ( + (* We actually need to merge the abstractions *) + + (* Debug *) + log#ldebug + (lazy + ("reduce_ctx: merging abstraction " + ^ AbstractionId.to_string abs_id1 + ^ " into " + ^ AbstractionId.to_string abs_id0 + ^ ":\n\n" + ^ eval_ctx_to_string ~span:(Some span) !ctx)); + + (* Update the environment - pay attention to the order: we + we merge [abs_id1] *into* [abs_id0] *) + let nctx, abs_id = + merge_into_abstraction span abs_kind can_end merge_funs + !ctx abs_id1 abs_id0 + in + ctx := nctx; + + (* Update the union find *) + let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in + UnionFind.set abs_ref_merged abs_id)) + abs_ids1) bids) abs_ids; @@ -278,8 +289,11 @@ let reduce_ctx (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) (* Return the new context *) ctx +(* Reduce_ctx can only be called in a context with no markers *) +let reduce_ctx = reduce_ctx_with_markers None + (* TODO Adapt and comment *) -let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) +let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = (* Debug *) @@ -296,128 +310,153 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) let is_fresh_abs_id (id : AbstractionId.id) : bool = not (AbstractionId.Set.mem id old_ids.aids) in - 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) *) - (* Note that we preserve the order of the dummy values: we replace them with - abstractions in place - this makes matching easier *) - let env = - List.concat - (List.map - (fun ee -> - match ee with - | EAbs _ | EFrame | EBinding (BVar _, _) -> [ ee ] - | EBinding (BDummy id, v) -> - if is_fresh_did id then - let absl = - convert_value_to_abstractions span abs_kind can_end - destructure_shared_values ctx0 v - in - List.map (fun abs -> EAbs abs) absl - else [ ee ]) - ctx0.env) - in - let ctx = { ctx0 with env } in - log#ldebug - (lazy - ("collapse_ctx: after converting values to abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" - ^ eval_ctx_to_string ~span:(Some span) ctx - ^ "\n\n")); - - log#ldebug - (lazy - ("collapse_ctx: after decomposing the shared values in the abstractions:\n" - ^ show_ids_sets old_ids ^ "\n\n- ctx:\n" - ^ eval_ctx_to_string ~span:(Some span) ctx - ^ "\n\n")); (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = compute_abs_borrows_loans_maps span false explore env in + let ids_maps = compute_abs_borrows_loans_maps span false explore ctx0.env in let { abs_ids; abs_to_borrows; - abs_to_loans = _; + abs_to_loans; abs_to_borrows_loans; - borrow_to_abs = _; + borrow_to_abs; loan_to_abs; borrow_loan_to_abs; } = ids_maps in - (* Change the merging behaviour depending on the input parameters *) - let abs_to_borrows, loan_to_abs = - (abs_to_borrows_loans, borrow_loan_to_abs) - in - (* Merge the abstractions together *) 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 + let ctx = ref ctx0 in - (* Merge all the mergeable abs. + let invert_proj_marker = function + | PNone -> craise __FILE__ __LINE__ span "Unreachable" + | PLeft -> PRight + | PRight -> PLeft + in - We iterate over the abstractions, then over the borrows in the abstractions. - We do this because we want to control the order in which abstractions - are merged (the ids are iterated in increasing order). Otherwise, we - could simply iterate over all the borrows in [borrow_to_abs]... + (* Merge all the mergeable abs where the same element in present in both abs, + but with left and right markers respectively. + + We first check all borrows, then all loans *) List.iter (fun abs_id0 -> let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in let bids = MarkerBorrowId.Set.elements bids in List.iter - (fun bid -> - match MarkerBorrowId.Map.find_opt bid loan_to_abs with - | None -> (* Nothing to do *) () - | Some abs_ids1 -> - 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 = - UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) - in - let abs_id0 = UnionFind.get abs_ref0 in - let abs_ref1 = - UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) - 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 ( - (* We actually need to merge the abstractions *) - - (* Debug *) - log#ldebug - (lazy - ("collapse_ctx: merging abstraction " - ^ AbstractionId.to_string abs_id1 - ^ " into " - ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx)); - - (* Update the environment - pay attention to the order: we - we merge [abs_id1] *into* [abs_id0] *) - let nctx, abs_id = - merge_into_abstraction span abs_kind can_end - (Some merge_funs) !ctx abs_id1 abs_id0 + (fun (pm, bid) -> + if pm = PNone then () + else + (* We are looking for an element with the same borrow_id, but with the dual marker *) + match + MarkerBorrowId.Map.find_opt + (invert_proj_marker pm, bid) + borrow_to_abs + with + | None -> (* Nothing to do *) () + | Some abs_ids1 -> + 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 = + UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) in - ctx := nctx; - - (* Update the union find *) - let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in - UnionFind.set abs_ref_merged abs_id)) - abs_ids1) + let abs_id0 = UnionFind.get abs_ref0 in + let abs_ref1 = + UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) + 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 ( + (* We actually need to merge the abstractions *) + + (* Debug *) + log#ldebug + (lazy + ("collapse_ctx: merging abstraction " + ^ AbstractionId.to_string abs_id1 + ^ " into " + ^ AbstractionId.to_string abs_id0 + ^ ":\n\n" + ^ eval_ctx_to_string ~span:(Some span) !ctx)); + + (* Update the environment - pay attention to the order: we + we merge [abs_id1] *into* [abs_id0] *) + let nctx, abs_id = + merge_into_abstraction span abs_kind can_end + (Some merge_funs) !ctx abs_id1 abs_id0 + in + ctx := nctx; + + (* Update the union find *) + let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in + UnionFind.set abs_ref_merged abs_id)) + abs_ids1) + bids; + (* We now traverse the loans *) + let bids = AbstractionId.Map.find abs_id0 abs_to_loans in + let bids = MarkerBorrowId.Set.elements bids in + List.iter + (fun (pm, bid) -> + if pm = PNone then () + else + (* We are looking for an element with the same borrow_id, but with the dual marker *) + match + MarkerBorrowId.Map.find_opt + (invert_proj_marker pm, bid) + loan_to_abs + with + | None -> (* Nothing to do *) () + | Some abs_ids1 -> + 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 = + UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) + in + let abs_id0 = UnionFind.get abs_ref0 in + let abs_ref1 = + UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) + 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 ( + (* We actually need to merge the abstractions *) + + (* Debug *) + log#ldebug + (lazy + ("collapse_ctx: merging abstraction " + ^ AbstractionId.to_string abs_id1 + ^ " into " + ^ AbstractionId.to_string abs_id0 + ^ ":\n\n" + ^ eval_ctx_to_string ~span:(Some span) !ctx)); + + (* Update the environment - pay attention to the order: we + we merge [abs_id1] *into* [abs_id0] *) + let nctx, abs_id = + merge_into_abstraction span abs_kind can_end + (Some merge_funs) !ctx abs_id1 abs_id0 + in + ctx := nctx; + + (* Update the union find *) + let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in + UnionFind.set abs_ref_merged abs_id)) + abs_ids1) bids) abs_ids; @@ -441,6 +480,25 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (* Return the new context *) ctx +(* Collapse two environments containing projection markers; this function is called after + joining environments. + + The collapse is done in two steps. + First, we reduce the environment, merging for instance abstractions containing MB l0 _ and ML l0, + when both elements have the same marker, e.g., PNone, PLeft, or PRight. + + Second, we merge abstractions containing the same element with left and right markers respectively. + + At the end of the second step, all markers should have been removed from the resulting environment. +*) +let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) + (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) + : eval_ctx = + let ctx = + reduce_ctx_with_markers (Some merge_funs) span loop_id old_ids ctx0 + in + collapse_ctx_markers span loop_id merge_funs old_ids ctx + let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) (loop_id : LoopId.id) (ctx : eval_ctx) : merge_duplicates_funcs = (* Rem.: the merge functions raise exceptions (that we catch). *) @@ -466,9 +524,6 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; - (* TODO: Handle markers *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; - (* 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 the one from the left), because we will merge those regions together @@ -493,9 +548,6 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) span in - (* TODO: Handle markers *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; - (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let value = ABorrow (ASharedBorrow (PNone, id)) in @@ -506,8 +558,7 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; - (* TODO: Handle markers *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; + (* Same remarks as for [merge_amut_borrows] *) let ty = ty0 in let child = child0 in @@ -530,8 +581,6 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) sanity_check __FILE__ __LINE__ (not (value_has_loans_or_borrows ctx sv1.value)) span; - (* TODO: Handle markers *) - sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let ty = ty0 in let child = child0 in @@ -670,10 +719,9 @@ let join_ctxs (span : Meta.span) (loop_id : LoopId.id) (fixed_ids : ids_sets) | x -> x in - (* TODO: Readd this - let env0 = List.map (add_marker PLeft) env0 in - let env1 = List.map (add_marker PRight) env1 in - *) + let env0 = List.map (add_marker PLeft) env0 in + let env1 = List.map (add_marker PRight) env1 in + List.iter check_valid env0; List.iter check_valid env1; (* Concatenate the suffixes and append the abstractions introduced while diff --git a/compiler/Values.ml b/compiler/Values.ml index ca33604d..c32cbc6e 100644 --- a/compiler/Values.ml +++ b/compiler/Values.ml @@ -180,6 +180,37 @@ type abstraction_id_set = AbstractionId.Set.t [@@deriving show, ord] For additional explanations see: https://arxiv.org/pdf/2404.02680#section.5 *) type proj_marker = PNone | PLeft | PRight [@@deriving show, ord] +type marker_borrow_id = proj_marker * BorrowId.id [@@deriving show, ord] + +module MarkerBorrowIdOrd = struct + type t = marker_borrow_id + + let compare = compare_marker_borrow_id + let to_string = show_marker_borrow_id + let pp_t = pp_marker_borrow_id + let show_t = show_marker_borrow_id +end + +module MarkerBorrowIdSet = Collections.MakeSet (MarkerBorrowIdOrd) +module MarkerBorrowIdMap = Collections.MakeMap (MarkerBorrowIdOrd) + +module MarkerBorrowId : sig + type t + + val to_string : t -> string + + module Set : Collections.Set with type elt = t + module Map : Collections.Map with type key = t +end +with type t = marker_borrow_id = struct + type t = marker_borrow_id + + let to_string = show_marker_borrow_id + + module Set = MarkerBorrowIdSet + module Map = MarkerBorrowIdMap +end + (** Ancestor for {!typed_avalue} iter visitor *) class ['self] iter_typed_avalue_base = object (self : 'self) diff --git a/tests/coq/arrays/Arrays.v b/tests/coq/arrays/Arrays.v index 35dea58c..b7bef7c7 100644 --- a/tests/coq/arrays/Arrays.v +++ b/tests/coq/arrays/Arrays.v @@ -375,58 +375,15 @@ Definition non_copyable_array : result unit := take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]) . -(** [arrays::sum]: loop 0: - Source: 'tests/src/arrays.rs', lines 242:0-250:1 *) -Fixpoint sum_loop - (n : nat) (s : slice u32) (sum1 : u32) (i : usize) : result u32 := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := slice_len u32 s in - if i s< i1 - then ( - i2 <- slice_index_usize u32 s i; - sum3 <- u32_add sum1 i2; - i3 <- usize_add i 1%usize; - sum_loop n1 s sum3 i3) - else Ok sum1 - end -. - (** [arrays::sum]: Source: 'tests/src/arrays.rs', lines 242:0-242:28 *) Definition sum (n : nat) (s : slice u32) : result u32 := - sum_loop n s 0%u32 0%usize -. - -(** [arrays::sum2]: loop 0: - Source: 'tests/src/arrays.rs', lines 252:0-261:1 *) -Fixpoint sum2_loop - (n : nat) (s : slice u32) (s2 : slice u32) (sum1 : u32) (i : usize) : - result u32 - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := slice_len u32 s in - if i s< i1 - then ( - i2 <- slice_index_usize u32 s i; - i3 <- slice_index_usize u32 s2 i; - i4 <- u32_add i2 i3; - sum3 <- u32_add sum1 i4; - i5 <- usize_add i 1%usize; - sum2_loop n1 s s2 sum3 i5) - else Ok sum1 - end -. + admit. (** [arrays::sum2]: Source: 'tests/src/arrays.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 i1 := slice_len u32 s2 in - if negb (i s= i1) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize + admit . (** [arrays::f0]: @@ -507,29 +464,10 @@ Definition ite : result unit := Ok tt . -(** [arrays::zero_slice]: loop 0: - Source: 'tests/src/arrays.rs', lines 303:0-310:1 *) -Fixpoint zero_slice_loop - (n : nat) (a : slice u8) (i : usize) (len : usize) : result (slice u8) := - match n with - | O => Fail_ OutOfFuel - | S n1 => - if i s< len - then ( - p <- slice_index_mut_usize u8 a i; - let (_, index_mut_back) := p in - i1 <- usize_add i 1%usize; - a1 <- index_mut_back 0%u8; - zero_slice_loop n1 a1 i1 len) - else Ok a - end -. - (** [arrays::zero_slice]: Source: 'tests/src/arrays.rs', lines 303:0-303:31 *) Definition zero_slice (n : nat) (a : slice u8) : result (slice u8) := - let len := slice_len u8 a in zero_slice_loop n a 0%usize len -. + admit. (** [arrays::iter_mut_slice]: loop 0: Source: 'tests/src/arrays.rs', lines 312:0-318:1 *) diff --git a/tests/coq/demo/Demo.v b/tests/coq/demo/Demo.v index 8d8f840d..14b1ca9d 100644 --- a/tests/coq/demo/Demo.v +++ b/tests/coq/demo/Demo.v @@ -90,38 +90,13 @@ Fixpoint list_nth_mut end . -(** [demo::list_nth_mut1]: loop 0: - Source: 'tests/src/demo.rs', lines 69:0-78:1 *) -Fixpoint list_nth_mut1_loop - (T : Type) (n : nat) (l : CList_t T) (i : u32) : - result (T * (T -> result (CList_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match l with - | CList_CCons x tl => - if i s= 0%u32 - then let back := fun (ret : T) => Ok (CList_CCons ret tl) in Ok (x, back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_mut1_loop T n1 tl i1; - let (t, back) := p in - let back1 := fun (ret : T) => tl1 <- back ret; Ok (CList_CCons x tl1) - in - Ok (t, back1)) - | CList_CNil => Fail_ Failure - end - end -. - (** [demo::list_nth_mut1]: Source: 'tests/src/demo.rs', lines 69:0-69:77 *) Definition list_nth_mut1 (T : Type) (n : nat) (l : CList_t T) (i : u32) : result (T * (T -> result (CList_t T))) := - list_nth_mut1_loop T n l i + admit . (** [demo::i32_id]: diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index 1f2b2b22..b5c2bff0 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -67,41 +67,11 @@ 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: - Source: 'tests/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)) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := alloc_vec_Vec_len (List_t T) slots in - if i s< i1 - then ( - p <- - alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i; - let (_, index_mut_back) := p in - i2 <- usize_add i 1%usize; - slots1 <- index_mut_back List_Nil; - hashMap_clear_loop T n1 slots1 i2) - else Ok slots - end -. - (** [hashmap::{hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 *) Definition hashMap_clear (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := - hm <- hashMap_clear_loop T n self.(hashMap_slots) 0%usize; - Ok - {| - hashMap_num_entries := 0%usize; - hashMap_max_load_factor := self.(hashMap_max_load_factor); - hashMap_max_load := self.(hashMap_max_load); - hashMap_slots := hm - |} + admit . (** [hashmap::{hashmap::HashMap}::len]: @@ -110,35 +80,13 @@ Definition hashMap_len (T : Type) (self : HashMap_t T) : result usize := Ok self.(hashMap_num_entries) . -(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: - Source: 'tests/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 * (List_t T)) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons ckey cvalue tl => - if ckey s= key - then Ok (false, List_Cons ckey value tl) - else ( - p <- hashMap_insert_in_list_loop T n1 key value tl; - let (b, tl1) := p in - Ok (b, List_Cons ckey cvalue tl1)) - | List_Nil => Ok (true, List_Cons key value List_Nil) - end - end -. - (** [hashmap::{hashmap::HashMap}::insert_in_list]: Source: 'tests/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 * (List_t T)) := - hashMap_insert_in_list_loop T n key value ls + admit . (** [hashmap::{hashmap::HashMap}::insert_no_resize]: @@ -179,57 +127,13 @@ Definition hashMap_insert_no_resize |}) . -(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: - Source: 'tests/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) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons k v tl => - ntable1 <- hashMap_insert_no_resize T n1 ntable k v; - hashMap_move_elements_from_list_loop T n1 ntable1 tl - | List_Nil => Ok ntable - end - end -. - (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - hashMap_move_elements_from_list_loop T n ntable ls -. - -(** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: - Source: 'tests/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) : - result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := alloc_vec_Vec_len (List_t T) slots in - if i s< i1 - then ( - p <- - alloc_vec_Vec_index_mut (List_t T) usize - (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i; - let (l, index_mut_back) := p in - let (ls, l1) := core_mem_replace (List_t T) l List_Nil in - ntable1 <- hashMap_move_elements_from_list T n1 ntable ls; - i2 <- usize_add i 1%usize; - slots1 <- index_mut_back l1; - hashMap_move_elements_loop T n1 ntable1 slots1 i2) - else Ok (ntable, slots) - end + admit . (** [hashmap::{hashmap::HashMap}::move_elements]: @@ -239,7 +143,7 @@ Definition hashMap_move_elements (slots : alloc_vec_Vec (List_t T)) (i : usize) : result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := - hashMap_move_elements_loop T n ntable slots i + admit . (** [hashmap::{hashmap::HashMap}::try_resize]: @@ -287,28 +191,11 @@ Definition hashMap_insert else Ok self1 . -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: - Source: 'tests/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 - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons ckey _ tl => - if ckey s= key - then Ok true - else hashMap_contains_key_in_list_loop T n1 key tl - | List_Nil => Ok false - end - end -. - (** [hashmap::{hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 + admit . (** [hashmap::{hashmap::HashMap}::contains_key]: @@ -325,26 +212,11 @@ Definition hashMap_contains_key hashMap_contains_key_in_list T n key l . -(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: - Source: 'tests/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 - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons ckey cvalue tl => - if ckey s= key then Ok cvalue else hashMap_get_in_list_loop T n1 key tl - | List_Nil => Fail_ Failure - end - end -. - (** [hashmap::{hashmap::HashMap}::get_in_list]: Source: 'tests/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 + admit . (** [hashmap::{hashmap::HashMap}::get]: @@ -361,39 +233,13 @@ Definition hashMap_get hashMap_get_in_list T n key l . -(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: - Source: 'tests/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 * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons ckey cvalue tl => - if ckey s= key - then - let back := fun (ret : T) => Ok (List_Cons ckey ret tl) in - Ok (cvalue, back) - else ( - p <- hashMap_get_mut_in_list_loop T n1 tl key; - let (t, back) := p in - let back1 := - fun (ret : T) => tl1 <- back ret; Ok (List_Cons ckey cvalue tl1) in - Ok (t, back1)) - | List_Nil => Fail_ Failure - end - end -. - (** [hashmap::{hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 * (T -> result (List_t T))) := - hashMap_get_mut_in_list_loop T n ls key + admit . (** [hashmap::{hashmap::HashMap}::get_mut]: @@ -426,41 +272,13 @@ Definition hashMap_get_mut Ok (t, back) . -(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: - Source: 'tests/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) * (List_t T)) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons ckey t tl => - if ckey s= key - then - let (mv_ls, _) := - core_mem_replace (List_t T) (List_Cons ckey t tl) List_Nil in - match mv_ls with - | List_Cons _ cvalue tl1 => Ok (Some cvalue, tl1) - | List_Nil => Fail_ Failure - end - else ( - p <- hashMap_remove_from_list_loop T n1 key tl; - let (o, tl1) := p in - Ok (o, List_Cons ckey t tl1)) - | List_Nil => Ok (None, List_Nil) - end - end -. - (** [hashmap::{hashmap::HashMap}::remove_from_list]: Source: 'tests/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) * (List_t T)) := - hashMap_remove_from_list_loop T n key ls + admit . (** [hashmap::{hashmap::HashMap}::remove]: diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index facd84ea..e37b111c 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -74,44 +74,13 @@ Definition hashmap_HashMap_new hashmap_HashMap_new_with_capacity T n 32%usize 4%usize 5%usize . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: - Source: 'tests/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)) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := alloc_vec_Vec_len (hashmap_List_t T) slots in - if i s< i1 - then ( - p <- - alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots - i; - let (_, index_mut_back) := p in - i2 <- usize_add i 1%usize; - slots1 <- index_mut_back Hashmap_List_Nil; - hashmap_HashMap_clear_loop T n1 slots1 i2) - else Ok slots - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: Source: 'tests/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) := - hm <- hashmap_HashMap_clear_loop T n self.(hashmap_HashMap_slots) 0%usize; - Ok - {| - 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 := hm - |} + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: @@ -121,36 +90,13 @@ Definition hashmap_HashMap_len Ok self.(hashmap_HashMap_num_entries) . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: - Source: 'tests/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 * (hashmap_List_t T)) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | Hashmap_List_Cons ckey cvalue tl => - if ckey s= key - then Ok (false, Hashmap_List_Cons ckey value tl) - else ( - p <- hashmap_HashMap_insert_in_list_loop T n1 key value tl; - let (b, tl1) := p in - Ok (b, Hashmap_List_Cons ckey cvalue tl1)) - | Hashmap_List_Nil => - Ok (true, Hashmap_List_Cons key value Hashmap_List_Nil) - end - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: Source: 'tests/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 * (hashmap_List_t T)) := - hashmap_HashMap_insert_in_list_loop T n key value ls + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: @@ -193,58 +139,13 @@ Definition hashmap_HashMap_insert_no_resize |}) . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: - Source: 'tests/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) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | Hashmap_List_Cons k v tl => - ntable1 <- hashmap_HashMap_insert_no_resize T n1 ntable k v; - hashmap_HashMap_move_elements_from_list_loop T n1 ntable1 tl - | Hashmap_List_Nil => Ok ntable - end - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - hashmap_HashMap_move_elements_from_list_loop T n ntable ls -. - -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: - Source: 'tests/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) : - result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := alloc_vec_Vec_len (hashmap_List_t T) slots in - if i s< i1 - then ( - p <- - alloc_vec_Vec_index_mut (hashmap_List_t T) usize - (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots - i; - let (l, index_mut_back) := p in - let (ls, l1) := core_mem_replace (hashmap_List_t T) l Hashmap_List_Nil in - ntable1 <- hashmap_HashMap_move_elements_from_list T n1 ntable ls; - i2 <- usize_add i 1%usize; - slots1 <- index_mut_back l1; - hashmap_HashMap_move_elements_loop T n1 ntable1 slots1 i2) - else Ok (ntable, slots) - end + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: @@ -254,7 +155,7 @@ Definition hashmap_HashMap_move_elements (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := - hashmap_HashMap_move_elements_loop T n ntable slots i + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: @@ -307,28 +208,11 @@ Definition hashmap_HashMap_insert else Ok self1 . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: - Source: 'tests/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 - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | Hashmap_List_Cons ckey _ tl => - if ckey s= key - then Ok true - else hashmap_HashMap_contains_key_in_list_loop T n1 key tl - | Hashmap_List_Nil => Ok false - end - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: @@ -347,28 +231,11 @@ 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: - Source: 'tests/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 - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | Hashmap_List_Cons ckey cvalue tl => - if ckey s= key - then Ok cvalue - else hashmap_HashMap_get_in_list_loop T n1 key tl - | Hashmap_List_Nil => Fail_ Failure - end - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: Source: 'tests/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 + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: @@ -385,40 +252,13 @@ 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: - Source: 'tests/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 * (T -> result (hashmap_List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | Hashmap_List_Cons ckey cvalue tl => - if ckey s= key - then - let back := fun (ret : T) => Ok (Hashmap_List_Cons ckey ret tl) in - Ok (cvalue, back) - else ( - p <- hashmap_HashMap_get_mut_in_list_loop T n1 tl key; - let (t, back) := p in - let back1 := - fun (ret : T) => - tl1 <- back ret; Ok (Hashmap_List_Cons ckey cvalue tl1) in - Ok (t, back1)) - | Hashmap_List_Nil => Fail_ Failure - end - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 * (T -> result (hashmap_List_t T))) := - hashmap_HashMap_get_mut_in_list_loop T n ls key + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: @@ -452,42 +292,13 @@ Definition hashmap_HashMap_get_mut Ok (t, back) . -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: - Source: 'tests/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) * (hashmap_List_t T)) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | Hashmap_List_Cons ckey t tl => - if ckey s= key - then - let (mv_ls, _) := - core_mem_replace (hashmap_List_t T) (Hashmap_List_Cons ckey t tl) - Hashmap_List_Nil in - match mv_ls with - | Hashmap_List_Cons _ cvalue tl1 => Ok (Some cvalue, tl1) - | Hashmap_List_Nil => Fail_ Failure - end - else ( - p <- hashmap_HashMap_remove_from_list_loop T n1 key tl; - let (o, tl1) := p in - Ok (o, Hashmap_List_Cons ckey t tl1)) - | Hashmap_List_Nil => Ok (None, Hashmap_List_Nil) - end - end -. - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: Source: 'tests/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) * (hashmap_List_t T)) := - hashmap_HashMap_remove_from_list_loop T n key ls + admit . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index bf0a8bc1..bd2b287b 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -93,32 +93,11 @@ Definition sum_array (N : usize) (n : nat) (a : array u32 N) : result u32 := sum_array_loop N n a 0%usize 0%u32 . -(** [loops::clear]: loop 0: - Source: 'tests/src/loops.rs', lines 62:0-68:1 *) -Fixpoint clear_loop - (n : nat) (v : alloc_vec_Vec u32) (i : usize) : result (alloc_vec_Vec u32) := - match n with - | O => Fail_ OutOfFuel - | S n1 => - let i1 := alloc_vec_Vec_len u32 v in - if i s< i1 - then ( - p <- - alloc_vec_Vec_index_mut u32 usize - (core_slice_index_SliceIndexUsizeSliceTInst u32) v i; - let (_, index_mut_back) := p in - i2 <- usize_add i 1%usize; - v1 <- index_mut_back 0%u32; - clear_loop n1 v1 i2) - else Ok v - end -. - (** [loops::clear]: Source: 'tests/src/loops.rs', lines 62:0-62:30 *) Definition clear (n : nat) (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) := - clear_loop n v 0%usize + admit . (** [loops::List] @@ -131,47 +110,10 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. -(** [loops::list_mem]: loop 0: - Source: 'tests/src/loops.rs', lines 76:0-85:1 *) -Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons y tl => if y s= x then Ok true else list_mem_loop n1 x tl - | List_Nil => Ok false - end - end -. - (** [loops::list_mem]: Source: 'tests/src/loops.rs', lines 76:0-76: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: - Source: 'tests/src/loops.rs', lines 88:0-98:1 *) -Fixpoint list_nth_mut_loop_loop - (T : Type) (n : nat) (ls : List_t T) (i : u32) : - result (T * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons x tl => - if i s= 0%u32 - then let back := fun (ret : T) => Ok (List_Cons ret tl) in Ok (x, back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_mut_loop_loop T n1 tl i1; - let (t, back) := p in - let back1 := fun (ret : T) => tl1 <- back ret; Ok (List_Cons x tl1) in - Ok (t, back1)) - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_mut_loop]: @@ -180,56 +122,14 @@ Definition list_nth_mut_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result (T * (T -> result (List_t T))) := - list_nth_mut_loop_loop T n ls i -. - -(** [loops::list_nth_shared_loop]: loop 0: - Source: 'tests/src/loops.rs', lines 101:0-111:1 *) -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 n1 => - match ls with - | List_Cons x tl => - if i s= 0%u32 - then Ok x - else (i1 <- u32_sub i 1%u32; list_nth_shared_loop_loop T n1 tl i1) - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_shared_loop]: Source: 'tests/src/loops.rs', lines 101:0-101: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: - Source: 'tests/src/loops.rs', lines 113:0-127:1 *) -Fixpoint get_elem_mut_loop - (n : nat) (x : usize) (ls : List_t usize) : - result (usize * (usize -> result (List_t usize))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons y tl => - if y s= x - then - let back := fun (ret : usize) => Ok (List_Cons ret tl) in Ok (y, back) - else ( - p <- get_elem_mut_loop n1 x tl; - let (i, back) := p in - let back1 := fun (ret : usize) => tl1 <- back ret; Ok (List_Cons y tl1) - in - Ok (i, back1)) - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::get_elem_mut]: @@ -238,28 +138,7 @@ Definition get_elem_mut (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : result (usize * (usize -> result (alloc_vec_Vec (List_t usize)))) := - p <- - alloc_vec_Vec_index_mut (List_t usize) usize - (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; - let (ls, index_mut_back) := p in - p1 <- get_elem_mut_loop n x ls; - let (i, back) := p1 in - let back1 := fun (ret : usize) => l <- back ret; index_mut_back l in - Ok (i, back1) -. - -(** [loops::get_elem_shared]: loop 0: - Source: 'tests/src/loops.rs', lines 129:0-143:1 *) -Fixpoint get_elem_shared_loop - (n : nat) (x : usize) (ls : List_t usize) : result usize := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons y tl => if y s= x then Ok y else get_elem_shared_loop n1 x tl - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::get_elem_shared]: @@ -268,10 +147,7 @@ Definition get_elem_shared (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : result usize := - ls <- - alloc_vec_Vec_index (List_t usize) usize - (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; - get_elem_shared_loop n x ls + admit . (** [loops::id_mut]: @@ -288,101 +164,20 @@ Definition id_mut Definition id_shared (T : Type) (ls : List_t T) : result (List_t T) := Ok ls. -(** [loops::list_nth_mut_loop_with_id]: loop 0: - Source: 'tests/src/loops.rs', lines 154:0-165:1 *) -Fixpoint list_nth_mut_loop_with_id_loop - (T : Type) (n : nat) (i : u32) (ls : List_t T) : - result (T * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls with - | List_Cons x tl => - if i s= 0%u32 - then let back := fun (ret : T) => Ok (List_Cons ret tl) in Ok (x, back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_mut_loop_with_id_loop T n1 i1 tl; - let (t, back) := p in - let back1 := fun (ret : T) => tl1 <- back ret; Ok (List_Cons x tl1) in - Ok (t, back1)) - | List_Nil => Fail_ Failure - end - end -. - (** [loops::list_nth_mut_loop_with_id]: Source: 'tests/src/loops.rs', lines 154:0-154:75 *) Definition list_nth_mut_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result (T * (T -> result (List_t T))) := - p <- id_mut T ls; - let (ls1, id_mut_back) := p in - p1 <- list_nth_mut_loop_with_id_loop T n i ls1; - let (t, back) := p1 in - let back1 := fun (ret : T) => l <- back ret; id_mut_back l in - Ok (t, back1) -. - -(** [loops::list_nth_shared_loop_with_id]: loop 0: - Source: 'tests/src/loops.rs', lines 168:0-179:1 *) -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 n1 => - match ls with - | List_Cons x tl => - if i s= 0%u32 - then Ok x - else ( - i1 <- u32_sub i 1%u32; list_nth_shared_loop_with_id_loop T n1 i1 tl) - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_shared_loop_with_id]: Source: 'tests/src/loops.rs', lines 168:0-168:70 *) Definition list_nth_shared_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - ls1 <- id_shared T ls; list_nth_shared_loop_with_id_loop T n i ls1 -. - -(** [loops::list_nth_mut_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 184:0-205: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) * (T -> result (List_t T)) * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then - let back'a := fun (ret : T) => Ok (List_Cons ret tl0) in - let back'b := fun (ret : T) => Ok (List_Cons ret tl1) in - Ok ((x0, x1), back'a, back'b) - else ( - i1 <- u32_sub i 1%u32; - t <- list_nth_mut_loop_pair_loop T n1 tl0 tl1 i1; - let '(p, back'a, back'b) := t in - let back'a1 := - fun (ret : T) => tl01 <- back'a ret; Ok (List_Cons x0 tl01) in - let back'b1 := - fun (ret : T) => tl11 <- back'b ret; Ok (List_Cons x1 tl11) in - Ok (p, back'a1, back'b1)) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_mut_loop_pair]: @@ -391,31 +186,7 @@ Definition list_nth_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * (T -> result (List_t T)) * (T -> result (List_t T))) := - list_nth_mut_loop_pair_loop T n ls0 ls1 i -. - -(** [loops::list_nth_shared_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 208:0-229: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) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then Ok (x0, x1) - else ( - i1 <- u32_sub i 1%u32; list_nth_shared_loop_pair_loop T n1 tl0 tl1 i1) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_shared_loop_pair]: @@ -424,43 +195,7 @@ 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 T n ls0 ls1 i -. - -(** [loops::list_nth_mut_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 233:0-248: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) * ((T * T) -> result ((List_t T) * (List_t T)))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then - let back := - fun (ret : (T * T)) => - let (t, t1) := ret in Ok (List_Cons t tl0, List_Cons t1 tl1) in - Ok ((x0, x1), back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_mut_loop_pair_merge_loop T n1 tl0 tl1 i1; - let (p1, back) := p in - let back1 := - fun (ret : (T * T)) => - p2 <- back ret; - let (tl01, tl11) := p2 in - Ok (List_Cons x0 tl01, List_Cons x1 tl11) in - Ok (p1, back1)) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_mut_loop_pair_merge]: @@ -469,32 +204,7 @@ Definition list_nth_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * ((T * T) -> result ((List_t T) * (List_t T)))) := - list_nth_mut_loop_pair_merge_loop T n ls0 ls1 i -. - -(** [loops::list_nth_shared_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 251:0-266: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) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then Ok (x0, x1) - else ( - i1 <- u32_sub i 1%u32; - list_nth_shared_loop_pair_merge_loop T n1 tl0 tl1 i1) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_shared_loop_pair_merge]: @@ -503,38 +213,7 @@ 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 T n ls0 ls1 i -. - -(** [loops::list_nth_mut_shared_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 269:0-284: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) * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then - let back := fun (ret : T) => Ok (List_Cons ret tl0) in - Ok ((x0, x1), back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_mut_shared_loop_pair_loop T n1 tl0 tl1 i1; - let (p1, back) := p in - let back1 := - fun (ret : T) => tl01 <- back ret; Ok (List_Cons x0 tl01) in - Ok (p1, back1)) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_mut_shared_loop_pair]: @@ -543,38 +222,7 @@ Definition list_nth_mut_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * (T -> result (List_t T))) := - list_nth_mut_shared_loop_pair_loop T n ls0 ls1 i -. - -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 288:0-303: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) * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then - let back := fun (ret : T) => Ok (List_Cons ret tl0) in - Ok ((x0, x1), back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_mut_shared_loop_pair_merge_loop T n1 tl0 tl1 i1; - let (p1, back) := p in - let back1 := - fun (ret : T) => tl01 <- back ret; Ok (List_Cons x0 tl01) in - Ok (p1, back1)) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_mut_shared_loop_pair_merge]: @@ -583,38 +231,7 @@ 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) * (T -> result (List_t T))) := - list_nth_mut_shared_loop_pair_merge_loop T n ls0 ls1 i -. - -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 307:0-322: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) * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then - let back := fun (ret : T) => Ok (List_Cons ret tl1) in - Ok ((x0, x1), back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_shared_mut_loop_pair_loop T n1 tl0 tl1 i1; - let (p1, back) := p in - let back1 := - fun (ret : T) => tl11 <- back ret; Ok (List_Cons x1 tl11) in - Ok (p1, back1)) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_shared_mut_loop_pair]: @@ -623,38 +240,7 @@ Definition list_nth_shared_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * (T -> result (List_t T))) := - list_nth_shared_mut_loop_pair_loop T n ls0 ls1 i -. - -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 326:0-341: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) * (T -> result (List_t T))) - := - match n with - | O => Fail_ OutOfFuel - | S n1 => - match ls0 with - | List_Cons x0 tl0 => - match ls1 with - | List_Cons x1 tl1 => - if i s= 0%u32 - then - let back := fun (ret : T) => Ok (List_Cons ret tl1) in - Ok ((x0, x1), back) - else ( - i1 <- u32_sub i 1%u32; - p <- list_nth_shared_mut_loop_pair_merge_loop T n1 tl0 tl1 i1; - let (p1, back) := p in - let back1 := - fun (ret : T) => tl11 <- back ret; Ok (List_Cons x1 tl11) in - Ok (p1, back1)) - | List_Nil => Fail_ Failure - end - | List_Nil => Fail_ Failure - end - end + admit . (** [loops::list_nth_shared_mut_loop_pair_merge]: @@ -663,7 +249,7 @@ 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) * (T -> result (List_t T))) := - list_nth_shared_mut_loop_pair_merge_loop T n ls0 ls1 i + admit . (** [loops::ignore_input_mut_borrow]: loop 0: diff --git a/tests/fstar/arrays/Arrays.Clauses.Template.fst b/tests/fstar/arrays/Arrays.Clauses.Template.fst index e695b89b..c189e41e 100644 --- a/tests/fstar/arrays/Arrays.Clauses.Template.fst +++ b/tests/fstar/arrays/Arrays.Clauses.Template.fst @@ -6,25 +6,6 @@ open Arrays.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" -(** [arrays::sum]: decreases clause - Source: 'tests/src/arrays.rs', lines 242:0-250:1 *) -unfold -let sum_loop_decreases (s : slice u32) (sum1 : u32) (i : usize) : nat = - admit () - -(** [arrays::sum2]: decreases clause - Source: 'tests/src/arrays.rs', lines 252:0-261:1 *) -unfold -let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum1 : u32) - (i : usize) : nat = - admit () - -(** [arrays::zero_slice]: decreases clause - Source: 'tests/src/arrays.rs', lines 303:0-310:1 *) -unfold -let zero_slice_loop_decreases (a : slice u8) (i : usize) (len : usize) : nat = - admit () - (** [arrays::iter_mut_slice]: decreases clause Source: 'tests/src/arrays.rs', lines 312:0-318:1 *) unfold diff --git a/tests/fstar/arrays/Arrays.Funs.fst b/tests/fstar/arrays/Arrays.Funs.fst index 6196e3b7..f77b9c40 100644 --- a/tests/fstar/arrays/Arrays.Funs.fst +++ b/tests/fstar/arrays/Arrays.Funs.fst @@ -306,49 +306,15 @@ let take_array_t (a : array aB_t 2) : result unit = let non_copyable_array : result unit = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) -(** [arrays::sum]: loop 0: - Source: 'tests/src/arrays.rs', lines 242:0-250:1 *) -let rec sum_loop - (s : slice u32) (sum1 : u32) (i : usize) : - Tot (result u32) (decreases (sum_loop_decreases s sum1 i)) - = - let i1 = slice_len u32 s in - if i < i1 - then - let* i2 = slice_index_usize u32 s i in - let* sum3 = u32_add sum1 i2 in - let* i3 = usize_add i 1 in - sum_loop s sum3 i3 - else Ok sum1 - (** [arrays::sum]: Source: 'tests/src/arrays.rs', lines 242:0-242:28 *) let sum (s : slice u32) : result u32 = - sum_loop s 0 0 - -(** [arrays::sum2]: loop 0: - Source: 'tests/src/arrays.rs', lines 252:0-261:1 *) -let rec sum2_loop - (s : slice u32) (s2 : slice u32) (sum1 : u32) (i : usize) : - Tot (result u32) (decreases (sum2_loop_decreases s s2 sum1 i)) - = - let i1 = slice_len u32 s in - if i < i1 - then - let* i2 = slice_index_usize u32 s i in - let* i3 = slice_index_usize u32 s2 i in - let* i4 = u32_add i2 i3 in - let* sum3 = u32_add sum1 i4 in - let* i5 = usize_add i 1 in - sum2_loop s s2 sum3 i5 - else Ok sum1 + admit (** [arrays::sum2]: Source: 'tests/src/arrays.rs', lines 252:0-252:41 *) let sum2 (s : slice u32) (s2 : slice u32) : result u32 = - let i = slice_len u32 s in - let i1 = slice_len u32 s2 in - if not (i = i1) then Fail Failure else sum2_loop s s2 0 0 + admit (** [arrays::f0]: Source: 'tests/src/arrays.rs', lines 263:0-263:11 *) @@ -414,24 +380,10 @@ let ite : result unit = let* _ = to_slice_mut_back s1 in Ok () -(** [arrays::zero_slice]: loop 0: - Source: 'tests/src/arrays.rs', lines 303:0-310:1 *) -let rec zero_slice_loop - (a : slice u8) (i : usize) (len : usize) : - Tot (result (slice u8)) (decreases (zero_slice_loop_decreases a i len)) - = - if i < len - then - let* (_, index_mut_back) = slice_index_mut_usize u8 a i in - let* i1 = usize_add i 1 in - let* a1 = index_mut_back 0 in - zero_slice_loop a1 i1 len - else Ok a - (** [arrays::zero_slice]: Source: 'tests/src/arrays.rs', lines 303:0-303:31 *) let zero_slice (a : slice u8) : result (slice u8) = - let len = slice_len u8 a in zero_slice_loop a 0 len + admit (** [arrays::iter_mut_slice]: loop 0: Source: 'tests/src/arrays.rs', lines 312:0-318:1 *) diff --git a/tests/fstar/demo/Demo.fst b/tests/fstar/demo/Demo.fst index 41fd9804..c78dab8e 100644 --- a/tests/fstar/demo/Demo.fst +++ b/tests/fstar/demo/Demo.fst @@ -76,35 +76,13 @@ let rec list_nth_mut | CList_CNil -> Fail Failure end -(** [demo::list_nth_mut1]: loop 0: - Source: 'tests/src/demo.rs', lines 69:0-78:1 *) -let rec list_nth_mut1_loop - (t : Type0) (n : nat) (l : cList_t t) (i : u32) : - result (t & (t -> result (cList_t t))) - = - if is_zero n - then Fail OutOfFuel - else - let n1 = decrease n in - begin match l with - | CList_CCons x tl -> - if i = 0 - then let back = fun ret -> Ok (CList_CCons ret tl) in Ok (x, back) - else - let* i1 = u32_sub i 1 in - let* (x1, back) = list_nth_mut1_loop t n1 tl i1 in - let back1 = fun ret -> let* tl1 = back ret in Ok (CList_CCons x tl1) in - Ok (x1, back1) - | CList_CNil -> Fail Failure - end - (** [demo::list_nth_mut1]: Source: 'tests/src/demo.rs', lines 69:0-69:77 *) let list_nth_mut1 (t : Type0) (n : nat) (l : cList_t t) (i : u32) : result (t & (t -> result (cList_t t))) = - list_nth_mut1_loop t n l i + admit (** [demo::i32_id]: Source: 'tests/src/demo.rs', lines 80:0-80:28 *) diff --git a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst index b96f6784..5effb67a 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst @@ -13,59 +13,3 @@ 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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 = - admit () - diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index 2aca9fbe..638cd66f 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -58,59 +58,23 @@ let hashMap_new_with_capacity let hashMap_new (t : Type0) : result (hashMap_t t) = hashMap_new_with_capacity t 32 4 5 -(** [hashmap::{hashmap::HashMap}::clear]: loop 0: - Source: 'tests/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))) - (decreases (hashMap_clear_loop_decreases t slots i)) - = - let i1 = alloc_vec_Vec_len (list_t t) slots in - if i < i1 - then - let* (_, index_mut_back) = - alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i in - let* i2 = usize_add i 1 in - let* slots1 = index_mut_back List_Nil in - hashMap_clear_loop t slots1 i2 - else Ok slots - (** [hashmap::{hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 *) let hashMap_clear (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = - let* hm = hashMap_clear_loop t self.slots 0 in - Ok { self with num_entries = 0; slots = hm } + admit (** [hashmap::{hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 *) let hashMap_len (t : Type0) (self : hashMap_t t) : result usize = Ok self.num_entries -(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: - Source: 'tests/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 & (list_t t))) - (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) - = - begin match ls with - | List_Cons ckey cvalue tl -> - if ckey = key - then Ok (false, List_Cons ckey value tl) - else - let* (b, tl1) = hashMap_insert_in_list_loop t key value tl in - Ok (b, List_Cons ckey cvalue tl1) - | List_Nil -> Ok (true, List_Cons key value List_Nil) - end - (** [hashmap::{hashmap::HashMap}::insert_in_list]: Source: 'tests/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 & (list_t t)) = - hashMap_insert_in_list_loop t key value ls + admit (** [hashmap::{hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 *) @@ -133,46 +97,11 @@ let hashMap_insert_no_resize Ok { self with num_entries = i1; slots = v } else let* v = index_mut_back l1 in Ok { self with slots = v } -(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: - Source: 'tests/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)) - (decreases (hashMap_move_elements_from_list_loop_decreases t ntable ls)) - = - begin match ls with - | List_Cons k v tl -> - let* ntable1 = hashMap_insert_no_resize t ntable k v in - hashMap_move_elements_from_list_loop t ntable1 tl - | List_Nil -> Ok ntable - end - (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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: - Source: 'tests/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) : - Tot (result ((hashMap_t t) & (alloc_vec_Vec (list_t t)))) - (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) - = - let i1 = alloc_vec_Vec_len (list_t t) slots in - if i < i1 - then - let* (l, index_mut_back) = - alloc_vec_Vec_index_mut (list_t t) usize - (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i in - let (ls, l1) = core_mem_replace (list_t t) l List_Nil in - let* ntable1 = hashMap_move_elements_from_list t ntable ls in - let* i2 = usize_add i 1 in - let* slots1 = index_mut_back l1 in - hashMap_move_elements_loop t ntable1 slots1 i2 - else Ok (ntable, slots) + admit (** [hashmap::{hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 *) @@ -181,7 +110,7 @@ let hashMap_move_elements (i : usize) : result ((hashMap_t t) & (alloc_vec_Vec (list_t t))) = - hashMap_move_elements_loop t ntable slots i + admit (** [hashmap::{hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 *) @@ -213,24 +142,11 @@ let hashMap_insert let* i = hashMap_len t self1 in if i > self1.max_load then hashMap_try_resize t self1 else Ok self1 -(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: - Source: 'tests/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) - (decreases (hashMap_contains_key_in_list_loop_decreases t key ls)) - = - begin match ls with - | List_Cons ckey _ tl -> - if ckey = key then Ok true else hashMap_contains_key_in_list_loop t key tl - | List_Nil -> Ok false - end - (** [hashmap::{hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 + admit (** [hashmap::{hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 *) @@ -245,22 +161,10 @@ let hashMap_contains_key hash_mod in hashMap_contains_key_in_list t key l -(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: - Source: 'tests/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)) - = - begin match ls with - | List_Cons ckey cvalue tl -> - if ckey = key then Ok cvalue else hashMap_get_in_list_loop t key tl - | List_Nil -> Fail Failure - end - (** [hashmap::{hashmap::HashMap}::get_in_list]: Source: 'tests/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 + admit (** [hashmap::{hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 *) @@ -274,32 +178,13 @@ 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: - Source: 'tests/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 & (t -> result (list_t t)))) - (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) - = - begin match ls with - | List_Cons ckey cvalue tl -> - if ckey = key - then let back = fun ret -> Ok (List_Cons ckey ret tl) in Ok (cvalue, back) - else - let* (x, back) = hashMap_get_mut_in_list_loop t tl key in - let back1 = - fun ret -> let* tl1 = back ret in Ok (List_Cons ckey cvalue tl1) in - Ok (x, back1) - | List_Nil -> Fail Failure - end - (** [hashmap::{hashmap::HashMap}::get_mut_in_list]: Source: 'tests/src/hashmap.rs', lines 245:4-245:86 *) let hashMap_get_mut_in_list (t : Type0) (ls : list_t t) (key : usize) : result (t & (t -> result (list_t t))) = - hashMap_get_mut_in_list_loop t ls key + admit (** [hashmap::{hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 *) @@ -322,36 +207,13 @@ let hashMap_get_mut Ok { self with slots = v } in Ok (x, back) -(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: - Source: 'tests/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) & (list_t t))) - (decreases (hashMap_remove_from_list_loop_decreases t key ls)) - = - begin match ls with - | List_Cons ckey x tl -> - if ckey = key - then - let (mv_ls, _) = - core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in - begin match mv_ls with - | List_Cons _ cvalue tl1 -> Ok (Some cvalue, tl1) - | List_Nil -> Fail Failure - end - else - let* (o, tl1) = hashMap_remove_from_list_loop t key tl in - Ok (o, List_Cons ckey x tl1) - | List_Nil -> Ok (None, List_Nil) - end - (** [hashmap::{hashmap::HashMap}::remove_from_list]: Source: 'tests/src/hashmap.rs', lines 265:4-265:69 *) let hashMap_remove_from_list (t : Type0) (key : usize) (ls : list_t t) : result ((option t) & (list_t t)) = - hashMap_remove_from_list_loop t key ls + admit (** [hashmap::{hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 *) diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst index 0715bdcb..3c6b4af0 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst @@ -13,60 +13,3 @@ 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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 - Source: 'tests/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 = - admit () - diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 4a032207..27041dd6 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -61,31 +61,11 @@ let hashmap_HashMap_new_with_capacity 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: - Source: 'tests/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))) - (decreases (hashmap_HashMap_clear_loop_decreases t slots i)) - = - let i1 = alloc_vec_Vec_len (hashmap_List_t t) slots in - if i < i1 - then - let* (_, index_mut_back) = - alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i - in - let* i2 = usize_add i 1 in - let* slots1 = index_mut_back Hashmap_List_Nil in - hashmap_HashMap_clear_loop t slots1 i2 - else Ok slots - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: Source: 'tests/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* hm = hashmap_HashMap_clear_loop t self.slots 0 in - Ok { self with num_entries = 0; slots = hm } + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 *) @@ -93,30 +73,13 @@ let hashmap_HashMap_len (t : Type0) (self : hashmap_HashMap_t t) : result usize = Ok self.num_entries -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: - Source: 'tests/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 & (hashmap_List_t t))) - (decreases (hashmap_HashMap_insert_in_list_loop_decreases t key value ls)) - = - begin match ls with - | Hashmap_List_Cons ckey cvalue tl -> - if ckey = key - then Ok (false, Hashmap_List_Cons ckey value tl) - else - let* (b, tl1) = hashmap_HashMap_insert_in_list_loop t key value tl in - Ok (b, Hashmap_List_Cons ckey cvalue tl1) - | Hashmap_List_Nil -> Ok (true, Hashmap_List_Cons key value Hashmap_List_Nil) - end - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: Source: 'tests/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_List_t t)) = - hashmap_HashMap_insert_in_list_loop t key value ls + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 *) @@ -139,50 +102,13 @@ let hashmap_HashMap_insert_no_resize Ok { self with num_entries = i1; slots = v } else let* v = index_mut_back l1 in Ok { self with slots = v } -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: - Source: 'tests/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)) - (decreases ( - hashmap_HashMap_move_elements_from_list_loop_decreases t ntable ls)) - = - begin match ls with - | Hashmap_List_Cons k v tl -> - let* ntable1 = hashmap_HashMap_insert_no_resize t ntable k v in - hashmap_HashMap_move_elements_from_list_loop t ntable1 tl - | Hashmap_List_Nil -> Ok ntable - end - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) = - hashmap_HashMap_move_elements_from_list_loop t ntable ls - -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: - Source: 'tests/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) : - 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 i1 = alloc_vec_Vec_len (hashmap_List_t t) slots in - if i < i1 - then - let* (l, index_mut_back) = - alloc_vec_Vec_index_mut (hashmap_List_t t) usize - (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i - in - let (ls, l1) = core_mem_replace (hashmap_List_t t) l Hashmap_List_Nil in - let* ntable1 = hashmap_HashMap_move_elements_from_list t ntable ls in - let* i2 = usize_add i 1 in - let* slots1 = index_mut_back l1 in - hashmap_HashMap_move_elements_loop t ntable1 slots1 i2 - else Ok (ntable, slots) + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 *) @@ -191,7 +117,7 @@ let hashmap_HashMap_move_elements (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : result ((hashmap_HashMap_t t) & (alloc_vec_Vec (hashmap_List_t t))) = - hashmap_HashMap_move_elements_loop t ntable slots i + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 *) @@ -223,26 +149,11 @@ let hashmap_HashMap_insert let* i = hashmap_HashMap_len t self1 in if i > self1.max_load then hashmap_HashMap_try_resize t self1 else Ok self1 -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: - Source: 'tests/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) - (decreases (hashmap_HashMap_contains_key_in_list_loop_decreases t key ls)) - = - begin match ls with - | Hashmap_List_Cons ckey _ tl -> - if ckey = key - then Ok true - else hashmap_HashMap_contains_key_in_list_loop t key tl - | Hashmap_List_Nil -> Ok false - end - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 *) @@ -257,24 +168,11 @@ 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: - Source: 'tests/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) - (decreases (hashmap_HashMap_get_in_list_loop_decreases t key ls)) - = - begin match ls with - | Hashmap_List_Cons ckey cvalue tl -> - if ckey = key then Ok cvalue else hashmap_HashMap_get_in_list_loop t key tl - | Hashmap_List_Nil -> Fail Failure - end - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: Source: 'tests/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 + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 *) @@ -289,35 +187,13 @@ 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: - Source: 'tests/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 & (t -> result (hashmap_List_t t)))) - (decreases (hashmap_HashMap_get_mut_in_list_loop_decreases t ls key)) - = - begin match ls with - | Hashmap_List_Cons ckey cvalue tl -> - if ckey = key - then - let back = fun ret -> Ok (Hashmap_List_Cons ckey ret tl) in - Ok (cvalue, back) - else - let* (x, back) = hashmap_HashMap_get_mut_in_list_loop t tl key in - let back1 = - fun ret -> - let* tl1 = back ret in Ok (Hashmap_List_Cons ckey cvalue tl1) in - Ok (x, back1) - | Hashmap_List_Nil -> Fail Failure - end - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 & (t -> result (hashmap_List_t t))) = - hashmap_HashMap_get_mut_in_list_loop t ls key + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 *) @@ -340,37 +216,13 @@ let hashmap_HashMap_get_mut Ok { self with slots = v } in Ok (x, back) -(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: - Source: 'tests/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) & (hashmap_List_t t))) - (decreases (hashmap_HashMap_remove_from_list_loop_decreases t key ls)) - = - begin match ls with - | Hashmap_List_Cons ckey x tl -> - if ckey = key - then - let (mv_ls, _) = - core_mem_replace (hashmap_List_t t) (Hashmap_List_Cons ckey x tl) - Hashmap_List_Nil in - begin match mv_ls with - | Hashmap_List_Cons _ cvalue tl1 -> Ok (Some cvalue, tl1) - | Hashmap_List_Nil -> Fail Failure - end - else - let* (o, tl1) = hashmap_HashMap_remove_from_list_loop t key tl in - Ok (o, Hashmap_List_Cons ckey x tl1) - | Hashmap_List_Nil -> Ok (None, Hashmap_List_Nil) - end - (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: Source: 'tests/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_List_t t)) = - hashmap_HashMap_remove_from_list_loop t key ls + admit (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 *) diff --git a/tests/fstar/misc/Loops.Clauses.Template.fst b/tests/fstar/misc/Loops.Clauses.Template.fst index 77f9c3e4..21c128bb 100644 --- a/tests/fstar/misc/Loops.Clauses.Template.fst +++ b/tests/fstar/misc/Loops.Clauses.Template.fst @@ -30,111 +30,6 @@ let sum_array_loop_decreases (n : usize) (a : array u32 n) (i : usize) (s : u32) : nat = admit () -(** [loops::clear]: decreases clause - Source: 'tests/src/loops.rs', lines 62:0-68:1 *) -unfold -let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () - -(** [loops::list_mem]: decreases clause - Source: 'tests/src/loops.rs', lines 76:0-85:1 *) -unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () - -(** [loops::list_nth_mut_loop]: decreases clause - Source: 'tests/src/loops.rs', lines 88:0-98: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 - Source: 'tests/src/loops.rs', lines 101:0-111: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 - Source: 'tests/src/loops.rs', lines 113:0-127:1 *) -unfold -let get_elem_mut_loop_decreases (x : usize) (ls : list_t usize) : nat = - admit () - -(** [loops::get_elem_shared]: decreases clause - Source: 'tests/src/loops.rs', lines 129:0-143: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 - Source: 'tests/src/loops.rs', lines 154:0-165: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 - Source: 'tests/src/loops.rs', lines 168:0-179: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 - Source: 'tests/src/loops.rs', lines 184:0-205: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 - Source: 'tests/src/loops.rs', lines 208:0-229: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 - Source: 'tests/src/loops.rs', lines 233:0-248: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 - Source: 'tests/src/loops.rs', lines 251:0-266: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 - Source: 'tests/src/loops.rs', lines 269:0-284: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 - Source: 'tests/src/loops.rs', lines 288:0-303: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 - Source: 'tests/src/loops.rs', lines 307:0-322: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 - Source: 'tests/src/loops.rs', lines 326:0-341: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 = - admit () - (** [loops::ignore_input_mut_borrow]: decreases clause Source: 'tests/src/loops.rs', lines 345:0-349:1 *) unfold let ignore_input_mut_borrow_loop_decreases (i : u32) : nat = admit () diff --git a/tests/fstar/misc/Loops.Funs.fst b/tests/fstar/misc/Loops.Funs.fst index 0eafeebb..dc53a04b 100644 --- a/tests/fstar/misc/Loops.Funs.fst +++ b/tests/fstar/misc/Loops.Funs.fst @@ -77,62 +77,15 @@ let rec sum_array_loop let sum_array (n : usize) (a : array u32 n) : result u32 = sum_array_loop n a 0 0 -(** [loops::clear]: loop 0: - Source: 'tests/src/loops.rs', lines 62:0-68:1 *) -let rec clear_loop - (v : alloc_vec_Vec u32) (i : usize) : - Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) - = - let i1 = alloc_vec_Vec_len u32 v in - if i < i1 - then - let* (_, index_mut_back) = - alloc_vec_Vec_index_mut u32 usize - (core_slice_index_SliceIndexUsizeSliceTInst u32) v i in - let* i2 = usize_add i 1 in - let* v1 = index_mut_back 0 in - clear_loop v1 i2 - else Ok v - (** [loops::clear]: Source: 'tests/src/loops.rs', lines 62:0-62:30 *) let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = - clear_loop v 0 - -(** [loops::list_mem]: loop 0: - Source: 'tests/src/loops.rs', lines 76:0-85:1 *) -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 Ok true else list_mem_loop x tl - | List_Nil -> Ok false - end + admit (** [loops::list_mem]: Source: 'tests/src/loops.rs', lines 76:0-76:52 *) let list_mem (x : u32) (ls : list_t u32) : result bool = - list_mem_loop x ls - -(** [loops::list_nth_mut_loop]: loop 0: - Source: 'tests/src/loops.rs', lines 88:0-98:1 *) -let rec list_nth_mut_loop_loop - (t : Type0) (ls : list_t t) (i : u32) : - Tot (result (t & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl) in Ok (x, back) - else - let* i1 = u32_sub i 1 in - let* (x1, back) = list_nth_mut_loop_loop t tl i1 in - let back1 = fun ret -> let* tl1 = back ret in Ok (List_Cons x tl1) in - Ok (x1, back1) - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_mut_loop]: Source: 'tests/src/loops.rs', lines 88:0-88:71 *) @@ -140,44 +93,12 @@ let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result (t & (t -> result (list_t t))) = - list_nth_mut_loop_loop t ls i - -(** [loops::list_nth_shared_loop]: loop 0: - Source: 'tests/src/loops.rs', lines 101:0-111: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)) - = - begin match ls with - | List_Cons x tl -> - if i = 0 - then Ok x - else let* i1 = u32_sub i 1 in list_nth_shared_loop_loop t tl i1 - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_shared_loop]: Source: 'tests/src/loops.rs', lines 101:0-101: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: - Source: 'tests/src/loops.rs', lines 113:0-127:1 *) -let rec get_elem_mut_loop - (x : usize) (ls : list_t usize) : - Tot (result (usize & (usize -> result (list_t usize)))) - (decreases (get_elem_mut_loop_decreases x ls)) - = - begin match ls with - | List_Cons y tl -> - if y = x - then let back = fun ret -> Ok (List_Cons ret tl) in Ok (y, back) - else - let* (i, back) = get_elem_mut_loop x tl in - let back1 = fun ret -> let* tl1 = back ret in Ok (List_Cons y tl1) in - Ok (i, back1) - | List_Nil -> Fail Failure - end + admit (** [loops::get_elem_mut]: Source: 'tests/src/loops.rs', lines 113:0-113:73 *) @@ -185,32 +106,13 @@ let get_elem_mut (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result (usize & (usize -> result (alloc_vec_Vec (list_t usize)))) = - let* (ls, index_mut_back) = - alloc_vec_Vec_index_mut (list_t usize) usize - (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in - let* (i, back) = get_elem_mut_loop x ls in - let back1 = fun ret -> let* l = back ret in index_mut_back l in - Ok (i, back1) - -(** [loops::get_elem_shared]: loop 0: - Source: 'tests/src/loops.rs', lines 129:0-143:1 *) -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 Ok y else get_elem_shared_loop x tl - | List_Nil -> Fail Failure - end + admit (** [loops::get_elem_shared]: Source: 'tests/src/loops.rs', lines 129:0-129:68 *) let get_elem_shared (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = - let* ls = - alloc_vec_Vec_index (list_t usize) usize - (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in - get_elem_shared_loop x ls + admit (** [loops::id_mut]: Source: 'tests/src/loops.rs', lines 145:0-145:50 *) @@ -225,85 +127,19 @@ let id_mut let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = Ok ls -(** [loops::list_nth_mut_loop_with_id]: loop 0: - Source: 'tests/src/loops.rs', lines 154:0-165:1 *) -let rec list_nth_mut_loop_with_id_loop - (t : Type0) (i : u32) (ls : list_t t) : - Tot (result (t & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl) in Ok (x, back) - else - let* i1 = u32_sub i 1 in - let* (x1, back) = list_nth_mut_loop_with_id_loop t i1 tl in - let back1 = fun ret -> let* tl1 = back ret in Ok (List_Cons x tl1) in - Ok (x1, back1) - | List_Nil -> Fail Failure - end - (** [loops::list_nth_mut_loop_with_id]: Source: 'tests/src/loops.rs', lines 154:0-154:75 *) let list_nth_mut_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result (t & (t -> result (list_t t))) = - let* (ls1, id_mut_back) = id_mut t ls in - let* (x, back) = list_nth_mut_loop_with_id_loop t i ls1 in - let back1 = fun ret -> let* l = back ret in id_mut_back l in - Ok (x, back1) - -(** [loops::list_nth_shared_loop_with_id]: loop 0: - Source: 'tests/src/loops.rs', lines 168:0-179:1 *) -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 Ok x - else let* i1 = u32_sub i 1 in list_nth_shared_loop_with_id_loop t i1 tl - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_shared_loop_with_id]: Source: 'tests/src/loops.rs', lines 168:0-168:70 *) let list_nth_shared_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = - let* ls1 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls1 - -(** [loops::list_nth_mut_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 184:0-205: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) & (t -> result (list_t t)) & (t -> 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 - let back'a = fun ret -> Ok (List_Cons ret tl0) in - let back'b = fun ret -> Ok (List_Cons ret tl1) in - Ok ((x0, x1), back'a, back'b) - else - let* i1 = u32_sub i 1 in - let* (p, back'a, back'b) = list_nth_mut_loop_pair_loop t tl0 tl1 i1 in - let back'a1 = - fun ret -> let* tl01 = back'a ret in Ok (List_Cons x0 tl01) in - let back'b1 = - fun ret -> let* tl11 = back'b ret in Ok (List_Cons x1 tl11) in - Ok (p, back'a1, back'b1) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 184:0-188:27 *) @@ -311,62 +147,13 @@ let list_nth_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t)) & (t -> result (list_t t))) = - list_nth_mut_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_shared_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 208:0-229: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)) - (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 Ok (x0, x1) - else let* i1 = u32_sub i 1 in list_nth_shared_loop_pair_loop t tl0 tl1 i1 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 208:0-212: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: - Source: 'tests/src/loops.rs', lines 233:0-248: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) & ((t & t) -> 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 back = - fun ret -> - let (x, x2) = ret in Ok (List_Cons x tl0, List_Cons x2 tl1) in - Ok ((x0, x1), back) - else - let* i1 = u32_sub i 1 in - let* (p, back) = list_nth_mut_loop_pair_merge_loop t tl0 tl1 i1 in - let back1 = - fun ret -> - let* (tl01, tl11) = back ret in - Ok (List_Cons x0 tl01, List_Cons x1 tl11) in - Ok (p, back1) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 233:0-237:27 *) @@ -374,58 +161,13 @@ let list_nth_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & ((t & t) -> result ((list_t t) & (list_t t)))) = - list_nth_mut_loop_pair_merge_loop t ls0 ls1 i - -(** [loops::list_nth_shared_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 251:0-266: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)) - (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 Ok (x0, x1) - else - let* i1 = u32_sub i 1 in - list_nth_shared_loop_pair_merge_loop t tl0 tl1 i1 - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 251:0-255: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: - Source: 'tests/src/loops.rs', lines 269:0-284: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl0) in Ok ((x0, x1), back) - else - let* i1 = u32_sub i 1 in - let* (p, back) = list_nth_mut_shared_loop_pair_loop t tl0 tl1 i1 in - let back1 = fun ret -> let* tl01 = back ret in Ok (List_Cons x0 tl01) - in - Ok (p, back1) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_mut_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 269:0-273:23 *) @@ -433,32 +175,7 @@ let list_nth_mut_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - list_nth_mut_shared_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 288:0-303: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl0) in Ok ((x0, x1), back) - else - let* i1 = u32_sub i 1 in - let* (p, back) = list_nth_mut_shared_loop_pair_merge_loop t tl0 tl1 i1 - in - let back1 = fun ret -> let* tl01 = back ret in Ok (List_Cons x0 tl01) - in - Ok (p, back1) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_mut_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 288:0-292:23 *) @@ -466,31 +183,7 @@ let list_nth_mut_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i - -(** [loops::list_nth_shared_mut_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 307:0-322: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl1) in Ok ((x0, x1), back) - else - let* i1 = u32_sub i 1 in - let* (p, back) = list_nth_shared_mut_loop_pair_loop t tl0 tl1 i1 in - let back1 = fun ret -> let* tl11 = back ret in Ok (List_Cons x1 tl11) - in - Ok (p, back1) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_shared_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 307:0-311:23 *) @@ -498,32 +191,7 @@ let list_nth_shared_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - list_nth_shared_mut_loop_pair_loop t ls0 ls1 i - -(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 326:0-341: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl1) in Ok ((x0, x1), back) - else - let* i1 = u32_sub i 1 in - let* (p, back) = list_nth_shared_mut_loop_pair_merge_loop t tl0 tl1 i1 - in - let back1 = fun ret -> let* tl11 = back ret in Ok (List_Cons x1 tl11) - in - Ok (p, back1) - | List_Nil -> Fail Failure - end - | List_Nil -> Fail Failure - end + admit (** [loops::list_nth_shared_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 326:0-330:23 *) @@ -531,7 +199,7 @@ let list_nth_shared_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i + admit (** [loops::ignore_input_mut_borrow]: loop 0: Source: 'tests/src/loops.rs', lines 345:0-349:1 *) diff --git a/tests/lean/Arrays.lean b/tests/lean/Arrays.lean index 5ffcce51..464c3ced 100644 --- a/tests/lean/Arrays.lean +++ b/tests/lean/Arrays.lean @@ -345,48 +345,15 @@ def take_array_t (a : Array AB 2#usize) : Result Unit := def non_copyable_array : Result Unit := take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) -/- [arrays::sum]: loop 0: - Source: 'tests/src/arrays.rs', lines 242:0-250:1 -/ -divergent def sum_loop (s : Slice U32) (sum1 : U32) (i : Usize) : Result U32 := - let i1 := Slice.len U32 s - if i < i1 - then - do - let i2 ← Slice.index_usize U32 s i - let sum3 ← sum1 + i2 - let i3 ← i + 1#usize - sum_loop s sum3 i3 - else Result.ok sum1 - /- [arrays::sum]: Source: 'tests/src/arrays.rs', lines 242:0-242:28 -/ def sum (s : Slice U32) : Result U32 := - sum_loop s 0#u32 0#usize - -/- [arrays::sum2]: loop 0: - Source: 'tests/src/arrays.rs', lines 252:0-261:1 -/ -divergent def sum2_loop - (s : Slice U32) (s2 : Slice U32) (sum1 : U32) (i : Usize) : Result U32 := - let i1 := Slice.len U32 s - if i < i1 - then - do - let i2 ← Slice.index_usize U32 s i - let i3 ← Slice.index_usize U32 s2 i - let i4 ← i2 + i3 - let sum3 ← sum1 + i4 - let i5 ← i + 1#usize - sum2_loop s s2 sum3 i5 - else Result.ok sum1 + sorry /- [arrays::sum2]: Source: 'tests/src/arrays.rs', lines 252:0-252:41 -/ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := - let i := Slice.len U32 s - let i1 := Slice.len U32 s2 - if ¬ (i = i1) - then Result.fail .panic - else sum2_loop s s2 0#u32 0#usize + sorry /- [arrays::f0]: Source: 'tests/src/arrays.rs', lines 263:0-263:11 -/ @@ -460,24 +427,10 @@ def ite : Result Unit := let _ ← to_slice_mut_back s1 Result.ok () -/- [arrays::zero_slice]: loop 0: - Source: 'tests/src/arrays.rs', lines 303:0-310:1 -/ -divergent def zero_slice_loop - (a : Slice U8) (i : Usize) (len : Usize) : Result (Slice U8) := - if i < len - then - do - let (_, index_mut_back) ← Slice.index_mut_usize U8 a i - let i1 ← i + 1#usize - let a1 ← index_mut_back 0#u8 - zero_slice_loop a1 i1 len - else Result.ok a - /- [arrays::zero_slice]: Source: 'tests/src/arrays.rs', lines 303:0-303:31 -/ def zero_slice (a : Slice U8) : Result (Slice U8) := - let len := Slice.len U8 a - zero_slice_loop a 0#usize len + sorry /- [arrays::iter_mut_slice]: loop 0: Source: 'tests/src/arrays.rs', lines 312:0-318:1 -/ diff --git a/tests/lean/Demo/Demo.lean b/tests/lean/Demo/Demo.lean index a9b349b3..7402f010 100644 --- a/tests/lean/Demo/Demo.lean +++ b/tests/lean/Demo/Demo.lean @@ -87,36 +87,13 @@ divergent def list_nth_mut Result.ok (t, back) | CList.CNil => Result.fail .panic -/- [demo::list_nth_mut1]: loop 0: - Source: 'tests/src/demo.rs', lines 69:0-78:1 -/ -divergent def list_nth_mut1_loop - (T : Type) (l : CList T) (i : U32) : - Result (T × (T → Result (CList T))) - := - match l with - | CList.CCons x tl => - if i = 0#u32 - then - let back := fun ret => Result.ok (CList.CCons ret tl) - Result.ok (x, back) - else - do - let i1 ← i - 1#u32 - let (t, back) ← list_nth_mut1_loop T tl i1 - let back1 := - fun ret => do - let tl1 ← back ret - Result.ok (CList.CCons x tl1) - Result.ok (t, back1) - | CList.CNil => Result.fail .panic - /- [demo::list_nth_mut1]: Source: 'tests/src/demo.rs', lines 69:0-69:77 -/ def list_nth_mut1 (T : Type) (l : CList T) (i : U32) : Result (T × (T → Result (CList T))) := - list_nth_mut1_loop T l i + sorry /- [demo::i32_id]: Source: 'tests/src/demo.rs', lines 80:0-80:28 -/ diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index cb11e5cf..a107240e 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -57,59 +57,23 @@ def HashMap.new_with_capacity 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: - Source: 'tests/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)) - := - let i1 := alloc.vec.Vec.len (List T) slots - if i < i1 - then - do - let (_, index_mut_back) ← - alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i - let i2 ← i + 1#usize - let slots1 ← index_mut_back List.Nil - HashMap.clear_loop T slots1 i2 - else Result.ok slots - /- [hashmap::{hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 -/ def HashMap.clear (T : Type) (self : HashMap T) : Result (HashMap T) := - do - let hm ← HashMap.clear_loop T self.slots 0#usize - Result.ok { self with num_entries := 0#usize, slots := hm } + sorry /- [hashmap::{hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 -/ def HashMap.len (T : Type) (self : HashMap T) : Result Usize := Result.ok self.num_entries -/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: - Source: 'tests/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 × (List T)) - := - match ls with - | List.Cons ckey cvalue tl => - if ckey = key - then Result.ok (false, List.Cons ckey value tl) - else - do - let (b, tl1) ← HashMap.insert_in_list_loop T key value tl - Result.ok (b, List.Cons ckey cvalue tl1) - | List.Nil => Result.ok (true, List.Cons key value List.Nil) - /- [hashmap::{hashmap::HashMap}::insert_in_list]: Source: 'tests/src/hashmap.rs', lines 97:4-97:71 -/ def HashMap.insert_in_list (T : Type) (key : Usize) (value : T) (ls : List T) : Result (Bool × (List T)) := - HashMap.insert_in_list_loop T key value ls + sorry /- [hashmap::{hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 -/ @@ -135,43 +99,11 @@ def HashMap.insert_no_resize let v ← index_mut_back l1 Result.ok { self with slots := v } -/- [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: - Source: 'tests/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 - | List.Cons k v tl => - do - let ntable1 ← HashMap.insert_no_resize T ntable k v - HashMap.move_elements_from_list_loop T ntable1 tl - | List.Nil => Result.ok ntable - /- [hashmap::{hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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: - Source: 'tests/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) - : - Result ((HashMap T) × (alloc.vec.Vec (List T))) - := - let i1 := alloc.vec.Vec.len (List T) slots - if i < i1 - then - do - let (l, index_mut_back) ← - alloc.vec.Vec.index_mut (List T) Usize - (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i - let (ls, l1) := core.mem.replace (List T) l List.Nil - let ntable1 ← HashMap.move_elements_from_list T ntable ls - let i2 ← i + 1#usize - let slots1 ← index_mut_back l1 - HashMap.move_elements_loop T ntable1 slots1 i2 - else Result.ok (ntable, slots) + sorry /- [hashmap::{hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 -/ @@ -180,7 +112,7 @@ def HashMap.move_elements : Result ((HashMap T) × (alloc.vec.Vec (List T))) := - HashMap.move_elements_loop T ntable slots i + sorry /- [hashmap::{hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 -/ @@ -219,22 +151,11 @@ def HashMap.insert then HashMap.try_resize T self1 else Result.ok self1 -/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: - Source: 'tests/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 - | List.Cons ckey _ tl => - if ckey = key - then Result.ok true - else HashMap.contains_key_in_list_loop T key tl - | List.Nil => Result.ok false - /- [hashmap::{hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 + sorry /- [hashmap::{hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 -/ @@ -249,21 +170,10 @@ def HashMap.contains_key (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots hash_mod HashMap.contains_key_in_list T key l -/- [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: - Source: 'tests/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 - | List.Cons ckey cvalue tl => - if ckey = key - then Result.ok cvalue - else HashMap.get_in_list_loop T key tl - | List.Nil => Result.fail .panic - /- [hashmap::{hashmap::HashMap}::get_in_list]: Source: 'tests/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 + sorry /- [hashmap::{hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 -/ @@ -277,36 +187,13 @@ def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots hash_mod HashMap.get_in_list T key l -/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: - Source: 'tests/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 × (T → Result (List T))) - := - match ls with - | List.Cons ckey cvalue tl => - if ckey = key - then - let back := fun ret => Result.ok (List.Cons ckey ret tl) - Result.ok (cvalue, back) - else - do - let (t, back) ← HashMap.get_mut_in_list_loop T tl key - let back1 := - fun ret => - do - let tl1 ← back ret - Result.ok (List.Cons ckey cvalue tl1) - Result.ok (t, back1) - | List.Nil => Result.fail .panic - /- [hashmap::{hashmap::HashMap}::get_mut_in_list]: Source: 'tests/src/hashmap.rs', lines 245:4-245:86 -/ def HashMap.get_mut_in_list (T : Type) (ls : List T) (key : Usize) : Result (T × (T → Result (List T))) := - HashMap.get_mut_in_list_loop T ls key + sorry /- [hashmap::{hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 -/ @@ -330,30 +217,11 @@ def HashMap.get_mut Result.ok { self with slots := v } Result.ok (t, back) -/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: - Source: 'tests/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) × (List T)) := - match ls with - | List.Cons ckey t tl => - if ckey = key - then - let (mv_ls, _) := - core.mem.replace (List T) (List.Cons ckey t tl) List.Nil - match mv_ls with - | List.Cons _ cvalue tl1 => Result.ok (some cvalue, tl1) - | List.Nil => Result.fail .panic - else - do - let (o, tl1) ← HashMap.remove_from_list_loop T key tl - Result.ok (o, List.Cons ckey t tl1) - | List.Nil => Result.ok (none, List.Nil) - /- [hashmap::{hashmap::HashMap}::remove_from_list]: Source: 'tests/src/hashmap.rs', lines 265:4-265:69 -/ def HashMap.remove_from_list (T : Type) (key : Usize) (ls : List T) : Result ((Option T) × (List T)) := - HashMap.remove_from_list_loop T key ls + sorry /- [hashmap::{hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 -/ diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index e27305b1..d3c4ae77 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -60,61 +60,24 @@ def hashmap.HashMap.new_with_capacity 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: - Source: 'tests/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)) - := - let i1 := alloc.vec.Vec.len (hashmap.List T) slots - if i < i1 - then - do - let (_, index_mut_back) ← - alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i - let i2 ← i + 1#usize - let slots1 ← index_mut_back hashmap.List.Nil - hashmap.HashMap.clear_loop T slots1 i2 - else Result.ok slots - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 -/ def hashmap.HashMap.clear (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := - do - let hm ← hashmap.HashMap.clear_loop T self.slots 0#usize - Result.ok { self with num_entries := 0#usize, slots := hm } + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 -/ def hashmap.HashMap.len (T : Type) (self : hashmap.HashMap T) : Result Usize := Result.ok self.num_entries -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: - Source: 'tests/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 × (hashmap.List T)) - := - match ls with - | hashmap.List.Cons ckey cvalue tl => - if ckey = key - then Result.ok (false, hashmap.List.Cons ckey value tl) - else - do - let (b, tl1) ← hashmap.HashMap.insert_in_list_loop T key value tl - Result.ok (b, hashmap.List.Cons ckey cvalue tl1) - | hashmap.List.Nil => - Result.ok (true, hashmap.List.Cons key value hashmap.List.Nil) - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: Source: 'tests/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.List T)) := - hashmap.HashMap.insert_in_list_loop T key value ls + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 -/ @@ -141,47 +104,13 @@ def hashmap.HashMap.insert_no_resize let v ← index_mut_back l1 Result.ok { self with slots := v } -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: - Source: 'tests/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) - := - match ls with - | hashmap.List.Cons k v tl => - do - let ntable1 ← hashmap.HashMap.insert_no_resize T ntable k v - hashmap.HashMap.move_elements_from_list_loop T ntable1 tl - | hashmap.List.Nil => Result.ok ntable - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - hashmap.HashMap.move_elements_from_list_loop T ntable ls - -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: - Source: 'tests/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) : - Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) - := - let i1 := alloc.vec.Vec.len (hashmap.List T) slots - if i < i1 - then - do - let (l, index_mut_back) ← - alloc.vec.Vec.index_mut (hashmap.List T) Usize - (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i - let (ls, l1) := core.mem.replace (hashmap.List T) l hashmap.List.Nil - let ntable1 ← hashmap.HashMap.move_elements_from_list T ntable ls - let i2 ← i + 1#usize - let slots1 ← index_mut_back l1 - hashmap.HashMap.move_elements_loop T ntable1 slots1 i2 - else Result.ok (ntable, slots) + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 -/ @@ -190,7 +119,7 @@ def hashmap.HashMap.move_elements (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 + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 -/ @@ -230,22 +159,11 @@ def hashmap.HashMap.insert then hashmap.HashMap.try_resize T self1 else Result.ok self1 -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: - Source: 'tests/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 - | hashmap.List.Cons ckey _ tl => - if ckey = key - then Result.ok true - else hashmap.HashMap.contains_key_in_list_loop T key tl - | hashmap.List.Nil => Result.ok false - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 -/ @@ -261,22 +179,11 @@ def hashmap.HashMap.contains_key hash_mod hashmap.HashMap.contains_key_in_list T key l -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: - Source: 'tests/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 - | hashmap.List.Cons ckey cvalue tl => - if ckey = key - then Result.ok cvalue - else hashmap.HashMap.get_in_list_loop T key tl - | hashmap.List.Nil => Result.fail .panic - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: Source: 'tests/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 + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 -/ @@ -292,36 +199,13 @@ def hashmap.HashMap.get hash_mod hashmap.HashMap.get_in_list T key l -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: - Source: 'tests/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 × (T → Result (hashmap.List T))) - := - match ls with - | hashmap.List.Cons ckey cvalue tl => - if ckey = key - then - let back := fun ret => Result.ok (hashmap.List.Cons ckey ret tl) - Result.ok (cvalue, back) - else - do - let (t, back) ← hashmap.HashMap.get_mut_in_list_loop T tl key - let back1 := - fun ret => - do - let tl1 ← back ret - Result.ok (hashmap.List.Cons ckey cvalue tl1) - Result.ok (t, back1) - | hashmap.List.Nil => Result.fail .panic - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 × (T → Result (hashmap.List T))) := - hashmap.HashMap.get_mut_in_list_loop T ls key + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 -/ @@ -346,35 +230,13 @@ def hashmap.HashMap.get_mut Result.ok { self with slots := v } Result.ok (t, back) -/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: - Source: 'tests/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) × (hashmap.List T)) - := - match ls with - | hashmap.List.Cons ckey t tl => - if ckey = key - then - let (mv_ls, _) := - core.mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) - hashmap.List.Nil - match mv_ls with - | hashmap.List.Cons _ cvalue tl1 => Result.ok (some cvalue, tl1) - | hashmap.List.Nil => Result.fail .panic - else - do - let (o, tl1) ← hashmap.HashMap.remove_from_list_loop T key tl - Result.ok (o, hashmap.List.Cons ckey t tl1) - | hashmap.List.Nil => Result.ok (none, hashmap.List.Nil) - /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: Source: 'tests/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.List T)) := - hashmap.HashMap.remove_from_list_loop T key ls + sorry /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 -/ diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index d5bda6ab..046d2240 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -72,26 +72,10 @@ divergent def sum_array_loop def sum_array (N : Usize) (a : Array U32 N) : Result U32 := sum_array_loop N a 0#usize 0#u32 -/- [loops::clear]: loop 0: - Source: 'tests/src/loops.rs', lines 62:0-68:1 -/ -divergent def clear_loop - (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := - let i1 := alloc.vec.Vec.len U32 v - if i < i1 - then - do - let (_, index_mut_back) ← - alloc.vec.Vec.index_mut U32 Usize - (core.slice.index.SliceIndexUsizeSliceTInst U32) v i - let i2 ← i + 1#usize - let v1 ← index_mut_back 0#u32 - clear_loop v1 i2 - else Result.ok v - /- [loops::clear]: Source: 'tests/src/loops.rs', lines 62:0-62:30 -/ def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := - clear_loop v 0#usize + sorry /- [loops::List] Source: 'tests/src/loops.rs', lines 70:0-70:16 -/ @@ -99,86 +83,21 @@ inductive List (T : Type) := | Cons : T → List T → List T | Nil : List T -/- [loops::list_mem]: loop 0: - Source: 'tests/src/loops.rs', lines 76:0-85:1 -/ -divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := - match ls with - | List.Cons y tl => if y = x - then Result.ok true - else list_mem_loop x tl - | List.Nil => Result.ok false - /- [loops::list_mem]: Source: 'tests/src/loops.rs', lines 76:0-76:52 -/ def list_mem (x : U32) (ls : List U32) : Result Bool := - list_mem_loop x ls - -/- [loops::list_nth_mut_loop]: loop 0: - Source: 'tests/src/loops.rs', lines 88:0-98:1 -/ -divergent def list_nth_mut_loop_loop - (T : Type) (ls : List T) (i : U32) : Result (T × (T → Result (List T))) := - match ls with - | List.Cons x tl => - if i = 0#u32 - then - let back := fun ret => Result.ok (List.Cons ret tl) - Result.ok (x, back) - else - do - let i1 ← i - 1#u32 - let (t, back) ← list_nth_mut_loop_loop T tl i1 - let back1 := - fun ret => do - let tl1 ← back ret - Result.ok (List.Cons x tl1) - Result.ok (t, back1) - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_mut_loop]: Source: 'tests/src/loops.rs', lines 88:0-88:71 -/ def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result (T × (T → Result (List T))) := - list_nth_mut_loop_loop T ls i - -/- [loops::list_nth_shared_loop]: loop 0: - Source: 'tests/src/loops.rs', lines 101:0-111:1 -/ -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.ok x - else do - let i1 ← i - 1#u32 - list_nth_shared_loop_loop T tl i1 - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_shared_loop]: Source: 'tests/src/loops.rs', lines 101:0-101: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: - Source: 'tests/src/loops.rs', lines 113:0-127:1 -/ -divergent def get_elem_mut_loop - (x : Usize) (ls : List Usize) : - Result (Usize × (Usize → Result (List Usize))) - := - match ls with - | List.Cons y tl => - if y = x - then - let back := fun ret => Result.ok (List.Cons ret tl) - Result.ok (y, back) - else - do - let (i, back) ← get_elem_mut_loop x tl - let back1 := - fun ret => do - let tl1 ← back ret - Result.ok (List.Cons y tl1) - Result.ok (i, back1) - | List.Nil => Result.fail .panic + sorry /- [loops::get_elem_mut]: Source: 'tests/src/loops.rs', lines 113:0-113:73 -/ @@ -186,35 +105,13 @@ def get_elem_mut (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result (Usize × (Usize → Result (alloc.vec.Vec (List Usize)))) := - do - let (ls, index_mut_back) ← - alloc.vec.Vec.index_mut (List Usize) Usize - (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize - let (i, back) ← get_elem_mut_loop x ls - let back1 := fun ret => do - let l ← back ret - index_mut_back l - Result.ok (i, back1) - -/- [loops::get_elem_shared]: loop 0: - Source: 'tests/src/loops.rs', lines 129:0-143:1 -/ -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.ok y - else get_elem_shared_loop x tl - | List.Nil => Result.fail .panic + sorry /- [loops::get_elem_shared]: Source: 'tests/src/loops.rs', lines 129:0-129:68 -/ def get_elem_shared (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := - do - let ls ← - alloc.vec.Vec.index (List Usize) Usize - (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize - get_elem_shared_loop x ls + sorry /- [loops::id_mut]: Source: 'tests/src/loops.rs', lines 145:0-145:50 -/ @@ -229,90 +126,17 @@ def id_mut def id_shared (T : Type) (ls : List T) : Result (List T) := Result.ok ls -/- [loops::list_nth_mut_loop_with_id]: loop 0: - Source: 'tests/src/loops.rs', lines 154:0-165:1 -/ -divergent def list_nth_mut_loop_with_id_loop - (T : Type) (i : U32) (ls : List T) : Result (T × (T → Result (List T))) := - match ls with - | List.Cons x tl => - if i = 0#u32 - then - let back := fun ret => Result.ok (List.Cons ret tl) - Result.ok (x, back) - else - do - let i1 ← i - 1#u32 - let (t, back) ← list_nth_mut_loop_with_id_loop T i1 tl - let back1 := - fun ret => do - let tl1 ← back ret - Result.ok (List.Cons x tl1) - Result.ok (t, back1) - | List.Nil => Result.fail .panic - /- [loops::list_nth_mut_loop_with_id]: Source: 'tests/src/loops.rs', lines 154:0-154:75 -/ def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result (T × (T → Result (List T))) := - do - let (ls1, id_mut_back) ← id_mut T ls - let (t, back) ← list_nth_mut_loop_with_id_loop T i ls1 - let back1 := fun ret => do - let l ← back ret - id_mut_back l - Result.ok (t, back1) - -/- [loops::list_nth_shared_loop_with_id]: loop 0: - Source: 'tests/src/loops.rs', lines 168:0-179:1 -/ -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.ok x - else do - let i1 ← i - 1#u32 - list_nth_shared_loop_with_id_loop T i1 tl - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_shared_loop_with_id]: Source: 'tests/src/loops.rs', lines 168:0-168:70 -/ def list_nth_shared_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := - do - let ls1 ← id_shared T ls - list_nth_shared_loop_with_id_loop T i ls1 - -/- [loops::list_nth_mut_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 184:0-205:1 -/ -divergent def list_nth_mut_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : - Result ((T × T) × (T → Result (List T)) × (T → Result (List T))) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then - let back'a := fun ret => Result.ok (List.Cons ret tl0) - let back'b := fun ret => Result.ok (List.Cons ret tl1) - Result.ok ((x0, x1), back'a, back'b) - else - do - let i1 ← i - 1#u32 - let (p, back'a, back'b) ← list_nth_mut_loop_pair_loop T tl0 tl1 i1 - let back'a1 := - fun ret => do - let tl01 ← back'a ret - Result.ok (List.Cons x0 tl01) - let back'b1 := - fun ret => do - let tl11 ← back'b ret - Result.ok (List.Cons x1 tl11) - Result.ok (p, back'a1, back'b1) - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 184:0-188:27 -/ @@ -320,59 +144,13 @@ def list_nth_mut_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T)) × (T → Result (List T))) := - list_nth_mut_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_shared_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 208:0-229: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 - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ok (x0, x1) - else do - let i1 ← i - 1#u32 - list_nth_shared_loop_pair_loop T tl0 tl1 i1 - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 208:0-212: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: - Source: 'tests/src/loops.rs', lines 233:0-248:1 -/ -divergent def list_nth_mut_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : - Result ((T × T) × ((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 back := - fun ret => - let (t, t1) := ret - Result.ok (List.Cons t tl0, List.Cons t1 tl1) - Result.ok ((x0, x1), back) - else - do - let i1 ← i - 1#u32 - let (p, back) ← list_nth_mut_loop_pair_merge_loop T tl0 tl1 i1 - let back1 := - fun ret => - do - let (tl01, tl11) ← back ret - Result.ok (List.Cons x0 tl01, List.Cons x1 tl11) - Result.ok (p, back1) - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 233:0-237:27 -/ @@ -380,56 +158,13 @@ def list_nth_mut_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × ((T × T) → Result ((List T) × (List T)))) := - list_nth_mut_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_shared_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 251:0-266: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 - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then Result.ok (x0, x1) - else - do - let i1 ← i - 1#u32 - list_nth_shared_loop_pair_merge_loop T tl0 tl1 i1 - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 251:0-255: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: - Source: 'tests/src/loops.rs', lines 269:0-284:1 -/ -divergent def list_nth_mut_shared_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : - Result ((T × T) × (T → Result (List T))) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then - let back := fun ret => Result.ok (List.Cons ret tl0) - Result.ok ((x0, x1), back) - else - do - let i1 ← i - 1#u32 - let (p, back) ← list_nth_mut_shared_loop_pair_loop T tl0 tl1 i1 - let back1 := - fun ret => do - let tl01 ← back ret - Result.ok (List.Cons x0 tl01) - Result.ok (p, back1) - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_mut_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 269:0-273:23 -/ @@ -437,33 +172,7 @@ def list_nth_mut_shared_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - list_nth_mut_shared_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 288:0-303:1 -/ -divergent def list_nth_mut_shared_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : - Result ((T × T) × (T → Result (List T))) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then - let back := fun ret => Result.ok (List.Cons ret tl0) - Result.ok ((x0, x1), back) - else - do - let i1 ← i - 1#u32 - let (p, back) ← list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i1 - let back1 := - fun ret => do - let tl01 ← back ret - Result.ok (List.Cons x0 tl01) - Result.ok (p, back1) - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_mut_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 288:0-292:23 -/ @@ -471,33 +180,7 @@ def list_nth_mut_shared_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i - -/- [loops::list_nth_shared_mut_loop_pair]: loop 0: - Source: 'tests/src/loops.rs', lines 307:0-322:1 -/ -divergent def list_nth_shared_mut_loop_pair_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : - Result ((T × T) × (T → Result (List T))) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then - let back := fun ret => Result.ok (List.Cons ret tl1) - Result.ok ((x0, x1), back) - else - do - let i1 ← i - 1#u32 - let (p, back) ← list_nth_shared_mut_loop_pair_loop T tl0 tl1 i1 - let back1 := - fun ret => do - let tl11 ← back ret - Result.ok (List.Cons x1 tl11) - Result.ok (p, back1) - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_shared_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 307:0-311:23 -/ @@ -505,33 +188,7 @@ def list_nth_shared_mut_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - list_nth_shared_mut_loop_pair_loop T ls0 ls1 i - -/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: - Source: 'tests/src/loops.rs', lines 326:0-341:1 -/ -divergent def list_nth_shared_mut_loop_pair_merge_loop - (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : - Result ((T × T) × (T → Result (List T))) - := - match ls0 with - | List.Cons x0 tl0 => - match ls1 with - | List.Cons x1 tl1 => - if i = 0#u32 - then - let back := fun ret => Result.ok (List.Cons ret tl1) - Result.ok ((x0, x1), back) - else - do - let i1 ← i - 1#u32 - let (p, back) ← list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i1 - let back1 := - fun ret => do - let tl11 ← back ret - Result.ok (List.Cons x1 tl11) - Result.ok (p, back1) - | List.Nil => Result.fail .panic - | List.Nil => Result.fail .panic + sorry /- [loops::list_nth_shared_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 326:0-330:23 -/ @@ -539,7 +196,7 @@ def list_nth_shared_mut_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i + sorry /- [loops::ignore_input_mut_borrow]: loop 0: Source: 'tests/src/loops.rs', lines 345:0-349:1 -/ -- cgit v1.2.3 From 9a860ae3ac5f0fdd4430ba39315456c0396e55e7 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Thu, 30 May 2024 13:01:06 +0200 Subject: More lisible sign for proj_right pretty-printing --- compiler/Print.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/Print.ml b/compiler/Print.ml index 12506274..9a3a7d16 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -152,7 +152,7 @@ module Values = struct match pm with | PNone -> s | PLeft -> "|" ^ s ^ "|" - | PRight -> "┊" ^ s ^ "┊" + | PRight -> "︙" ^ s ^ "︙" let rec typed_avalue_to_string ?(span : Meta.span option = None) (env : fmt_env) (v : typed_avalue) : string = -- cgit v1.2.3 From ad4cbc5d7d3d9f907cd12fc7bff480e61679043d Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Thu, 30 May 2024 13:39:18 +0200 Subject: Correct implementation of Join-MutBorrows: add markers when creating a new abstraction --- compiler/InterpreterLoopsMatchCtxs.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index be6f3ade..0ea832d7 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -666,14 +666,15 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct 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 = + let mk_aborrow (pm : proj_marker) (bid : borrow_id) (bv : typed_value) : + typed_avalue = let bv_ty = bv.ty in cassert __FILE__ __LINE__ (ty_no_regions bv_ty) span "Nested borrows are not supported yet"; - let value = ABorrow (AMutBorrow (PNone, bid, mk_aignored span bv_ty)) in + let value = ABorrow (AMutBorrow (pm, bid, mk_aignored span bv_ty)) in { value; ty = borrow_ty } in - let borrows = [ mk_aborrow bid0 bv0; mk_aborrow bid1 bv1 ] in + let borrows = [ mk_aborrow PLeft bid0 bv0; mk_aborrow PRight bid1 bv1 ] in let loan = AMutLoan (PNone, bid2, mk_aignored span bv_ty) in (* Note that an aloan has a borrow type *) -- cgit v1.2.3 From bdabf34385eb8949a4ca3e66be44d0067d57b159 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Thu, 30 May 2024 13:45:58 +0200 Subject: destructure_abs can be called during collapse: markers should be allowed --- compiler/InterpreterBorrows.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index e9be07aa..b4e45825 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1653,7 +1653,6 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) (* Explore the loan content *) match lc with | ASharedLoan (pm, bids, sv, child_av) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; (* We don't support nested borrows for now *) cassert __FILE__ __LINE__ (not (value_has_borrows ctx sv.value)) @@ -1676,7 +1675,6 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) signature) *) List.iter push avl | AMutLoan (pm, bid, child_av) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Explore the child *) list_avalues false push_fail child_av; (* Explore the whole loan *) @@ -1709,7 +1707,6 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) (* Explore the borrow content *) match bc with | AMutBorrow (pm, bid, child_av) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Explore the child *) list_avalues false push_fail child_av; (* Explore the borrow *) @@ -1717,7 +1714,6 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) let value = ABorrow (AMutBorrow (pm, bid, ignored)) in push { value; ty } | ASharedBorrow (pm, _) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Nothing specific to do: keep the value as it is *) push av | AIgnoredMutBorrow (opt_bid, child_av) -> -- cgit v1.2.3 From f03888772e8c983dcae8d6bc8b12ef6b896266a8 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 11:29:04 +0200 Subject: Also fix implementation of Join-SharedBorrow --- compiler/InterpreterLoopsMatchCtxs.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 0ea832d7..9b1d3dd0 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -516,11 +516,11 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct 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 = - let value = ABorrow (ASharedBorrow (PNone, bid)) in + let mk_aborrow (pm: proj_marker) (bid : borrow_id) : typed_avalue = + let value = ABorrow (ASharedBorrow (pm, bid)) in { value; ty = borrow_ty } in - let borrows = [ mk_aborrow bid0; mk_aborrow bid1 ] in + let borrows = [ mk_aborrow PLeft bid0; mk_aborrow PRight bid1 ] in let loan = ASharedLoan -- cgit v1.2.3 From 52bcaf0cdd1c08ece0f9f09bdc0d32b753a2a00f Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 11:55:51 +0200 Subject: Add markers when creating new abstractions because of a join with bottom --- compiler/InterpreterLoopsCore.ml | 44 ++++++++++++++++++++++++++++++ compiler/InterpreterLoopsJoinCtxs.ml | 51 +++-------------------------------- compiler/InterpreterLoopsMatchCtxs.ml | 16 ++++++++++- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index cd609ab0..8d6caac4 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -429,3 +429,47 @@ let ids_sets_empty_borrows_loans (ids : ids_sets) : ids_sets = } in ids + +(* Small utility: Add a projection marker to a typed avalue. + This can be used in combination with List.map to add markers to an entire abstraction +*) +let add_marker_avalue (span : Meta.span) (ctx : eval_ctx) (pm : proj_marker) + (av : typed_avalue) : typed_avalue = + let obj = + object + inherit [_] map_typed_avalue as super + + method! visit_borrow_content _ _ = + craise __FILE__ __LINE__ span "Unexpected borrow" + + method! visit_loan_content _ _ = + craise __FILE__ __LINE__ span "Unexpected loan" + + method! visit_symbolic_value _ sv = + sanity_check __FILE__ __LINE__ + (not (symbolic_value_has_borrows ctx sv)) + span; + sv + + method! visit_aloan_content env lc = + match lc with + | AMutLoan (pm0, bid, av) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aloan_content env (AMutLoan (pm, bid, av)) + | ASharedLoan (pm0, bids, av, child) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aloan_content env (ASharedLoan (pm, bids, av, child)) + | _ -> craise __FILE__ __LINE__ span "Unsupported yet" + + method! visit_aborrow_content env bc = + match bc with + | AMutBorrow (pm0, bid, av) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aborrow_content env (AMutBorrow (pm, bid, av)) + | ASharedBorrow (pm0, bid) -> + sanity_check __FILE__ __LINE__ (pm0 = PNone) span; + super#visit_aborrow_content env (ASharedBorrow (pm, bid)) + | _ -> craise __FILE__ __LINE__ span "Unsupported yet" + end + in + obj#visit_typed_avalue () av diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 1e099d96..2f2dba41 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -664,58 +664,15 @@ let join_ctxs (span : Meta.span) (loop_id : LoopId.id) (fixed_ids : ids_sets) craise __FILE__ __LINE__ span "Unreachable" in - (* Add a projection marker to a typed avalue *) - let add_marker_avalue (pm : proj_marker) (av : typed_avalue) : typed_avalue - = - let obj = - object - inherit [_] map_typed_avalue as super - - method! visit_borrow_content _ _ = - craise __FILE__ __LINE__ span "Unexpected borrow" - - method! visit_loan_content _ _ = - craise __FILE__ __LINE__ span "Unexpected loan" - - method! visit_symbolic_value _ sv = - (* While ctx0 and ctx1 are different, we assume that the type info context is - the same in both. Hence, we can use ctx0's types wlog *) - sanity_check __FILE__ __LINE__ - (not (symbolic_value_has_borrows ctx0 sv)) - span; - sv - - method! visit_aloan_content env lc = - match lc with - | AMutLoan (pm0, bid, av) -> - sanity_check __FILE__ __LINE__ (pm0 = PNone) span; - super#visit_aloan_content env (AMutLoan (pm, bid, av)) - | ASharedLoan (pm0, bids, av, child) -> - sanity_check __FILE__ __LINE__ (pm0 = PNone) span; - super#visit_aloan_content env - (ASharedLoan (pm, bids, av, child)) - | _ -> craise __FILE__ __LINE__ span "Unsupported yet" - - method! visit_aborrow_content env bc = - match bc with - | AMutBorrow (pm0, bid, av) -> - sanity_check __FILE__ __LINE__ (pm0 = PNone) span; - super#visit_aborrow_content env (AMutBorrow (pm, bid, av)) - | ASharedBorrow (pm0, bid) -> - sanity_check __FILE__ __LINE__ (pm0 = PNone) span; - super#visit_aborrow_content env (ASharedBorrow (pm, bid)) - | _ -> craise __FILE__ __LINE__ span "Unsupported yet" - end - in - obj#visit_typed_avalue () av - in - (* Add projection marker to all abstractions in the left and right environments *) let add_marker (pm : proj_marker) (ee : env_elem) : env_elem = match ee with | EAbs abs -> EAbs - { abs with avalues = List.map (add_marker_avalue pm) abs.avalues } + { + abs with + avalues = List.map (add_marker_avalue span ctx0 pm) abs.avalues; + } | x -> x in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 9b1d3dd0..713f462b 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -516,7 +516,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in (* Generate the avalues for the abstraction *) - let mk_aborrow (pm: proj_marker) (bid : borrow_id) : typed_avalue = + let mk_aborrow (pm : proj_marker) (bid : borrow_id) : typed_avalue = let value = ABorrow (ASharedBorrow (pm, bid)) in { value; ty = borrow_ty } in @@ -832,6 +832,20 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct convert_value_to_abstractions span abs_kind can_end destructure_shared_values ctx v in + (* Add a marker to the abstraction indicating the provenance of the value *) + let absl = + List.map + (fun abs -> + { + abs with + avalues = + List.map + (add_marker_avalue span ctx0 + (if value_is_left then PLeft else PRight)) + abs.avalues; + }) + absl + in push_absl absl; (* Return [Bottom] *) mk_bottom span v.ty -- cgit v1.2.3 From 1ee3d0f7d4f3c83351d5989c7979be3642069e63 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 13:08:08 +0200 Subject: Avoid adding shared loans twice when merging environments --- compiler/InterpreterBorrows.ml | 33 ++++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index b4e45825..d48635fc 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2494,6 +2494,10 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (* Phase 2: We now remove markers, by replacing pairs of the same element with left/right markers into one element with only one marker. To do so, we linearly traverse the abstraction created through the first phase *) + log#ldebug + (lazy + ("merge_into_abstraction_aux: starting phase 2\n- abs:\n" + ^ abs_to_string span ctx { abs0 with avalues = abs_values })); (* We first reset the list of avalues, and will construct avalues similarly to the previous phase *) avalues := []; @@ -2528,12 +2532,18 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | Abstract (ty, bc) -> { value = ABorrow bc; ty } in - (* Recreates an avalue from a loan_content *) + (* Recreates an avalue from a loan_content, and adds the set of loan ids as merged. + See the comment in the loop below for a detailed explanation *) let avalue_from_lc = function | Concrete (_, _) -> (* This can happen only in case of nested borrows, and should have been filtered during phase 1 *) craise __FILE__ __LINE__ span "Unreachable" - | Abstract (ty, bc) -> { value = ALoan bc; ty } + | Abstract (ty, bc) -> + (match bc with + | AMutLoan (_, id, _) -> set_loan_as_merged id + | ASharedLoan (_, ids, _, _) -> set_loans_as_merged ids + | _ -> craise __FILE__ __LINE__ span "Unreachable"); + { value = ALoan bc; ty } in (* Some utility functions *) @@ -2669,9 +2679,22 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) We merge their values, and push the result to the list of avalues. The merge will also remove the projection marker *) push_avalue (merge_g_borrow_contents bc0 bc1)) | LoanId (PNone, bid) -> - (* Same as BorrowId PNone above. We do not filter this element *) - let lc = MarkerBorrowId.Map.find (PNone, bid) loan_to_content in - push_avalue (avalue_from_lc lc) + (* Since we currently have a set of loan ids associated to a shared_borrow, we can + have several loan ids associated to the same element. Hence, we need to ensure + that we did not add the corresponding element previously. + + To do so, we use the loan id merged set for both marked and unmarked values. + The assumption is that we should not have the same loan id for both an unmarked + element and a marked element. It might better to sanity-check this. + + Adding the loan id to the merged set will be done inside avalue_from_lc. + + Rem: Once we move to a single loan id per shared_loan, this should not be needed anymore + *) + if loan_is_merged bid then () + else + let lc = MarkerBorrowId.Map.find (PNone, bid) loan_to_content in + push_avalue (avalue_from_lc lc) | LoanId (pm, bid) -> ( if (* Check if the loan has already been merged. If so, we skip it *) -- cgit v1.2.3 From 092dae81f5f90281b634e229102d2dff7f5c3fd7 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 13:09:37 +0200 Subject: Regenerate test output --- tests/coq/arrays/Arrays.v | 68 +++- tests/coq/demo/Demo.v | 27 +- tests/coq/hashmap/Hashmap_Funs.v | 198 ++++++++- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 205 +++++++++- tests/coq/misc/Loops.v | 446 ++++++++++++++++++++- tests/fstar/arrays/Arrays.Clauses.Template.fst | 19 + tests/fstar/arrays/Arrays.Funs.fst | 54 ++- tests/fstar/demo/Demo.fst | 24 +- tests/fstar/hashmap/Hashmap.Clauses.Template.fst | 56 +++ tests/fstar/hashmap/Hashmap.Funs.fst | 154 ++++++- .../HashmapMain.Clauses.Template.fst | 57 +++ tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 164 +++++++- tests/fstar/misc/Loops.Clauses.Template.fst | 105 +++++ tests/fstar/misc/Loops.Funs.fst | 364 ++++++++++++++++- tests/lean/Arrays.lean | 53 ++- tests/lean/Demo/Demo.lean | 25 +- tests/lean/Hashmap/Funs.lean | 148 ++++++- tests/lean/HashmapMain/Funs.lean | 154 ++++++- tests/lean/Loops.lean | 375 ++++++++++++++++- 19 files changed, 2588 insertions(+), 108 deletions(-) diff --git a/tests/coq/arrays/Arrays.v b/tests/coq/arrays/Arrays.v index b7bef7c7..35dea58c 100644 --- a/tests/coq/arrays/Arrays.v +++ b/tests/coq/arrays/Arrays.v @@ -375,15 +375,58 @@ Definition non_copyable_array : result unit := take_array_t (mk_array AB_t 2%usize [ AB_A; AB_B ]) . +(** [arrays::sum]: loop 0: + Source: 'tests/src/arrays.rs', lines 242:0-250:1 *) +Fixpoint sum_loop + (n : nat) (s : slice u32) (sum1 : u32) (i : usize) : result u32 := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := slice_len u32 s in + if i s< i1 + then ( + i2 <- slice_index_usize u32 s i; + sum3 <- u32_add sum1 i2; + i3 <- usize_add i 1%usize; + sum_loop n1 s sum3 i3) + else Ok sum1 + end +. + (** [arrays::sum]: Source: 'tests/src/arrays.rs', lines 242:0-242:28 *) Definition sum (n : nat) (s : slice u32) : result u32 := - admit. + sum_loop n s 0%u32 0%usize +. + +(** [arrays::sum2]: loop 0: + Source: 'tests/src/arrays.rs', lines 252:0-261:1 *) +Fixpoint sum2_loop + (n : nat) (s : slice u32) (s2 : slice u32) (sum1 : u32) (i : usize) : + result u32 + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := slice_len u32 s in + if i s< i1 + then ( + i2 <- slice_index_usize u32 s i; + i3 <- slice_index_usize u32 s2 i; + i4 <- u32_add i2 i3; + sum3 <- u32_add sum1 i4; + i5 <- usize_add i 1%usize; + sum2_loop n1 s s2 sum3 i5) + else Ok sum1 + end +. (** [arrays::sum2]: Source: 'tests/src/arrays.rs', lines 252:0-252:41 *) Definition sum2 (n : nat) (s : slice u32) (s2 : slice u32) : result u32 := - admit + let i := slice_len u32 s in + let i1 := slice_len u32 s2 in + if negb (i s= i1) then Fail_ Failure else sum2_loop n s s2 0%u32 0%usize . (** [arrays::f0]: @@ -464,10 +507,29 @@ Definition ite : result unit := Ok tt . +(** [arrays::zero_slice]: loop 0: + Source: 'tests/src/arrays.rs', lines 303:0-310:1 *) +Fixpoint zero_slice_loop + (n : nat) (a : slice u8) (i : usize) (len : usize) : result (slice u8) := + match n with + | O => Fail_ OutOfFuel + | S n1 => + if i s< len + then ( + p <- slice_index_mut_usize u8 a i; + let (_, index_mut_back) := p in + i1 <- usize_add i 1%usize; + a1 <- index_mut_back 0%u8; + zero_slice_loop n1 a1 i1 len) + else Ok a + end +. + (** [arrays::zero_slice]: Source: 'tests/src/arrays.rs', lines 303:0-303:31 *) Definition zero_slice (n : nat) (a : slice u8) : result (slice u8) := - admit. + let len := slice_len u8 a in zero_slice_loop n a 0%usize len +. (** [arrays::iter_mut_slice]: loop 0: Source: 'tests/src/arrays.rs', lines 312:0-318:1 *) diff --git a/tests/coq/demo/Demo.v b/tests/coq/demo/Demo.v index 14b1ca9d..8d8f840d 100644 --- a/tests/coq/demo/Demo.v +++ b/tests/coq/demo/Demo.v @@ -90,13 +90,38 @@ Fixpoint list_nth_mut end . +(** [demo::list_nth_mut1]: loop 0: + Source: 'tests/src/demo.rs', lines 69:0-78:1 *) +Fixpoint list_nth_mut1_loop + (T : Type) (n : nat) (l : CList_t T) (i : u32) : + result (T * (T -> result (CList_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match l with + | CList_CCons x tl => + if i s= 0%u32 + then let back := fun (ret : T) => Ok (CList_CCons ret tl) in Ok (x, back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_mut1_loop T n1 tl i1; + let (t, back) := p in + let back1 := fun (ret : T) => tl1 <- back ret; Ok (CList_CCons x tl1) + in + Ok (t, back1)) + | CList_CNil => Fail_ Failure + end + end +. + (** [demo::list_nth_mut1]: Source: 'tests/src/demo.rs', lines 69:0-69:77 *) Definition list_nth_mut1 (T : Type) (n : nat) (l : CList_t T) (i : u32) : result (T * (T -> result (CList_t T))) := - admit + list_nth_mut1_loop T n l i . (** [demo::i32_id]: diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index b5c2bff0..6a4f8e99 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -67,11 +67,41 @@ 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: + Source: 'tests/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)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := alloc_vec_Vec_len (List_t T) slots in + if i s< i1 + then ( + p <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i; + let (_, index_mut_back) := p in + i2 <- usize_add i 1%usize; + slots1 <- index_mut_back List_Nil; + hashMap_clear_loop T n1 slots1 i2) + else Ok slots + end +. + (** [hashmap::{hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 *) Definition hashMap_clear (T : Type) (n : nat) (self : HashMap_t T) : result (HashMap_t T) := - admit + hm <- hashMap_clear_loop T n self.(hashMap_slots) 0%usize; + Ok + {| + hashMap_num_entries := 0%usize; + hashMap_max_load_factor := self.(hashMap_max_load_factor); + hashMap_max_load := self.(hashMap_max_load); + hashMap_slots := hm + |} . (** [hashmap::{hashmap::HashMap}::len]: @@ -80,13 +110,35 @@ Definition hashMap_len (T : Type) (self : HashMap_t T) : result usize := Ok self.(hashMap_num_entries) . +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: + Source: 'tests/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 * (List_t T)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons ckey cvalue tl => + if ckey s= key + then Ok (false, List_Cons ckey value tl) + else ( + p <- hashMap_insert_in_list_loop T n1 key value tl; + let (b, tl1) := p in + Ok (b, List_Cons ckey cvalue tl1)) + | List_Nil => Ok (true, List_Cons key value List_Nil) + end + end +. + (** [hashmap::{hashmap::HashMap}::insert_in_list]: Source: 'tests/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 * (List_t T)) := - admit + hashMap_insert_in_list_loop T n key value ls . (** [hashmap::{hashmap::HashMap}::insert_no_resize]: @@ -127,13 +179,57 @@ Definition hashMap_insert_no_resize |}) . +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: + Source: 'tests/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) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons k v tl => + ntable1 <- hashMap_insert_no_resize T n1 ntable k v; + hashMap_move_elements_from_list_loop T n1 ntable1 tl + | List_Nil => Ok ntable + end + end +. + (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - admit + hashMap_move_elements_from_list_loop T n ntable ls +. + +(** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: + Source: 'tests/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) : + result ((alloc_vec_Vec (List_t T)) * (HashMap_t T)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := alloc_vec_Vec_len (List_t T) slots in + if i s< i1 + then ( + p <- + alloc_vec_Vec_index_mut (List_t T) usize + (core_slice_index_SliceIndexUsizeSliceTInst (List_t T)) slots i; + let (l, index_mut_back) := p in + let (ls, l1) := core_mem_replace (List_t T) l List_Nil in + ntable1 <- hashMap_move_elements_from_list T n1 ntable ls; + i2 <- usize_add i 1%usize; + slots1 <- index_mut_back l1; + hashMap_move_elements_loop T n1 ntable1 slots1 i2) + else Ok (ntable, slots) + end . (** [hashmap::{hashmap::HashMap}::move_elements]: @@ -143,7 +239,7 @@ Definition hashMap_move_elements (slots : alloc_vec_Vec (List_t T)) (i : usize) : result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := - admit + hashMap_move_elements_loop T n ntable slots i . (** [hashmap::{hashmap::HashMap}::try_resize]: @@ -191,11 +287,28 @@ Definition hashMap_insert else Ok self1 . +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: + Source: 'tests/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 + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons ckey _ tl => + if ckey s= key + then Ok true + else hashMap_contains_key_in_list_loop T n1 key tl + | List_Nil => Ok false + end + end +. + (** [hashmap::{hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 := - admit + hashMap_contains_key_in_list_loop T n key ls . (** [hashmap::{hashmap::HashMap}::contains_key]: @@ -212,11 +325,26 @@ Definition hashMap_contains_key hashMap_contains_key_in_list T n key l . +(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: + Source: 'tests/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 + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons ckey cvalue tl => + if ckey s= key then Ok cvalue else hashMap_get_in_list_loop T n1 key tl + | List_Nil => Fail_ Failure + end + end +. + (** [hashmap::{hashmap::HashMap}::get_in_list]: Source: 'tests/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 := - admit + hashMap_get_in_list_loop T n key ls . (** [hashmap::{hashmap::HashMap}::get]: @@ -233,13 +361,39 @@ Definition hashMap_get hashMap_get_in_list T n key l . +(** [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: + Source: 'tests/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 * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons ckey cvalue tl => + if ckey s= key + then + let back := fun (ret : T) => Ok (List_Cons ckey ret tl) in + Ok (cvalue, back) + else ( + p <- hashMap_get_mut_in_list_loop T n1 tl key; + let (t, back) := p in + let back1 := + fun (ret : T) => tl1 <- back ret; Ok (List_Cons ckey cvalue tl1) in + Ok (t, back1)) + | List_Nil => Fail_ Failure + end + end +. + (** [hashmap::{hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 * (T -> result (List_t T))) := - admit + hashMap_get_mut_in_list_loop T n ls key . (** [hashmap::{hashmap::HashMap}::get_mut]: @@ -272,13 +426,41 @@ Definition hashMap_get_mut Ok (t, back) . +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: + Source: 'tests/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) * (List_t T)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons ckey t tl => + if ckey s= key + then + let (mv_ls, _) := + core_mem_replace (List_t T) (List_Cons ckey t tl) List_Nil in + match mv_ls with + | List_Cons _ cvalue tl1 => Ok (Some cvalue, tl1) + | List_Nil => Fail_ Failure + end + else ( + p <- hashMap_remove_from_list_loop T n1 key tl; + let (o, tl1) := p in + Ok (o, List_Cons ckey t tl1)) + | List_Nil => Ok (None, List_Nil) + end + end +. + (** [hashmap::{hashmap::HashMap}::remove_from_list]: Source: 'tests/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) * (List_t T)) := - admit + hashMap_remove_from_list_loop T n key ls . (** [hashmap::{hashmap::HashMap}::remove]: diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index e37b111c..fd7f7f16 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -74,13 +74,44 @@ Definition hashmap_HashMap_new hashmap_HashMap_new_with_capacity T n 32%usize 4%usize 5%usize . +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: loop 0: + Source: 'tests/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)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := alloc_vec_Vec_len (hashmap_List_t T) slots in + if i s< i1 + then ( + p <- + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots + i; + let (_, index_mut_back) := p in + i2 <- usize_add i 1%usize; + slots1 <- index_mut_back Hashmap_List_Nil; + hashmap_HashMap_clear_loop T n1 slots1 i2) + else Ok slots + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: Source: 'tests/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) := - admit + hm <- hashmap_HashMap_clear_loop T n self.(hashmap_HashMap_slots) 0%usize; + Ok + {| + 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 := hm + |} . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: @@ -90,13 +121,36 @@ Definition hashmap_HashMap_len Ok self.(hashmap_HashMap_num_entries) . +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: + Source: 'tests/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 * (hashmap_List_t T)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | Hashmap_List_Cons ckey cvalue tl => + if ckey s= key + then Ok (false, Hashmap_List_Cons ckey value tl) + else ( + p <- hashmap_HashMap_insert_in_list_loop T n1 key value tl; + let (b, tl1) := p in + Ok (b, Hashmap_List_Cons ckey cvalue tl1)) + | Hashmap_List_Nil => + Ok (true, Hashmap_List_Cons key value Hashmap_List_Nil) + end + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: Source: 'tests/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 * (hashmap_List_t T)) := - admit + hashmap_HashMap_insert_in_list_loop T n key value ls . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: @@ -139,13 +193,58 @@ Definition hashmap_HashMap_insert_no_resize |}) . +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: + Source: 'tests/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) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | Hashmap_List_Cons k v tl => + ntable1 <- hashmap_HashMap_insert_no_resize T n1 ntable k v; + hashmap_HashMap_move_elements_from_list_loop T n1 ntable1 tl + | Hashmap_List_Nil => Ok ntable + end + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - admit + hashmap_HashMap_move_elements_from_list_loop T n ntable ls +. + +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: + Source: 'tests/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) : + result ((alloc_vec_Vec (hashmap_List_t T)) * (hashmap_HashMap_t T)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := alloc_vec_Vec_len (hashmap_List_t T) slots in + if i s< i1 + then ( + p <- + alloc_vec_Vec_index_mut (hashmap_List_t T) usize + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t T)) slots + i; + let (l, index_mut_back) := p in + let (ls, l1) := core_mem_replace (hashmap_List_t T) l Hashmap_List_Nil in + ntable1 <- hashmap_HashMap_move_elements_from_list T n1 ntable ls; + i2 <- usize_add i 1%usize; + slots1 <- index_mut_back l1; + hashmap_HashMap_move_elements_loop T n1 ntable1 slots1 i2) + else Ok (ntable, slots) + end . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: @@ -155,7 +254,7 @@ Definition hashmap_HashMap_move_elements (slots : alloc_vec_Vec (hashmap_List_t T)) (i : usize) : result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := - admit + hashmap_HashMap_move_elements_loop T n ntable slots i . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: @@ -208,11 +307,28 @@ Definition hashmap_HashMap_insert else Ok self1 . +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: + Source: 'tests/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 + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | Hashmap_List_Cons ckey _ tl => + if ckey s= key + then Ok true + else hashmap_HashMap_contains_key_in_list_loop T n1 key tl + | Hashmap_List_Nil => Ok false + end + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 := - admit + hashmap_HashMap_contains_key_in_list_loop T n key ls . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: @@ -231,11 +347,28 @@ 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: + Source: 'tests/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 + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | Hashmap_List_Cons ckey cvalue tl => + if ckey s= key + then Ok cvalue + else hashmap_HashMap_get_in_list_loop T n1 key tl + | Hashmap_List_Nil => Fail_ Failure + end + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: Source: 'tests/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 := - admit + hashmap_HashMap_get_in_list_loop T n key ls . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: @@ -252,13 +385,40 @@ 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: + Source: 'tests/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 * (T -> result (hashmap_List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | Hashmap_List_Cons ckey cvalue tl => + if ckey s= key + then + let back := fun (ret : T) => Ok (Hashmap_List_Cons ckey ret tl) in + Ok (cvalue, back) + else ( + p <- hashmap_HashMap_get_mut_in_list_loop T n1 tl key; + let (t, back) := p in + let back1 := + fun (ret : T) => + tl1 <- back ret; Ok (Hashmap_List_Cons ckey cvalue tl1) in + Ok (t, back1)) + | Hashmap_List_Nil => Fail_ Failure + end + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 * (T -> result (hashmap_List_t T))) := - admit + hashmap_HashMap_get_mut_in_list_loop T n ls key . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: @@ -292,13 +452,42 @@ Definition hashmap_HashMap_get_mut Ok (t, back) . +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: + Source: 'tests/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) * (hashmap_List_t T)) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | Hashmap_List_Cons ckey t tl => + if ckey s= key + then + let (mv_ls, _) := + core_mem_replace (hashmap_List_t T) (Hashmap_List_Cons ckey t tl) + Hashmap_List_Nil in + match mv_ls with + | Hashmap_List_Cons _ cvalue tl1 => Ok (Some cvalue, tl1) + | Hashmap_List_Nil => Fail_ Failure + end + else ( + p <- hashmap_HashMap_remove_from_list_loop T n1 key tl; + let (o, tl1) := p in + Ok (o, Hashmap_List_Cons ckey t tl1)) + | Hashmap_List_Nil => Ok (None, Hashmap_List_Nil) + end + end +. + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: Source: 'tests/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) * (hashmap_List_t T)) := - admit + hashmap_HashMap_remove_from_list_loop T n key ls . (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: diff --git a/tests/coq/misc/Loops.v b/tests/coq/misc/Loops.v index bd2b287b..bf0a8bc1 100644 --- a/tests/coq/misc/Loops.v +++ b/tests/coq/misc/Loops.v @@ -93,11 +93,32 @@ Definition sum_array (N : usize) (n : nat) (a : array u32 N) : result u32 := sum_array_loop N n a 0%usize 0%u32 . +(** [loops::clear]: loop 0: + Source: 'tests/src/loops.rs', lines 62:0-68:1 *) +Fixpoint clear_loop + (n : nat) (v : alloc_vec_Vec u32) (i : usize) : result (alloc_vec_Vec u32) := + match n with + | O => Fail_ OutOfFuel + | S n1 => + let i1 := alloc_vec_Vec_len u32 v in + if i s< i1 + then ( + p <- + alloc_vec_Vec_index_mut u32 usize + (core_slice_index_SliceIndexUsizeSliceTInst u32) v i; + let (_, index_mut_back) := p in + i2 <- usize_add i 1%usize; + v1 <- index_mut_back 0%u32; + clear_loop n1 v1 i2) + else Ok v + end +. + (** [loops::clear]: Source: 'tests/src/loops.rs', lines 62:0-62:30 *) Definition clear (n : nat) (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) := - admit + clear_loop n v 0%usize . (** [loops::List] @@ -110,10 +131,47 @@ Inductive List_t (T : Type) := Arguments List_Cons { _ }. Arguments List_Nil { _ }. +(** [loops::list_mem]: loop 0: + Source: 'tests/src/loops.rs', lines 76:0-85:1 *) +Fixpoint list_mem_loop (n : nat) (x : u32) (ls : List_t u32) : result bool := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons y tl => if y s= x then Ok true else list_mem_loop n1 x tl + | List_Nil => Ok false + end + end +. + (** [loops::list_mem]: Source: 'tests/src/loops.rs', lines 76:0-76:52 *) Definition list_mem (n : nat) (x : u32) (ls : List_t u32) : result bool := - admit + list_mem_loop n x ls +. + +(** [loops::list_nth_mut_loop]: loop 0: + Source: 'tests/src/loops.rs', lines 88:0-98:1 *) +Fixpoint list_nth_mut_loop_loop + (T : Type) (n : nat) (ls : List_t T) (i : u32) : + result (T * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons x tl => + if i s= 0%u32 + then let back := fun (ret : T) => Ok (List_Cons ret tl) in Ok (x, back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_mut_loop_loop T n1 tl i1; + let (t, back) := p in + let back1 := fun (ret : T) => tl1 <- back ret; Ok (List_Cons x tl1) in + Ok (t, back1)) + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_mut_loop]: @@ -122,14 +180,56 @@ Definition list_nth_mut_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result (T * (T -> result (List_t T))) := - admit + list_nth_mut_loop_loop T n ls i +. + +(** [loops::list_nth_shared_loop]: loop 0: + Source: 'tests/src/loops.rs', lines 101:0-111:1 *) +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 n1 => + match ls with + | List_Cons x tl => + if i s= 0%u32 + then Ok x + else (i1 <- u32_sub i 1%u32; list_nth_shared_loop_loop T n1 tl i1) + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_shared_loop]: Source: 'tests/src/loops.rs', lines 101:0-101:66 *) Definition list_nth_shared_loop (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - admit + list_nth_shared_loop_loop T n ls i +. + +(** [loops::get_elem_mut]: loop 0: + Source: 'tests/src/loops.rs', lines 113:0-127:1 *) +Fixpoint get_elem_mut_loop + (n : nat) (x : usize) (ls : List_t usize) : + result (usize * (usize -> result (List_t usize))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons y tl => + if y s= x + then + let back := fun (ret : usize) => Ok (List_Cons ret tl) in Ok (y, back) + else ( + p <- get_elem_mut_loop n1 x tl; + let (i, back) := p in + let back1 := fun (ret : usize) => tl1 <- back ret; Ok (List_Cons y tl1) + in + Ok (i, back1)) + | List_Nil => Fail_ Failure + end + end . (** [loops::get_elem_mut]: @@ -138,7 +238,28 @@ Definition get_elem_mut (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : result (usize * (usize -> result (alloc_vec_Vec (List_t usize)))) := - admit + p <- + alloc_vec_Vec_index_mut (List_t usize) usize + (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; + let (ls, index_mut_back) := p in + p1 <- get_elem_mut_loop n x ls; + let (i, back) := p1 in + let back1 := fun (ret : usize) => l <- back ret; index_mut_back l in + Ok (i, back1) +. + +(** [loops::get_elem_shared]: loop 0: + Source: 'tests/src/loops.rs', lines 129:0-143:1 *) +Fixpoint get_elem_shared_loop + (n : nat) (x : usize) (ls : List_t usize) : result usize := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons y tl => if y s= x then Ok y else get_elem_shared_loop n1 x tl + | List_Nil => Fail_ Failure + end + end . (** [loops::get_elem_shared]: @@ -147,7 +268,10 @@ Definition get_elem_shared (n : nat) (slots : alloc_vec_Vec (List_t usize)) (x : usize) : result usize := - admit + ls <- + alloc_vec_Vec_index (List_t usize) usize + (core_slice_index_SliceIndexUsizeSliceTInst (List_t usize)) slots 0%usize; + get_elem_shared_loop n x ls . (** [loops::id_mut]: @@ -164,20 +288,101 @@ Definition id_mut Definition id_shared (T : Type) (ls : List_t T) : result (List_t T) := Ok ls. +(** [loops::list_nth_mut_loop_with_id]: loop 0: + Source: 'tests/src/loops.rs', lines 154:0-165:1 *) +Fixpoint list_nth_mut_loop_with_id_loop + (T : Type) (n : nat) (i : u32) (ls : List_t T) : + result (T * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls with + | List_Cons x tl => + if i s= 0%u32 + then let back := fun (ret : T) => Ok (List_Cons ret tl) in Ok (x, back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_mut_loop_with_id_loop T n1 i1 tl; + let (t, back) := p in + let back1 := fun (ret : T) => tl1 <- back ret; Ok (List_Cons x tl1) in + Ok (t, back1)) + | List_Nil => Fail_ Failure + end + end +. + (** [loops::list_nth_mut_loop_with_id]: Source: 'tests/src/loops.rs', lines 154:0-154:75 *) Definition list_nth_mut_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result (T * (T -> result (List_t T))) := - admit + p <- id_mut T ls; + let (ls1, id_mut_back) := p in + p1 <- list_nth_mut_loop_with_id_loop T n i ls1; + let (t, back) := p1 in + let back1 := fun (ret : T) => l <- back ret; id_mut_back l in + Ok (t, back1) +. + +(** [loops::list_nth_shared_loop_with_id]: loop 0: + Source: 'tests/src/loops.rs', lines 168:0-179:1 *) +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 n1 => + match ls with + | List_Cons x tl => + if i s= 0%u32 + then Ok x + else ( + i1 <- u32_sub i 1%u32; list_nth_shared_loop_with_id_loop T n1 i1 tl) + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_shared_loop_with_id]: Source: 'tests/src/loops.rs', lines 168:0-168:70 *) Definition list_nth_shared_loop_with_id (T : Type) (n : nat) (ls : List_t T) (i : u32) : result T := - admit + ls1 <- id_shared T ls; list_nth_shared_loop_with_id_loop T n i ls1 +. + +(** [loops::list_nth_mut_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 184:0-205: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) * (T -> result (List_t T)) * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then + let back'a := fun (ret : T) => Ok (List_Cons ret tl0) in + let back'b := fun (ret : T) => Ok (List_Cons ret tl1) in + Ok ((x0, x1), back'a, back'b) + else ( + i1 <- u32_sub i 1%u32; + t <- list_nth_mut_loop_pair_loop T n1 tl0 tl1 i1; + let '(p, back'a, back'b) := t in + let back'a1 := + fun (ret : T) => tl01 <- back'a ret; Ok (List_Cons x0 tl01) in + let back'b1 := + fun (ret : T) => tl11 <- back'b ret; Ok (List_Cons x1 tl11) in + Ok (p, back'a1, back'b1)) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_mut_loop_pair]: @@ -186,7 +391,31 @@ Definition list_nth_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * (T -> result (List_t T)) * (T -> result (List_t T))) := - admit + list_nth_mut_loop_pair_loop T n ls0 ls1 i +. + +(** [loops::list_nth_shared_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 208:0-229: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) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then Ok (x0, x1) + else ( + i1 <- u32_sub i 1%u32; list_nth_shared_loop_pair_loop T n1 tl0 tl1 i1) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_shared_loop_pair]: @@ -195,7 +424,43 @@ Definition list_nth_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - admit + list_nth_shared_loop_pair_loop T n ls0 ls1 i +. + +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 233:0-248: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) * ((T * T) -> result ((List_t T) * (List_t T)))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then + let back := + fun (ret : (T * T)) => + let (t, t1) := ret in Ok (List_Cons t tl0, List_Cons t1 tl1) in + Ok ((x0, x1), back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_mut_loop_pair_merge_loop T n1 tl0 tl1 i1; + let (p1, back) := p in + let back1 := + fun (ret : (T * T)) => + p2 <- back ret; + let (tl01, tl11) := p2 in + Ok (List_Cons x0 tl01, List_Cons x1 tl11) in + Ok (p1, back1)) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_mut_loop_pair_merge]: @@ -204,7 +469,32 @@ Definition list_nth_mut_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * ((T * T) -> result ((List_t T) * (List_t T)))) := - admit + list_nth_mut_loop_pair_merge_loop T n ls0 ls1 i +. + +(** [loops::list_nth_shared_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 251:0-266: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) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then Ok (x0, x1) + else ( + i1 <- u32_sub i 1%u32; + list_nth_shared_loop_pair_merge_loop T n1 tl0 tl1 i1) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_shared_loop_pair_merge]: @@ -213,7 +503,38 @@ Definition list_nth_shared_loop_pair_merge (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result (T * T) := - admit + list_nth_shared_loop_pair_merge_loop T n ls0 ls1 i +. + +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 269:0-284: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) * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then + let back := fun (ret : T) => Ok (List_Cons ret tl0) in + Ok ((x0, x1), back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_mut_shared_loop_pair_loop T n1 tl0 tl1 i1; + let (p1, back) := p in + let back1 := + fun (ret : T) => tl01 <- back ret; Ok (List_Cons x0 tl01) in + Ok (p1, back1)) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_mut_shared_loop_pair]: @@ -222,7 +543,38 @@ Definition list_nth_mut_shared_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * (T -> result (List_t T))) := - admit + list_nth_mut_shared_loop_pair_loop T n ls0 ls1 i +. + +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 288:0-303: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) * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then + let back := fun (ret : T) => Ok (List_Cons ret tl0) in + Ok ((x0, x1), back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_mut_shared_loop_pair_merge_loop T n1 tl0 tl1 i1; + let (p1, back) := p in + let back1 := + fun (ret : T) => tl01 <- back ret; Ok (List_Cons x0 tl01) in + Ok (p1, back1)) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_mut_shared_loop_pair_merge]: @@ -231,7 +583,38 @@ 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) * (T -> result (List_t T))) := - admit + list_nth_mut_shared_loop_pair_merge_loop T n ls0 ls1 i +. + +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 307:0-322: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) * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then + let back := fun (ret : T) => Ok (List_Cons ret tl1) in + Ok ((x0, x1), back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_shared_mut_loop_pair_loop T n1 tl0 tl1 i1; + let (p1, back) := p in + let back1 := + fun (ret : T) => tl11 <- back ret; Ok (List_Cons x1 tl11) in + Ok (p1, back1)) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_shared_mut_loop_pair]: @@ -240,7 +623,38 @@ Definition list_nth_shared_mut_loop_pair (T : Type) (n : nat) (ls0 : List_t T) (ls1 : List_t T) (i : u32) : result ((T * T) * (T -> result (List_t T))) := - admit + list_nth_shared_mut_loop_pair_loop T n ls0 ls1 i +. + +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 326:0-341: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) * (T -> result (List_t T))) + := + match n with + | O => Fail_ OutOfFuel + | S n1 => + match ls0 with + | List_Cons x0 tl0 => + match ls1 with + | List_Cons x1 tl1 => + if i s= 0%u32 + then + let back := fun (ret : T) => Ok (List_Cons ret tl1) in + Ok ((x0, x1), back) + else ( + i1 <- u32_sub i 1%u32; + p <- list_nth_shared_mut_loop_pair_merge_loop T n1 tl0 tl1 i1; + let (p1, back) := p in + let back1 := + fun (ret : T) => tl11 <- back ret; Ok (List_Cons x1 tl11) in + Ok (p1, back1)) + | List_Nil => Fail_ Failure + end + | List_Nil => Fail_ Failure + end + end . (** [loops::list_nth_shared_mut_loop_pair_merge]: @@ -249,7 +663,7 @@ 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) * (T -> result (List_t T))) := - admit + list_nth_shared_mut_loop_pair_merge_loop T n ls0 ls1 i . (** [loops::ignore_input_mut_borrow]: loop 0: diff --git a/tests/fstar/arrays/Arrays.Clauses.Template.fst b/tests/fstar/arrays/Arrays.Clauses.Template.fst index c189e41e..e695b89b 100644 --- a/tests/fstar/arrays/Arrays.Clauses.Template.fst +++ b/tests/fstar/arrays/Arrays.Clauses.Template.fst @@ -6,6 +6,25 @@ open Arrays.Types #set-options "--z3rlimit 50 --fuel 1 --ifuel 1" +(** [arrays::sum]: decreases clause + Source: 'tests/src/arrays.rs', lines 242:0-250:1 *) +unfold +let sum_loop_decreases (s : slice u32) (sum1 : u32) (i : usize) : nat = + admit () + +(** [arrays::sum2]: decreases clause + Source: 'tests/src/arrays.rs', lines 252:0-261:1 *) +unfold +let sum2_loop_decreases (s : slice u32) (s2 : slice u32) (sum1 : u32) + (i : usize) : nat = + admit () + +(** [arrays::zero_slice]: decreases clause + Source: 'tests/src/arrays.rs', lines 303:0-310:1 *) +unfold +let zero_slice_loop_decreases (a : slice u8) (i : usize) (len : usize) : nat = + admit () + (** [arrays::iter_mut_slice]: decreases clause Source: 'tests/src/arrays.rs', lines 312:0-318:1 *) unfold diff --git a/tests/fstar/arrays/Arrays.Funs.fst b/tests/fstar/arrays/Arrays.Funs.fst index f77b9c40..6196e3b7 100644 --- a/tests/fstar/arrays/Arrays.Funs.fst +++ b/tests/fstar/arrays/Arrays.Funs.fst @@ -306,15 +306,49 @@ let take_array_t (a : array aB_t 2) : result unit = let non_copyable_array : result unit = take_array_t (mk_array aB_t 2 [ AB_A; AB_B ]) +(** [arrays::sum]: loop 0: + Source: 'tests/src/arrays.rs', lines 242:0-250:1 *) +let rec sum_loop + (s : slice u32) (sum1 : u32) (i : usize) : + Tot (result u32) (decreases (sum_loop_decreases s sum1 i)) + = + let i1 = slice_len u32 s in + if i < i1 + then + let* i2 = slice_index_usize u32 s i in + let* sum3 = u32_add sum1 i2 in + let* i3 = usize_add i 1 in + sum_loop s sum3 i3 + else Ok sum1 + (** [arrays::sum]: Source: 'tests/src/arrays.rs', lines 242:0-242:28 *) let sum (s : slice u32) : result u32 = - admit + sum_loop s 0 0 + +(** [arrays::sum2]: loop 0: + Source: 'tests/src/arrays.rs', lines 252:0-261:1 *) +let rec sum2_loop + (s : slice u32) (s2 : slice u32) (sum1 : u32) (i : usize) : + Tot (result u32) (decreases (sum2_loop_decreases s s2 sum1 i)) + = + let i1 = slice_len u32 s in + if i < i1 + then + let* i2 = slice_index_usize u32 s i in + let* i3 = slice_index_usize u32 s2 i in + let* i4 = u32_add i2 i3 in + let* sum3 = u32_add sum1 i4 in + let* i5 = usize_add i 1 in + sum2_loop s s2 sum3 i5 + else Ok sum1 (** [arrays::sum2]: Source: 'tests/src/arrays.rs', lines 252:0-252:41 *) let sum2 (s : slice u32) (s2 : slice u32) : result u32 = - admit + let i = slice_len u32 s in + let i1 = slice_len u32 s2 in + if not (i = i1) then Fail Failure else sum2_loop s s2 0 0 (** [arrays::f0]: Source: 'tests/src/arrays.rs', lines 263:0-263:11 *) @@ -380,10 +414,24 @@ let ite : result unit = let* _ = to_slice_mut_back s1 in Ok () +(** [arrays::zero_slice]: loop 0: + Source: 'tests/src/arrays.rs', lines 303:0-310:1 *) +let rec zero_slice_loop + (a : slice u8) (i : usize) (len : usize) : + Tot (result (slice u8)) (decreases (zero_slice_loop_decreases a i len)) + = + if i < len + then + let* (_, index_mut_back) = slice_index_mut_usize u8 a i in + let* i1 = usize_add i 1 in + let* a1 = index_mut_back 0 in + zero_slice_loop a1 i1 len + else Ok a + (** [arrays::zero_slice]: Source: 'tests/src/arrays.rs', lines 303:0-303:31 *) let zero_slice (a : slice u8) : result (slice u8) = - admit + let len = slice_len u8 a in zero_slice_loop a 0 len (** [arrays::iter_mut_slice]: loop 0: Source: 'tests/src/arrays.rs', lines 312:0-318:1 *) diff --git a/tests/fstar/demo/Demo.fst b/tests/fstar/demo/Demo.fst index c78dab8e..41fd9804 100644 --- a/tests/fstar/demo/Demo.fst +++ b/tests/fstar/demo/Demo.fst @@ -76,13 +76,35 @@ let rec list_nth_mut | CList_CNil -> Fail Failure end +(** [demo::list_nth_mut1]: loop 0: + Source: 'tests/src/demo.rs', lines 69:0-78:1 *) +let rec list_nth_mut1_loop + (t : Type0) (n : nat) (l : cList_t t) (i : u32) : + result (t & (t -> result (cList_t t))) + = + if is_zero n + then Fail OutOfFuel + else + let n1 = decrease n in + begin match l with + | CList_CCons x tl -> + if i = 0 + then let back = fun ret -> Ok (CList_CCons ret tl) in Ok (x, back) + else + let* i1 = u32_sub i 1 in + let* (x1, back) = list_nth_mut1_loop t n1 tl i1 in + let back1 = fun ret -> let* tl1 = back ret in Ok (CList_CCons x tl1) in + Ok (x1, back1) + | CList_CNil -> Fail Failure + end + (** [demo::list_nth_mut1]: Source: 'tests/src/demo.rs', lines 69:0-69:77 *) let list_nth_mut1 (t : Type0) (n : nat) (l : cList_t t) (i : u32) : result (t & (t -> result (cList_t t))) = - admit + list_nth_mut1_loop t n l i (** [demo::i32_id]: Source: 'tests/src/demo.rs', lines 80:0-80:28 *) diff --git a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst index 5effb67a..b96f6784 100644 --- a/tests/fstar/hashmap/Hashmap.Clauses.Template.fst +++ b/tests/fstar/hashmap/Hashmap.Clauses.Template.fst @@ -13,3 +13,59 @@ 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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 = + admit () + diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index 638cd66f..38be12ac 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -58,23 +58,59 @@ let hashMap_new_with_capacity let hashMap_new (t : Type0) : result (hashMap_t t) = hashMap_new_with_capacity t 32 4 5 +(** [hashmap::{hashmap::HashMap}::clear]: loop 0: + Source: 'tests/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))) + (decreases (hashMap_clear_loop_decreases t slots i)) + = + let i1 = alloc_vec_Vec_len (list_t t) slots in + if i < i1 + then + let* (_, index_mut_back) = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i in + let* i2 = usize_add i 1 in + let* slots1 = index_mut_back List_Nil in + hashMap_clear_loop t slots1 i2 + else Ok slots + (** [hashmap::{hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 *) let hashMap_clear (t : Type0) (self : hashMap_t t) : result (hashMap_t t) = - admit + let* hm = hashMap_clear_loop t self.slots 0 in + Ok { self with num_entries = 0; slots = hm } (** [hashmap::{hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 *) let hashMap_len (t : Type0) (self : hashMap_t t) : result usize = Ok self.num_entries +(** [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: + Source: 'tests/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 & (list_t t))) + (decreases (hashMap_insert_in_list_loop_decreases t key value ls)) + = + begin match ls with + | List_Cons ckey cvalue tl -> + if ckey = key + then Ok (false, List_Cons ckey value tl) + else + let* (b, tl1) = hashMap_insert_in_list_loop t key value tl in + Ok (b, List_Cons ckey cvalue tl1) + | List_Nil -> Ok (true, List_Cons key value List_Nil) + end + (** [hashmap::{hashmap::HashMap}::insert_in_list]: Source: 'tests/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 & (list_t t)) = - admit + hashMap_insert_in_list_loop t key value ls (** [hashmap::{hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 *) @@ -97,11 +133,46 @@ let hashMap_insert_no_resize Ok { self with num_entries = i1; slots = v } else let* v = index_mut_back l1 in Ok { self with slots = v } +(** [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: + Source: 'tests/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)) + (decreases (hashMap_move_elements_from_list_loop_decreases t ntable ls)) + = + begin match ls with + | List_Cons k v tl -> + let* ntable1 = hashMap_insert_no_resize t ntable k v in + hashMap_move_elements_from_list_loop t ntable1 tl + | List_Nil -> Ok ntable + end + (** [hashmap::{hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) = - admit + hashMap_move_elements_from_list_loop t ntable ls + +(** [hashmap::{hashmap::HashMap}::move_elements]: loop 0: + Source: 'tests/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) : + Tot (result ((alloc_vec_Vec (list_t t)) & (hashMap_t t))) + (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) + = + let i1 = alloc_vec_Vec_len (list_t t) slots in + if i < i1 + then + let* (l, index_mut_back) = + alloc_vec_Vec_index_mut (list_t t) usize + (core_slice_index_SliceIndexUsizeSliceTInst (list_t t)) slots i in + let (ls, l1) = core_mem_replace (list_t t) l List_Nil in + let* ntable1 = hashMap_move_elements_from_list t ntable ls in + let* i2 = usize_add i 1 in + let* slots1 = index_mut_back l1 in + hashMap_move_elements_loop t ntable1 slots1 i2 + else Ok (ntable, slots) (** [hashmap::{hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 *) @@ -110,7 +181,7 @@ let hashMap_move_elements (i : usize) : result ((hashMap_t t) & (alloc_vec_Vec (list_t t))) = - admit + hashMap_move_elements_loop t ntable slots i (** [hashmap::{hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 *) @@ -142,11 +213,24 @@ let hashMap_insert let* i = hashMap_len t self1 in if i > self1.max_load then hashMap_try_resize t self1 else Ok self1 +(** [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: + Source: 'tests/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) + (decreases (hashMap_contains_key_in_list_loop_decreases t key ls)) + = + begin match ls with + | List_Cons ckey _ tl -> + if ckey = key then Ok true else hashMap_contains_key_in_list_loop t key tl + | List_Nil -> Ok false + end + (** [hashmap::{hashmap::HashMap}::contains_key_in_list]: Source: 'tests/src/hashmap.rs', lines 206:4-206:68 *) let hashMap_contains_key_in_list (t : Type0) (key : usize) (ls : list_t t) : result bool = - admit + hashMap_contains_key_in_list_loop t key ls (** [hashmap::{hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 *) @@ -161,10 +245,22 @@ let hashMap_contains_key hash_mod in hashMap_contains_key_in_list t key l +(** [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: + Source: 'tests/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)) + = + begin match ls with + | List_Cons ckey cvalue tl -> + if ckey = key then Ok cvalue else hashMap_get_in_list_loop t key tl + | List_Nil -> Fail Failure + end + (** [hashmap::{hashmap::HashMap}::get_in_list]: Source: 'tests/src/hashmap.rs', lines 224:4-224:70 *) let hashMap_get_in_list (t : Type0) (key : usize) (ls : list_t t) : result t = - admit + hashMap_get_in_list_loop t key ls (** [hashmap::{hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 *) @@ -178,13 +274,32 @@ 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: + Source: 'tests/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 & (t -> result (list_t t)))) + (decreases (hashMap_get_mut_in_list_loop_decreases t ls key)) + = + begin match ls with + | List_Cons ckey cvalue tl -> + if ckey = key + then let back = fun ret -> Ok (List_Cons ckey ret tl) in Ok (cvalue, back) + else + let* (x, back) = hashMap_get_mut_in_list_loop t tl key in + let back1 = + fun ret -> let* tl1 = back ret in Ok (List_Cons ckey cvalue tl1) in + Ok (x, back1) + | List_Nil -> Fail Failure + end + (** [hashmap::{hashmap::HashMap}::get_mut_in_list]: Source: 'tests/src/hashmap.rs', lines 245:4-245:86 *) let hashMap_get_mut_in_list (t : Type0) (ls : list_t t) (key : usize) : result (t & (t -> result (list_t t))) = - admit + hashMap_get_mut_in_list_loop t ls key (** [hashmap::{hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 *) @@ -207,13 +322,36 @@ let hashMap_get_mut Ok { self with slots = v } in Ok (x, back) +(** [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: + Source: 'tests/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) & (list_t t))) + (decreases (hashMap_remove_from_list_loop_decreases t key ls)) + = + begin match ls with + | List_Cons ckey x tl -> + if ckey = key + then + let (mv_ls, _) = + core_mem_replace (list_t t) (List_Cons ckey x tl) List_Nil in + begin match mv_ls with + | List_Cons _ cvalue tl1 -> Ok (Some cvalue, tl1) + | List_Nil -> Fail Failure + end + else + let* (o, tl1) = hashMap_remove_from_list_loop t key tl in + Ok (o, List_Cons ckey x tl1) + | List_Nil -> Ok (None, List_Nil) + end + (** [hashmap::{hashmap::HashMap}::remove_from_list]: Source: 'tests/src/hashmap.rs', lines 265:4-265:69 *) let hashMap_remove_from_list (t : Type0) (key : usize) (ls : list_t t) : result ((option t) & (list_t t)) = - admit + hashMap_remove_from_list_loop t key ls (** [hashmap::{hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 *) diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst index 3c6b4af0..0715bdcb 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Clauses.Template.fst @@ -13,3 +13,60 @@ 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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 + Source: 'tests/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 = + admit () + diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index 27041dd6..cf3ae858 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -61,11 +61,31 @@ let hashmap_HashMap_new_with_capacity 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: + Source: 'tests/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))) + (decreases (hashmap_HashMap_clear_loop_decreases t slots i)) + = + let i1 = alloc_vec_Vec_len (hashmap_List_t t) slots in + if i < i1 + then + let* (_, index_mut_back) = + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i + in + let* i2 = usize_add i 1 in + let* slots1 = index_mut_back Hashmap_List_Nil in + hashmap_HashMap_clear_loop t slots1 i2 + else Ok slots + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 *) let hashmap_HashMap_clear (t : Type0) (self : hashmap_HashMap_t t) : result (hashmap_HashMap_t t) = - admit + let* hm = hashmap_HashMap_clear_loop t self.slots 0 in + Ok { self with num_entries = 0; slots = hm } (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 *) @@ -73,13 +93,30 @@ let hashmap_HashMap_len (t : Type0) (self : hashmap_HashMap_t t) : result usize = Ok self.num_entries +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: + Source: 'tests/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 & (hashmap_List_t t))) + (decreases (hashmap_HashMap_insert_in_list_loop_decreases t key value ls)) + = + begin match ls with + | Hashmap_List_Cons ckey cvalue tl -> + if ckey = key + then Ok (false, Hashmap_List_Cons ckey value tl) + else + let* (b, tl1) = hashmap_HashMap_insert_in_list_loop t key value tl in + Ok (b, Hashmap_List_Cons ckey cvalue tl1) + | Hashmap_List_Nil -> Ok (true, Hashmap_List_Cons key value Hashmap_List_Nil) + end + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: Source: 'tests/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_List_t t)) = - admit + hashmap_HashMap_insert_in_list_loop t key value ls (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 *) @@ -102,13 +139,50 @@ let hashmap_HashMap_insert_no_resize Ok { self with num_entries = i1; slots = v } else let* v = index_mut_back l1 in Ok { self with slots = v } +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: + Source: 'tests/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)) + (decreases ( + hashmap_HashMap_move_elements_from_list_loop_decreases t ntable ls)) + = + begin match ls with + | Hashmap_List_Cons k v tl -> + let* ntable1 = hashmap_HashMap_insert_no_resize t ntable k v in + hashmap_HashMap_move_elements_from_list_loop t ntable1 tl + | Hashmap_List_Nil -> Ok ntable + end + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) = - admit + hashmap_HashMap_move_elements_from_list_loop t ntable ls + +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: + Source: 'tests/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) : + Tot (result ((alloc_vec_Vec (hashmap_List_t t)) & (hashmap_HashMap_t t))) + (decreases (hashmap_HashMap_move_elements_loop_decreases t ntable slots i)) + = + let i1 = alloc_vec_Vec_len (hashmap_List_t t) slots in + if i < i1 + then + let* (l, index_mut_back) = + alloc_vec_Vec_index_mut (hashmap_List_t t) usize + (core_slice_index_SliceIndexUsizeSliceTInst (hashmap_List_t t)) slots i + in + let (ls, l1) = core_mem_replace (hashmap_List_t t) l Hashmap_List_Nil in + let* ntable1 = hashmap_HashMap_move_elements_from_list t ntable ls in + let* i2 = usize_add i 1 in + let* slots1 = index_mut_back l1 in + hashmap_HashMap_move_elements_loop t ntable1 slots1 i2 + else Ok (ntable, slots) (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 *) @@ -117,7 +191,7 @@ let hashmap_HashMap_move_elements (slots : alloc_vec_Vec (hashmap_List_t t)) (i : usize) : result ((hashmap_HashMap_t t) & (alloc_vec_Vec (hashmap_List_t t))) = - admit + hashmap_HashMap_move_elements_loop t ntable slots i (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 *) @@ -149,11 +223,26 @@ let hashmap_HashMap_insert let* i = hashmap_HashMap_len t self1 in if i > self1.max_load then hashmap_HashMap_try_resize t self1 else Ok self1 +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: + Source: 'tests/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) + (decreases (hashmap_HashMap_contains_key_in_list_loop_decreases t key ls)) + = + begin match ls with + | Hashmap_List_Cons ckey _ tl -> + if ckey = key + then Ok true + else hashmap_HashMap_contains_key_in_list_loop t key tl + | Hashmap_List_Nil -> Ok false + end + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 = - admit + hashmap_HashMap_contains_key_in_list_loop t key ls (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 *) @@ -168,11 +257,24 @@ 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: + Source: 'tests/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) + (decreases (hashmap_HashMap_get_in_list_loop_decreases t key ls)) + = + begin match ls with + | Hashmap_List_Cons ckey cvalue tl -> + if ckey = key then Ok cvalue else hashmap_HashMap_get_in_list_loop t key tl + | Hashmap_List_Nil -> Fail Failure + end + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: Source: 'tests/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 = - admit + hashmap_HashMap_get_in_list_loop t key ls (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 *) @@ -187,13 +289,35 @@ 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: + Source: 'tests/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 & (t -> result (hashmap_List_t t)))) + (decreases (hashmap_HashMap_get_mut_in_list_loop_decreases t ls key)) + = + begin match ls with + | Hashmap_List_Cons ckey cvalue tl -> + if ckey = key + then + let back = fun ret -> Ok (Hashmap_List_Cons ckey ret tl) in + Ok (cvalue, back) + else + let* (x, back) = hashmap_HashMap_get_mut_in_list_loop t tl key in + let back1 = + fun ret -> + let* tl1 = back ret in Ok (Hashmap_List_Cons ckey cvalue tl1) in + Ok (x, back1) + | Hashmap_List_Nil -> Fail Failure + end + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 & (t -> result (hashmap_List_t t))) = - admit + hashmap_HashMap_get_mut_in_list_loop t ls key (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 *) @@ -216,13 +340,37 @@ let hashmap_HashMap_get_mut Ok { self with slots = v } in Ok (x, back) +(** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: + Source: 'tests/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) & (hashmap_List_t t))) + (decreases (hashmap_HashMap_remove_from_list_loop_decreases t key ls)) + = + begin match ls with + | Hashmap_List_Cons ckey x tl -> + if ckey = key + then + let (mv_ls, _) = + core_mem_replace (hashmap_List_t t) (Hashmap_List_Cons ckey x tl) + Hashmap_List_Nil in + begin match mv_ls with + | Hashmap_List_Cons _ cvalue tl1 -> Ok (Some cvalue, tl1) + | Hashmap_List_Nil -> Fail Failure + end + else + let* (o, tl1) = hashmap_HashMap_remove_from_list_loop t key tl in + Ok (o, Hashmap_List_Cons ckey x tl1) + | Hashmap_List_Nil -> Ok (None, Hashmap_List_Nil) + end + (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: Source: 'tests/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_List_t t)) = - admit + hashmap_HashMap_remove_from_list_loop t key ls (** [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 *) diff --git a/tests/fstar/misc/Loops.Clauses.Template.fst b/tests/fstar/misc/Loops.Clauses.Template.fst index 21c128bb..77f9c3e4 100644 --- a/tests/fstar/misc/Loops.Clauses.Template.fst +++ b/tests/fstar/misc/Loops.Clauses.Template.fst @@ -30,6 +30,111 @@ let sum_array_loop_decreases (n : usize) (a : array u32 n) (i : usize) (s : u32) : nat = admit () +(** [loops::clear]: decreases clause + Source: 'tests/src/loops.rs', lines 62:0-68:1 *) +unfold +let clear_loop_decreases (v : alloc_vec_Vec u32) (i : usize) : nat = admit () + +(** [loops::list_mem]: decreases clause + Source: 'tests/src/loops.rs', lines 76:0-85:1 *) +unfold let list_mem_loop_decreases (x : u32) (ls : list_t u32) : nat = admit () + +(** [loops::list_nth_mut_loop]: decreases clause + Source: 'tests/src/loops.rs', lines 88:0-98: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 + Source: 'tests/src/loops.rs', lines 101:0-111: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 + Source: 'tests/src/loops.rs', lines 113:0-127:1 *) +unfold +let get_elem_mut_loop_decreases (x : usize) (ls : list_t usize) : nat = + admit () + +(** [loops::get_elem_shared]: decreases clause + Source: 'tests/src/loops.rs', lines 129:0-143: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 + Source: 'tests/src/loops.rs', lines 154:0-165: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 + Source: 'tests/src/loops.rs', lines 168:0-179: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 + Source: 'tests/src/loops.rs', lines 184:0-205: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 + Source: 'tests/src/loops.rs', lines 208:0-229: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 + Source: 'tests/src/loops.rs', lines 233:0-248: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 + Source: 'tests/src/loops.rs', lines 251:0-266: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 + Source: 'tests/src/loops.rs', lines 269:0-284: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 + Source: 'tests/src/loops.rs', lines 288:0-303: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 + Source: 'tests/src/loops.rs', lines 307:0-322: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 + Source: 'tests/src/loops.rs', lines 326:0-341: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 = + admit () + (** [loops::ignore_input_mut_borrow]: decreases clause Source: 'tests/src/loops.rs', lines 345:0-349:1 *) unfold let ignore_input_mut_borrow_loop_decreases (i : u32) : nat = admit () diff --git a/tests/fstar/misc/Loops.Funs.fst b/tests/fstar/misc/Loops.Funs.fst index dc53a04b..0eafeebb 100644 --- a/tests/fstar/misc/Loops.Funs.fst +++ b/tests/fstar/misc/Loops.Funs.fst @@ -77,15 +77,62 @@ let rec sum_array_loop let sum_array (n : usize) (a : array u32 n) : result u32 = sum_array_loop n a 0 0 +(** [loops::clear]: loop 0: + Source: 'tests/src/loops.rs', lines 62:0-68:1 *) +let rec clear_loop + (v : alloc_vec_Vec u32) (i : usize) : + Tot (result (alloc_vec_Vec u32)) (decreases (clear_loop_decreases v i)) + = + let i1 = alloc_vec_Vec_len u32 v in + if i < i1 + then + let* (_, index_mut_back) = + alloc_vec_Vec_index_mut u32 usize + (core_slice_index_SliceIndexUsizeSliceTInst u32) v i in + let* i2 = usize_add i 1 in + let* v1 = index_mut_back 0 in + clear_loop v1 i2 + else Ok v + (** [loops::clear]: Source: 'tests/src/loops.rs', lines 62:0-62:30 *) let clear (v : alloc_vec_Vec u32) : result (alloc_vec_Vec u32) = - admit + clear_loop v 0 + +(** [loops::list_mem]: loop 0: + Source: 'tests/src/loops.rs', lines 76:0-85:1 *) +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 Ok true else list_mem_loop x tl + | List_Nil -> Ok false + end (** [loops::list_mem]: Source: 'tests/src/loops.rs', lines 76:0-76:52 *) let list_mem (x : u32) (ls : list_t u32) : result bool = - admit + list_mem_loop x ls + +(** [loops::list_nth_mut_loop]: loop 0: + Source: 'tests/src/loops.rs', lines 88:0-98:1 *) +let rec list_nth_mut_loop_loop + (t : Type0) (ls : list_t t) (i : u32) : + Tot (result (t & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl) in Ok (x, back) + else + let* i1 = u32_sub i 1 in + let* (x1, back) = list_nth_mut_loop_loop t tl i1 in + let back1 = fun ret -> let* tl1 = back ret in Ok (List_Cons x tl1) in + Ok (x1, back1) + | List_Nil -> Fail Failure + end (** [loops::list_nth_mut_loop]: Source: 'tests/src/loops.rs', lines 88:0-88:71 *) @@ -93,12 +140,44 @@ let list_nth_mut_loop (t : Type0) (ls : list_t t) (i : u32) : result (t & (t -> result (list_t t))) = - admit + list_nth_mut_loop_loop t ls i + +(** [loops::list_nth_shared_loop]: loop 0: + Source: 'tests/src/loops.rs', lines 101:0-111: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)) + = + begin match ls with + | List_Cons x tl -> + if i = 0 + then Ok x + else let* i1 = u32_sub i 1 in list_nth_shared_loop_loop t tl i1 + | List_Nil -> Fail Failure + end (** [loops::list_nth_shared_loop]: Source: 'tests/src/loops.rs', lines 101:0-101:66 *) let list_nth_shared_loop (t : Type0) (ls : list_t t) (i : u32) : result t = - admit + list_nth_shared_loop_loop t ls i + +(** [loops::get_elem_mut]: loop 0: + Source: 'tests/src/loops.rs', lines 113:0-127:1 *) +let rec get_elem_mut_loop + (x : usize) (ls : list_t usize) : + Tot (result (usize & (usize -> result (list_t usize)))) + (decreases (get_elem_mut_loop_decreases x ls)) + = + begin match ls with + | List_Cons y tl -> + if y = x + then let back = fun ret -> Ok (List_Cons ret tl) in Ok (y, back) + else + let* (i, back) = get_elem_mut_loop x tl in + let back1 = fun ret -> let* tl1 = back ret in Ok (List_Cons y tl1) in + Ok (i, back1) + | List_Nil -> Fail Failure + end (** [loops::get_elem_mut]: Source: 'tests/src/loops.rs', lines 113:0-113:73 *) @@ -106,13 +185,32 @@ let get_elem_mut (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result (usize & (usize -> result (alloc_vec_Vec (list_t usize)))) = - admit + let* (ls, index_mut_back) = + alloc_vec_Vec_index_mut (list_t usize) usize + (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in + let* (i, back) = get_elem_mut_loop x ls in + let back1 = fun ret -> let* l = back ret in index_mut_back l in + Ok (i, back1) + +(** [loops::get_elem_shared]: loop 0: + Source: 'tests/src/loops.rs', lines 129:0-143:1 *) +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 Ok y else get_elem_shared_loop x tl + | List_Nil -> Fail Failure + end (** [loops::get_elem_shared]: Source: 'tests/src/loops.rs', lines 129:0-129:68 *) let get_elem_shared (slots : alloc_vec_Vec (list_t usize)) (x : usize) : result usize = - admit + let* ls = + alloc_vec_Vec_index (list_t usize) usize + (core_slice_index_SliceIndexUsizeSliceTInst (list_t usize)) slots 0 in + get_elem_shared_loop x ls (** [loops::id_mut]: Source: 'tests/src/loops.rs', lines 145:0-145:50 *) @@ -127,19 +225,85 @@ let id_mut let id_shared (t : Type0) (ls : list_t t) : result (list_t t) = Ok ls +(** [loops::list_nth_mut_loop_with_id]: loop 0: + Source: 'tests/src/loops.rs', lines 154:0-165:1 *) +let rec list_nth_mut_loop_with_id_loop + (t : Type0) (i : u32) (ls : list_t t) : + Tot (result (t & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl) in Ok (x, back) + else + let* i1 = u32_sub i 1 in + let* (x1, back) = list_nth_mut_loop_with_id_loop t i1 tl in + let back1 = fun ret -> let* tl1 = back ret in Ok (List_Cons x tl1) in + Ok (x1, back1) + | List_Nil -> Fail Failure + end + (** [loops::list_nth_mut_loop_with_id]: Source: 'tests/src/loops.rs', lines 154:0-154:75 *) let list_nth_mut_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result (t & (t -> result (list_t t))) = - admit + let* (ls1, id_mut_back) = id_mut t ls in + let* (x, back) = list_nth_mut_loop_with_id_loop t i ls1 in + let back1 = fun ret -> let* l = back ret in id_mut_back l in + Ok (x, back1) + +(** [loops::list_nth_shared_loop_with_id]: loop 0: + Source: 'tests/src/loops.rs', lines 168:0-179:1 *) +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 Ok x + else let* i1 = u32_sub i 1 in list_nth_shared_loop_with_id_loop t i1 tl + | List_Nil -> Fail Failure + end (** [loops::list_nth_shared_loop_with_id]: Source: 'tests/src/loops.rs', lines 168:0-168:70 *) let list_nth_shared_loop_with_id (t : Type0) (ls : list_t t) (i : u32) : result t = - admit + let* ls1 = id_shared t ls in list_nth_shared_loop_with_id_loop t i ls1 + +(** [loops::list_nth_mut_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 184:0-205: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) & (t -> result (list_t t)) & (t -> 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 + let back'a = fun ret -> Ok (List_Cons ret tl0) in + let back'b = fun ret -> Ok (List_Cons ret tl1) in + Ok ((x0, x1), back'a, back'b) + else + let* i1 = u32_sub i 1 in + let* (p, back'a, back'b) = list_nth_mut_loop_pair_loop t tl0 tl1 i1 in + let back'a1 = + fun ret -> let* tl01 = back'a ret in Ok (List_Cons x0 tl01) in + let back'b1 = + fun ret -> let* tl11 = back'b ret in Ok (List_Cons x1 tl11) in + Ok (p, back'a1, back'b1) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 184:0-188:27 *) @@ -147,13 +311,62 @@ let list_nth_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t)) & (t -> result (list_t t))) = - admit + list_nth_mut_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_shared_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 208:0-229: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)) + (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 Ok (x0, x1) + else let* i1 = u32_sub i 1 in list_nth_shared_loop_pair_loop t tl0 tl1 i1 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 208:0-212:19 *) let list_nth_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - admit + list_nth_shared_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_mut_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 233:0-248: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) & ((t & t) -> 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 back = + fun ret -> + let (x, x2) = ret in Ok (List_Cons x tl0, List_Cons x2 tl1) in + Ok ((x0, x1), back) + else + let* i1 = u32_sub i 1 in + let* (p, back) = list_nth_mut_loop_pair_merge_loop t tl0 tl1 i1 in + let back1 = + fun ret -> + let* (tl01, tl11) = back ret in + Ok (List_Cons x0 tl01, List_Cons x1 tl11) in + Ok (p, back1) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 233:0-237:27 *) @@ -161,13 +374,58 @@ let list_nth_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & ((t & t) -> result ((list_t t) & (list_t t)))) = - admit + list_nth_mut_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_shared_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 251:0-266: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)) + (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 Ok (x0, x1) + else + let* i1 = u32_sub i 1 in + list_nth_shared_loop_pair_merge_loop t tl0 tl1 i1 + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 251:0-255:19 *) let list_nth_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result (t & t) = - admit + list_nth_shared_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_mut_shared_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 269:0-284: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl0) in Ok ((x0, x1), back) + else + let* i1 = u32_sub i 1 in + let* (p, back) = list_nth_mut_shared_loop_pair_loop t tl0 tl1 i1 in + let back1 = fun ret -> let* tl01 = back ret in Ok (List_Cons x0 tl01) + in + Ok (p, back1) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_mut_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 269:0-273:23 *) @@ -175,7 +433,32 @@ let list_nth_mut_shared_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - admit + list_nth_mut_shared_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 288:0-303: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl0) in Ok ((x0, x1), back) + else + let* i1 = u32_sub i 1 in + let* (p, back) = list_nth_mut_shared_loop_pair_merge_loop t tl0 tl1 i1 + in + let back1 = fun ret -> let* tl01 = back ret in Ok (List_Cons x0 tl01) + in + Ok (p, back1) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_mut_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 288:0-292:23 *) @@ -183,7 +466,31 @@ let list_nth_mut_shared_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - admit + list_nth_mut_shared_loop_pair_merge_loop t ls0 ls1 i + +(** [loops::list_nth_shared_mut_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 307:0-322: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl1) in Ok ((x0, x1), back) + else + let* i1 = u32_sub i 1 in + let* (p, back) = list_nth_shared_mut_loop_pair_loop t tl0 tl1 i1 in + let back1 = fun ret -> let* tl11 = back ret in Ok (List_Cons x1 tl11) + in + Ok (p, back1) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_shared_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 307:0-311:23 *) @@ -191,7 +498,32 @@ let list_nth_shared_mut_loop_pair (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - admit + list_nth_shared_mut_loop_pair_loop t ls0 ls1 i + +(** [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 326:0-341: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) & (t -> 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 let back = fun ret -> Ok (List_Cons ret tl1) in Ok ((x0, x1), back) + else + let* i1 = u32_sub i 1 in + let* (p, back) = list_nth_shared_mut_loop_pair_merge_loop t tl0 tl1 i1 + in + let back1 = fun ret -> let* tl11 = back ret in Ok (List_Cons x1 tl11) + in + Ok (p, back1) + | List_Nil -> Fail Failure + end + | List_Nil -> Fail Failure + end (** [loops::list_nth_shared_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 326:0-330:23 *) @@ -199,7 +531,7 @@ let list_nth_shared_mut_loop_pair_merge (t : Type0) (ls0 : list_t t) (ls1 : list_t t) (i : u32) : result ((t & t) & (t -> result (list_t t))) = - admit + list_nth_shared_mut_loop_pair_merge_loop t ls0 ls1 i (** [loops::ignore_input_mut_borrow]: loop 0: Source: 'tests/src/loops.rs', lines 345:0-349:1 *) diff --git a/tests/lean/Arrays.lean b/tests/lean/Arrays.lean index 464c3ced..5ffcce51 100644 --- a/tests/lean/Arrays.lean +++ b/tests/lean/Arrays.lean @@ -345,15 +345,48 @@ def take_array_t (a : Array AB 2#usize) : Result Unit := def non_copyable_array : Result Unit := take_array_t (Array.make AB 2#usize [ AB.A, AB.B ]) +/- [arrays::sum]: loop 0: + Source: 'tests/src/arrays.rs', lines 242:0-250:1 -/ +divergent def sum_loop (s : Slice U32) (sum1 : U32) (i : Usize) : Result U32 := + let i1 := Slice.len U32 s + if i < i1 + then + do + let i2 ← Slice.index_usize U32 s i + let sum3 ← sum1 + i2 + let i3 ← i + 1#usize + sum_loop s sum3 i3 + else Result.ok sum1 + /- [arrays::sum]: Source: 'tests/src/arrays.rs', lines 242:0-242:28 -/ def sum (s : Slice U32) : Result U32 := - sorry + sum_loop s 0#u32 0#usize + +/- [arrays::sum2]: loop 0: + Source: 'tests/src/arrays.rs', lines 252:0-261:1 -/ +divergent def sum2_loop + (s : Slice U32) (s2 : Slice U32) (sum1 : U32) (i : Usize) : Result U32 := + let i1 := Slice.len U32 s + if i < i1 + then + do + let i2 ← Slice.index_usize U32 s i + let i3 ← Slice.index_usize U32 s2 i + let i4 ← i2 + i3 + let sum3 ← sum1 + i4 + let i5 ← i + 1#usize + sum2_loop s s2 sum3 i5 + else Result.ok sum1 /- [arrays::sum2]: Source: 'tests/src/arrays.rs', lines 252:0-252:41 -/ def sum2 (s : Slice U32) (s2 : Slice U32) : Result U32 := - sorry + let i := Slice.len U32 s + let i1 := Slice.len U32 s2 + if ¬ (i = i1) + then Result.fail .panic + else sum2_loop s s2 0#u32 0#usize /- [arrays::f0]: Source: 'tests/src/arrays.rs', lines 263:0-263:11 -/ @@ -427,10 +460,24 @@ def ite : Result Unit := let _ ← to_slice_mut_back s1 Result.ok () +/- [arrays::zero_slice]: loop 0: + Source: 'tests/src/arrays.rs', lines 303:0-310:1 -/ +divergent def zero_slice_loop + (a : Slice U8) (i : Usize) (len : Usize) : Result (Slice U8) := + if i < len + then + do + let (_, index_mut_back) ← Slice.index_mut_usize U8 a i + let i1 ← i + 1#usize + let a1 ← index_mut_back 0#u8 + zero_slice_loop a1 i1 len + else Result.ok a + /- [arrays::zero_slice]: Source: 'tests/src/arrays.rs', lines 303:0-303:31 -/ def zero_slice (a : Slice U8) : Result (Slice U8) := - sorry + let len := Slice.len U8 a + zero_slice_loop a 0#usize len /- [arrays::iter_mut_slice]: loop 0: Source: 'tests/src/arrays.rs', lines 312:0-318:1 -/ diff --git a/tests/lean/Demo/Demo.lean b/tests/lean/Demo/Demo.lean index 7402f010..a9b349b3 100644 --- a/tests/lean/Demo/Demo.lean +++ b/tests/lean/Demo/Demo.lean @@ -87,13 +87,36 @@ divergent def list_nth_mut Result.ok (t, back) | CList.CNil => Result.fail .panic +/- [demo::list_nth_mut1]: loop 0: + Source: 'tests/src/demo.rs', lines 69:0-78:1 -/ +divergent def list_nth_mut1_loop + (T : Type) (l : CList T) (i : U32) : + Result (T × (T → Result (CList T))) + := + match l with + | CList.CCons x tl => + if i = 0#u32 + then + let back := fun ret => Result.ok (CList.CCons ret tl) + Result.ok (x, back) + else + do + let i1 ← i - 1#u32 + let (t, back) ← list_nth_mut1_loop T tl i1 + let back1 := + fun ret => do + let tl1 ← back ret + Result.ok (CList.CCons x tl1) + Result.ok (t, back1) + | CList.CNil => Result.fail .panic + /- [demo::list_nth_mut1]: Source: 'tests/src/demo.rs', lines 69:0-69:77 -/ def list_nth_mut1 (T : Type) (l : CList T) (i : U32) : Result (T × (T → Result (CList T))) := - sorry + list_nth_mut1_loop T l i /- [demo::i32_id]: Source: 'tests/src/demo.rs', lines 80:0-80:28 -/ diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index a107240e..17ad26f7 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -57,23 +57,59 @@ def HashMap.new_with_capacity 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: + Source: 'tests/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)) + := + let i1 := alloc.vec.Vec.len (List T) slots + if i < i1 + then + do + let (_, index_mut_back) ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i + let i2 ← i + 1#usize + let slots1 ← index_mut_back List.Nil + HashMap.clear_loop T slots1 i2 + else Result.ok slots + /- [hashmap::{hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 -/ def HashMap.clear (T : Type) (self : HashMap T) : Result (HashMap T) := - sorry + do + let hm ← HashMap.clear_loop T self.slots 0#usize + Result.ok { self with num_entries := 0#usize, slots := hm } /- [hashmap::{hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 -/ def HashMap.len (T : Type) (self : HashMap T) : Result Usize := Result.ok self.num_entries +/- [hashmap::{hashmap::HashMap}::insert_in_list]: loop 0: + Source: 'tests/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 × (List T)) + := + match ls with + | List.Cons ckey cvalue tl => + if ckey = key + then Result.ok (false, List.Cons ckey value tl) + else + do + let (b, tl1) ← HashMap.insert_in_list_loop T key value tl + Result.ok (b, List.Cons ckey cvalue tl1) + | List.Nil => Result.ok (true, List.Cons key value List.Nil) + /- [hashmap::{hashmap::HashMap}::insert_in_list]: Source: 'tests/src/hashmap.rs', lines 97:4-97:71 -/ def HashMap.insert_in_list (T : Type) (key : Usize) (value : T) (ls : List T) : Result (Bool × (List T)) := - sorry + HashMap.insert_in_list_loop T key value ls /- [hashmap::{hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 -/ @@ -99,11 +135,43 @@ def HashMap.insert_no_resize let v ← index_mut_back l1 Result.ok { self with slots := v } +/- [hashmap::{hashmap::HashMap}::move_elements_from_list]: loop 0: + Source: 'tests/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 + | List.Cons k v tl => + do + let ntable1 ← HashMap.insert_no_resize T ntable k v + HashMap.move_elements_from_list_loop T ntable1 tl + | List.Nil => Result.ok ntable + /- [hashmap::{hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - sorry + HashMap.move_elements_from_list_loop T ntable ls + +/- [hashmap::{hashmap::HashMap}::move_elements]: loop 0: + Source: 'tests/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) + : + Result ((alloc.vec.Vec (List T)) × (HashMap T)) + := + let i1 := alloc.vec.Vec.len (List T) slots + if i < i1 + then + do + let (l, index_mut_back) ← + alloc.vec.Vec.index_mut (List T) Usize + (core.slice.index.SliceIndexUsizeSliceTInst (List T)) slots i + let (ls, l1) := core.mem.replace (List T) l List.Nil + let ntable1 ← HashMap.move_elements_from_list T ntable ls + let i2 ← i + 1#usize + let slots1 ← index_mut_back l1 + HashMap.move_elements_loop T ntable1 slots1 i2 + else Result.ok (ntable, slots) /- [hashmap::{hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 -/ @@ -112,7 +180,7 @@ def HashMap.move_elements : Result ((HashMap T) × (alloc.vec.Vec (List T))) := - sorry + HashMap.move_elements_loop T ntable slots i /- [hashmap::{hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 -/ @@ -151,11 +219,22 @@ def HashMap.insert then HashMap.try_resize T self1 else Result.ok self1 +/- [hashmap::{hashmap::HashMap}::contains_key_in_list]: loop 0: + Source: 'tests/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 + | List.Cons ckey _ tl => + if ckey = key + then Result.ok true + else HashMap.contains_key_in_list_loop T key tl + | List.Nil => Result.ok false + /- [hashmap::{hashmap::HashMap}::contains_key_in_list]: Source: 'tests/src/hashmap.rs', lines 206:4-206:68 -/ def HashMap.contains_key_in_list (T : Type) (key : Usize) (ls : List T) : Result Bool := - sorry + HashMap.contains_key_in_list_loop T key ls /- [hashmap::{hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 -/ @@ -170,10 +249,21 @@ def HashMap.contains_key (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots hash_mod HashMap.contains_key_in_list T key l +/- [hashmap::{hashmap::HashMap}::get_in_list]: loop 0: + Source: 'tests/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 + | List.Cons ckey cvalue tl => + if ckey = key + then Result.ok cvalue + else HashMap.get_in_list_loop T key tl + | List.Nil => Result.fail .panic + /- [hashmap::{hashmap::HashMap}::get_in_list]: Source: 'tests/src/hashmap.rs', lines 224:4-224:70 -/ def HashMap.get_in_list (T : Type) (key : Usize) (ls : List T) : Result T := - sorry + HashMap.get_in_list_loop T key ls /- [hashmap::{hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 -/ @@ -187,13 +277,36 @@ def HashMap.get (T : Type) (self : HashMap T) (key : Usize) : Result T := (core.slice.index.SliceIndexUsizeSliceTInst (List T)) self.slots hash_mod HashMap.get_in_list T key l +/- [hashmap::{hashmap::HashMap}::get_mut_in_list]: loop 0: + Source: 'tests/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 × (T → Result (List T))) + := + match ls with + | List.Cons ckey cvalue tl => + if ckey = key + then + let back := fun ret => Result.ok (List.Cons ckey ret tl) + Result.ok (cvalue, back) + else + do + let (t, back) ← HashMap.get_mut_in_list_loop T tl key + let back1 := + fun ret => + do + let tl1 ← back ret + Result.ok (List.Cons ckey cvalue tl1) + Result.ok (t, back1) + | List.Nil => Result.fail .panic + /- [hashmap::{hashmap::HashMap}::get_mut_in_list]: Source: 'tests/src/hashmap.rs', lines 245:4-245:86 -/ def HashMap.get_mut_in_list (T : Type) (ls : List T) (key : Usize) : Result (T × (T → Result (List T))) := - sorry + HashMap.get_mut_in_list_loop T ls key /- [hashmap::{hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 -/ @@ -217,11 +330,30 @@ def HashMap.get_mut Result.ok { self with slots := v } Result.ok (t, back) +/- [hashmap::{hashmap::HashMap}::remove_from_list]: loop 0: + Source: 'tests/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) × (List T)) := + match ls with + | List.Cons ckey t tl => + if ckey = key + then + let (mv_ls, _) := + core.mem.replace (List T) (List.Cons ckey t tl) List.Nil + match mv_ls with + | List.Cons _ cvalue tl1 => Result.ok (some cvalue, tl1) + | List.Nil => Result.fail .panic + else + do + let (o, tl1) ← HashMap.remove_from_list_loop T key tl + Result.ok (o, List.Cons ckey t tl1) + | List.Nil => Result.ok (none, List.Nil) + /- [hashmap::{hashmap::HashMap}::remove_from_list]: Source: 'tests/src/hashmap.rs', lines 265:4-265:69 -/ def HashMap.remove_from_list (T : Type) (key : Usize) (ls : List T) : Result ((Option T) × (List T)) := - sorry + HashMap.remove_from_list_loop T key ls /- [hashmap::{hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 -/ diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index d3c4ae77..56039741 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -60,24 +60,61 @@ def hashmap.HashMap.new_with_capacity 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: + Source: 'tests/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)) + := + let i1 := alloc.vec.Vec.len (hashmap.List T) slots + if i < i1 + then + do + let (_, index_mut_back) ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i + let i2 ← i + 1#usize + let slots1 ← index_mut_back hashmap.List.Nil + hashmap.HashMap.clear_loop T slots1 i2 + else Result.ok slots + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::clear]: Source: 'tests/src/hashmap.rs', lines 80:4-80:27 -/ def hashmap.HashMap.clear (T : Type) (self : hashmap.HashMap T) : Result (hashmap.HashMap T) := - sorry + do + let hm ← hashmap.HashMap.clear_loop T self.slots 0#usize + Result.ok { self with num_entries := 0#usize, slots := hm } /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::len]: Source: 'tests/src/hashmap.rs', lines 90:4-90:30 -/ def hashmap.HashMap.len (T : Type) (self : hashmap.HashMap T) : Result Usize := Result.ok self.num_entries +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: loop 0: + Source: 'tests/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 × (hashmap.List T)) + := + match ls with + | hashmap.List.Cons ckey cvalue tl => + if ckey = key + then Result.ok (false, hashmap.List.Cons ckey value tl) + else + do + let (b, tl1) ← hashmap.HashMap.insert_in_list_loop T key value tl + Result.ok (b, hashmap.List.Cons ckey cvalue tl1) + | hashmap.List.Nil => + Result.ok (true, hashmap.List.Cons key value hashmap.List.Nil) + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_in_list]: Source: 'tests/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.List T)) := - sorry + hashmap.HashMap.insert_in_list_loop T key value ls /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::insert_no_resize]: Source: 'tests/src/hashmap.rs', lines 117:4-117:54 -/ @@ -104,13 +141,47 @@ def hashmap.HashMap.insert_no_resize let v ← index_mut_back l1 Result.ok { self with slots := v } +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: loop 0: + Source: 'tests/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) + := + match ls with + | hashmap.List.Cons k v tl => + do + let ntable1 ← hashmap.HashMap.insert_no_resize T ntable k v + hashmap.HashMap.move_elements_from_list_loop T ntable1 tl + | hashmap.List.Nil => Result.ok ntable + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements_from_list]: Source: 'tests/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) := - sorry + hashmap.HashMap.move_elements_from_list_loop T ntable ls + +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: loop 0: + Source: 'tests/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) : + Result ((alloc.vec.Vec (hashmap.List T)) × (hashmap.HashMap T)) + := + let i1 := alloc.vec.Vec.len (hashmap.List T) slots + if i < i1 + then + do + let (l, index_mut_back) ← + alloc.vec.Vec.index_mut (hashmap.List T) Usize + (core.slice.index.SliceIndexUsizeSliceTInst (hashmap.List T)) slots i + let (ls, l1) := core.mem.replace (hashmap.List T) l hashmap.List.Nil + let ntable1 ← hashmap.HashMap.move_elements_from_list T ntable ls + let i2 ← i + 1#usize + let slots1 ← index_mut_back l1 + hashmap.HashMap.move_elements_loop T ntable1 slots1 i2 + else Result.ok (ntable, slots) /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::move_elements]: Source: 'tests/src/hashmap.rs', lines 171:4-171:95 -/ @@ -119,7 +190,7 @@ def hashmap.HashMap.move_elements (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) := - sorry + hashmap.HashMap.move_elements_loop T ntable slots i /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::try_resize]: Source: 'tests/src/hashmap.rs', lines 140:4-140:28 -/ @@ -159,11 +230,22 @@ def hashmap.HashMap.insert then hashmap.HashMap.try_resize T self1 else Result.ok self1 +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: loop 0: + Source: 'tests/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 + | hashmap.List.Cons ckey _ tl => + if ckey = key + then Result.ok true + else hashmap.HashMap.contains_key_in_list_loop T key tl + | hashmap.List.Nil => Result.ok false + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key_in_list]: Source: 'tests/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 := - sorry + hashmap.HashMap.contains_key_in_list_loop T key ls /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::contains_key]: Source: 'tests/src/hashmap.rs', lines 199:4-199:49 -/ @@ -179,11 +261,22 @@ def hashmap.HashMap.contains_key hash_mod hashmap.HashMap.contains_key_in_list T key l +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: loop 0: + Source: 'tests/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 + | hashmap.List.Cons ckey cvalue tl => + if ckey = key + then Result.ok cvalue + else hashmap.HashMap.get_in_list_loop T key tl + | hashmap.List.Nil => Result.fail .panic + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_in_list]: Source: 'tests/src/hashmap.rs', lines 224:4-224:70 -/ def hashmap.HashMap.get_in_list (T : Type) (key : Usize) (ls : hashmap.List T) : Result T := - sorry + hashmap.HashMap.get_in_list_loop T key ls /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get]: Source: 'tests/src/hashmap.rs', lines 239:4-239:55 -/ @@ -199,13 +292,36 @@ def hashmap.HashMap.get hash_mod hashmap.HashMap.get_in_list T key l +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: loop 0: + Source: 'tests/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 × (T → Result (hashmap.List T))) + := + match ls with + | hashmap.List.Cons ckey cvalue tl => + if ckey = key + then + let back := fun ret => Result.ok (hashmap.List.Cons ckey ret tl) + Result.ok (cvalue, back) + else + do + let (t, back) ← hashmap.HashMap.get_mut_in_list_loop T tl key + let back1 := + fun ret => + do + let tl1 ← back ret + Result.ok (hashmap.List.Cons ckey cvalue tl1) + Result.ok (t, back1) + | hashmap.List.Nil => Result.fail .panic + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut_in_list]: Source: 'tests/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 × (T → Result (hashmap.List T))) := - sorry + hashmap.HashMap.get_mut_in_list_loop T ls key /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::get_mut]: Source: 'tests/src/hashmap.rs', lines 257:4-257:67 -/ @@ -230,13 +346,35 @@ def hashmap.HashMap.get_mut Result.ok { self with slots := v } Result.ok (t, back) +/- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: loop 0: + Source: 'tests/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) × (hashmap.List T)) + := + match ls with + | hashmap.List.Cons ckey t tl => + if ckey = key + then + let (mv_ls, _) := + core.mem.replace (hashmap.List T) (hashmap.List.Cons ckey t tl) + hashmap.List.Nil + match mv_ls with + | hashmap.List.Cons _ cvalue tl1 => Result.ok (some cvalue, tl1) + | hashmap.List.Nil => Result.fail .panic + else + do + let (o, tl1) ← hashmap.HashMap.remove_from_list_loop T key tl + Result.ok (o, hashmap.List.Cons ckey t tl1) + | hashmap.List.Nil => Result.ok (none, hashmap.List.Nil) + /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove_from_list]: Source: 'tests/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.List T)) := - sorry + hashmap.HashMap.remove_from_list_loop T key ls /- [hashmap_main::hashmap::{hashmap_main::hashmap::HashMap}::remove]: Source: 'tests/src/hashmap.rs', lines 294:4-294:52 -/ diff --git a/tests/lean/Loops.lean b/tests/lean/Loops.lean index 046d2240..d5bda6ab 100644 --- a/tests/lean/Loops.lean +++ b/tests/lean/Loops.lean @@ -72,10 +72,26 @@ divergent def sum_array_loop def sum_array (N : Usize) (a : Array U32 N) : Result U32 := sum_array_loop N a 0#usize 0#u32 +/- [loops::clear]: loop 0: + Source: 'tests/src/loops.rs', lines 62:0-68:1 -/ +divergent def clear_loop + (v : alloc.vec.Vec U32) (i : Usize) : Result (alloc.vec.Vec U32) := + let i1 := alloc.vec.Vec.len U32 v + if i < i1 + then + do + let (_, index_mut_back) ← + alloc.vec.Vec.index_mut U32 Usize + (core.slice.index.SliceIndexUsizeSliceTInst U32) v i + let i2 ← i + 1#usize + let v1 ← index_mut_back 0#u32 + clear_loop v1 i2 + else Result.ok v + /- [loops::clear]: Source: 'tests/src/loops.rs', lines 62:0-62:30 -/ def clear (v : alloc.vec.Vec U32) : Result (alloc.vec.Vec U32) := - sorry + clear_loop v 0#usize /- [loops::List] Source: 'tests/src/loops.rs', lines 70:0-70:16 -/ @@ -83,21 +99,86 @@ inductive List (T : Type) := | Cons : T → List T → List T | Nil : List T +/- [loops::list_mem]: loop 0: + Source: 'tests/src/loops.rs', lines 76:0-85:1 -/ +divergent def list_mem_loop (x : U32) (ls : List U32) : Result Bool := + match ls with + | List.Cons y tl => if y = x + then Result.ok true + else list_mem_loop x tl + | List.Nil => Result.ok false + /- [loops::list_mem]: Source: 'tests/src/loops.rs', lines 76:0-76:52 -/ def list_mem (x : U32) (ls : List U32) : Result Bool := - sorry + list_mem_loop x ls + +/- [loops::list_nth_mut_loop]: loop 0: + Source: 'tests/src/loops.rs', lines 88:0-98:1 -/ +divergent def list_nth_mut_loop_loop + (T : Type) (ls : List T) (i : U32) : Result (T × (T → Result (List T))) := + match ls with + | List.Cons x tl => + if i = 0#u32 + then + let back := fun ret => Result.ok (List.Cons ret tl) + Result.ok (x, back) + else + do + let i1 ← i - 1#u32 + let (t, back) ← list_nth_mut_loop_loop T tl i1 + let back1 := + fun ret => do + let tl1 ← back ret + Result.ok (List.Cons x tl1) + Result.ok (t, back1) + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop]: Source: 'tests/src/loops.rs', lines 88:0-88:71 -/ def list_nth_mut_loop (T : Type) (ls : List T) (i : U32) : Result (T × (T → Result (List T))) := - sorry + list_nth_mut_loop_loop T ls i + +/- [loops::list_nth_shared_loop]: loop 0: + Source: 'tests/src/loops.rs', lines 101:0-111:1 -/ +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.ok x + else do + let i1 ← i - 1#u32 + list_nth_shared_loop_loop T tl i1 + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop]: Source: 'tests/src/loops.rs', lines 101:0-101:66 -/ def list_nth_shared_loop (T : Type) (ls : List T) (i : U32) : Result T := - sorry + list_nth_shared_loop_loop T ls i + +/- [loops::get_elem_mut]: loop 0: + Source: 'tests/src/loops.rs', lines 113:0-127:1 -/ +divergent def get_elem_mut_loop + (x : Usize) (ls : List Usize) : + Result (Usize × (Usize → Result (List Usize))) + := + match ls with + | List.Cons y tl => + if y = x + then + let back := fun ret => Result.ok (List.Cons ret tl) + Result.ok (y, back) + else + do + let (i, back) ← get_elem_mut_loop x tl + let back1 := + fun ret => do + let tl1 ← back ret + Result.ok (List.Cons y tl1) + Result.ok (i, back1) + | List.Nil => Result.fail .panic /- [loops::get_elem_mut]: Source: 'tests/src/loops.rs', lines 113:0-113:73 -/ @@ -105,13 +186,35 @@ def get_elem_mut (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result (Usize × (Usize → Result (alloc.vec.Vec (List Usize)))) := - sorry + do + let (ls, index_mut_back) ← + alloc.vec.Vec.index_mut (List Usize) Usize + (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize + let (i, back) ← get_elem_mut_loop x ls + let back1 := fun ret => do + let l ← back ret + index_mut_back l + Result.ok (i, back1) + +/- [loops::get_elem_shared]: loop 0: + Source: 'tests/src/loops.rs', lines 129:0-143:1 -/ +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.ok y + else get_elem_shared_loop x tl + | List.Nil => Result.fail .panic /- [loops::get_elem_shared]: Source: 'tests/src/loops.rs', lines 129:0-129:68 -/ def get_elem_shared (slots : alloc.vec.Vec (List Usize)) (x : Usize) : Result Usize := - sorry + do + let ls ← + alloc.vec.Vec.index (List Usize) Usize + (core.slice.index.SliceIndexUsizeSliceTInst (List Usize)) slots 0#usize + get_elem_shared_loop x ls /- [loops::id_mut]: Source: 'tests/src/loops.rs', lines 145:0-145:50 -/ @@ -126,17 +229,90 @@ def id_mut def id_shared (T : Type) (ls : List T) : Result (List T) := Result.ok ls +/- [loops::list_nth_mut_loop_with_id]: loop 0: + Source: 'tests/src/loops.rs', lines 154:0-165:1 -/ +divergent def list_nth_mut_loop_with_id_loop + (T : Type) (i : U32) (ls : List T) : Result (T × (T → Result (List T))) := + match ls with + | List.Cons x tl => + if i = 0#u32 + then + let back := fun ret => Result.ok (List.Cons ret tl) + Result.ok (x, back) + else + do + let i1 ← i - 1#u32 + let (t, back) ← list_nth_mut_loop_with_id_loop T i1 tl + let back1 := + fun ret => do + let tl1 ← back ret + Result.ok (List.Cons x tl1) + Result.ok (t, back1) + | List.Nil => Result.fail .panic + /- [loops::list_nth_mut_loop_with_id]: Source: 'tests/src/loops.rs', lines 154:0-154:75 -/ def list_nth_mut_loop_with_id (T : Type) (ls : List T) (i : U32) : Result (T × (T → Result (List T))) := - sorry + do + let (ls1, id_mut_back) ← id_mut T ls + let (t, back) ← list_nth_mut_loop_with_id_loop T i ls1 + let back1 := fun ret => do + let l ← back ret + id_mut_back l + Result.ok (t, back1) + +/- [loops::list_nth_shared_loop_with_id]: loop 0: + Source: 'tests/src/loops.rs', lines 168:0-179:1 -/ +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.ok x + else do + let i1 ← i - 1#u32 + list_nth_shared_loop_with_id_loop T i1 tl + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop_with_id]: Source: 'tests/src/loops.rs', lines 168:0-168:70 -/ def list_nth_shared_loop_with_id (T : Type) (ls : List T) (i : U32) : Result T := - sorry + do + let ls1 ← id_shared T ls + list_nth_shared_loop_with_id_loop T i ls1 + +/- [loops::list_nth_mut_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 184:0-205:1 -/ +divergent def list_nth_mut_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : + Result ((T × T) × (T → Result (List T)) × (T → Result (List T))) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then + let back'a := fun ret => Result.ok (List.Cons ret tl0) + let back'b := fun ret => Result.ok (List.Cons ret tl1) + Result.ok ((x0, x1), back'a, back'b) + else + do + let i1 ← i - 1#u32 + let (p, back'a, back'b) ← list_nth_mut_loop_pair_loop T tl0 tl1 i1 + let back'a1 := + fun ret => do + let tl01 ← back'a ret + Result.ok (List.Cons x0 tl01) + let back'b1 := + fun ret => do + let tl11 ← back'b ret + Result.ok (List.Cons x1 tl11) + Result.ok (p, back'a1, back'b1) + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 184:0-188:27 -/ @@ -144,13 +320,59 @@ def list_nth_mut_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T)) × (T → Result (List T))) := - sorry + list_nth_mut_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_shared_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 208:0-229: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 + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ok (x0, x1) + else do + let i1 ← i - 1#u32 + list_nth_shared_loop_pair_loop T tl0 tl1 i1 + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 208:0-212:19 -/ def list_nth_shared_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - sorry + list_nth_shared_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 233:0-248:1 -/ +divergent def list_nth_mut_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : + Result ((T × T) × ((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 back := + fun ret => + let (t, t1) := ret + Result.ok (List.Cons t tl0, List.Cons t1 tl1) + Result.ok ((x0, x1), back) + else + do + let i1 ← i - 1#u32 + let (p, back) ← list_nth_mut_loop_pair_merge_loop T tl0 tl1 i1 + let back1 := + fun ret => + do + let (tl01, tl11) ← back ret + Result.ok (List.Cons x0 tl01, List.Cons x1 tl11) + Result.ok (p, back1) + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 233:0-237:27 -/ @@ -158,13 +380,56 @@ def list_nth_mut_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × ((T × T) → Result ((List T) × (List T)))) := - sorry + list_nth_mut_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_shared_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 251:0-266: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 + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then Result.ok (x0, x1) + else + do + let i1 ← i - 1#u32 + list_nth_shared_loop_pair_merge_loop T tl0 tl1 i1 + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 251:0-255:19 -/ def list_nth_shared_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result (T × T) := - sorry + list_nth_shared_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 269:0-284:1 -/ +divergent def list_nth_mut_shared_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : + Result ((T × T) × (T → Result (List T))) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then + let back := fun ret => Result.ok (List.Cons ret tl0) + Result.ok ((x0, x1), back) + else + do + let i1 ← i - 1#u32 + let (p, back) ← list_nth_mut_shared_loop_pair_loop T tl0 tl1 i1 + let back1 := + fun ret => do + let tl01 ← back ret + Result.ok (List.Cons x0 tl01) + Result.ok (p, back1) + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_shared_loop_pair]: Source: 'tests/src/loops.rs', lines 269:0-273:23 -/ @@ -172,7 +437,33 @@ def list_nth_mut_shared_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - sorry + list_nth_mut_shared_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_mut_shared_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 288:0-303:1 -/ +divergent def list_nth_mut_shared_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : + Result ((T × T) × (T → Result (List T))) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then + let back := fun ret => Result.ok (List.Cons ret tl0) + Result.ok ((x0, x1), back) + else + do + let i1 ← i - 1#u32 + let (p, back) ← list_nth_mut_shared_loop_pair_merge_loop T tl0 tl1 i1 + let back1 := + fun ret => do + let tl01 ← back ret + Result.ok (List.Cons x0 tl01) + Result.ok (p, back1) + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_mut_shared_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 288:0-292:23 -/ @@ -180,7 +471,33 @@ def list_nth_mut_shared_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - sorry + list_nth_mut_shared_loop_pair_merge_loop T ls0 ls1 i + +/- [loops::list_nth_shared_mut_loop_pair]: loop 0: + Source: 'tests/src/loops.rs', lines 307:0-322:1 -/ +divergent def list_nth_shared_mut_loop_pair_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : + Result ((T × T) × (T → Result (List T))) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then + let back := fun ret => Result.ok (List.Cons ret tl1) + Result.ok ((x0, x1), back) + else + do + let i1 ← i - 1#u32 + let (p, back) ← list_nth_shared_mut_loop_pair_loop T tl0 tl1 i1 + let back1 := + fun ret => do + let tl11 ← back ret + Result.ok (List.Cons x1 tl11) + Result.ok (p, back1) + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_mut_loop_pair]: Source: 'tests/src/loops.rs', lines 307:0-311:23 -/ @@ -188,7 +505,33 @@ def list_nth_shared_mut_loop_pair (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - sorry + list_nth_shared_mut_loop_pair_loop T ls0 ls1 i + +/- [loops::list_nth_shared_mut_loop_pair_merge]: loop 0: + Source: 'tests/src/loops.rs', lines 326:0-341:1 -/ +divergent def list_nth_shared_mut_loop_pair_merge_loop + (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : + Result ((T × T) × (T → Result (List T))) + := + match ls0 with + | List.Cons x0 tl0 => + match ls1 with + | List.Cons x1 tl1 => + if i = 0#u32 + then + let back := fun ret => Result.ok (List.Cons ret tl1) + Result.ok ((x0, x1), back) + else + do + let i1 ← i - 1#u32 + let (p, back) ← list_nth_shared_mut_loop_pair_merge_loop T tl0 tl1 i1 + let back1 := + fun ret => do + let tl11 ← back ret + Result.ok (List.Cons x1 tl11) + Result.ok (p, back1) + | List.Nil => Result.fail .panic + | List.Nil => Result.fail .panic /- [loops::list_nth_shared_mut_loop_pair_merge]: Source: 'tests/src/loops.rs', lines 326:0-330:23 -/ @@ -196,7 +539,7 @@ def list_nth_shared_mut_loop_pair_merge (T : Type) (ls0 : List T) (ls1 : List T) (i : U32) : Result ((T × T) × (T → Result (List T))) := - sorry + list_nth_shared_mut_loop_pair_merge_loop T ls0 ls1 i /- [loops::ignore_input_mut_borrow]: loop 0: Source: 'tests/src/loops.rs', lines 345:0-349:1 -/ -- cgit v1.2.3 From e2afa2a24b290a55451431373152bf5a26c78d24 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 13:48:44 +0200 Subject: Fix unused variables warnings --- compiler/InterpreterBorrows.ml | 14 ++++++++++---- compiler/InterpreterLoopsJoinCtxs.ml | 17 ++++++++--------- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index d48635fc..653dea7c 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -1713,7 +1713,7 @@ let destructure_abs (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) let ignored = mk_aignored span child_av.ty in let value = ABorrow (AMutBorrow (pm, bid, ignored)) in push { value; ty } - | ASharedBorrow (pm, _) -> + | ASharedBorrow _ -> (* Nothing specific to do: keep the value as it is *) push av | AIgnoredMutBorrow (opt_bid, child_av) -> @@ -2417,7 +2417,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) *) craise __FILE__ __LINE__ span "Unreachable" | Abstract (ty, bc) -> { value = ABorrow bc; ty }) - | Some bc0, Some bc1 -> + | Some _, Some _ -> (* With markers, the case where the same borrow is duplicated should now be unreachable. Note, this is due to all shared borrows currently taking different ids, this will not be the case anymore when shared loans will take a unique id instead of a set *) @@ -2480,7 +2480,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | AIgnoredSharedLoan _ -> (* The abstraction has been destructured, so those shouldn't appear *) craise __FILE__ __LINE__ span "Unreachable")) - | Some lc0, Some lc1 -> + | Some _, Some _ -> (* With projection markers, shared loans should not be duplicated *) craise __FILE__ __LINE__ span "Unreachable" | None, None -> craise __FILE__ __LINE__ span "Unreachable" @@ -2503,7 +2503,13 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) avalues := []; (* We recompute the relevant information on the abstraction after phase 1 *) - let { loans; borrows; borrows_loans; loan_to_content; borrow_to_content } = + let { + loans = _; + borrows = _; + borrows_loans; + loan_to_content; + borrow_to_content; + } = compute_merge_abstraction_info span ctx abs_values in diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 2f2dba41..4b5cfb82 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -190,10 +190,10 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) abs_ids; abs_to_borrows; abs_to_loans = _; - abs_to_borrows_loans; + abs_to_borrows_loans = _; borrow_to_abs = _; loan_to_abs; - borrow_loan_to_abs; + borrow_loan_to_abs = _; } = ids_maps in @@ -306,7 +306,6 @@ let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) 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 : AbstractionId.id) : bool = not (AbstractionId.Set.mem id old_ids.aids) in @@ -318,10 +317,10 @@ let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) abs_ids; abs_to_borrows; abs_to_loans; - abs_to_borrows_loans; + abs_to_borrows_loans = _; borrow_to_abs; loan_to_abs; - borrow_loan_to_abs; + borrow_loan_to_abs = _; } = ids_maps in @@ -519,7 +518,7 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) Note that the join matcher doesn't implement match functions for avalues (see the comments in {!MakeJoinMatcher}. *) - let merge_amut_borrows id ty0 pm0 child0 _ty1 pm1 child1 = + let merge_amut_borrows id ty0 _pm0 child0 _ty1 _pm1 child1 = (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; @@ -535,7 +534,7 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) { value; ty } in - let merge_ashared_borrows id ty0 pm0 ty1 pm1 = + let merge_ashared_borrows id ty0 _pm0 ty1 _pm1 = (* Sanity checks *) let _ = let _, ty0, _ = ty_as_ref ty0 in @@ -554,7 +553,7 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) { value; ty } in - let merge_amut_loans id ty0 pm0 child0 _ty1 pm1 child1 = + let merge_amut_loans id ty0 _pm0 child0 _ty1 _pm1 child1 = (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; sanity_check __FILE__ __LINE__ (is_aignored child1.value) span; @@ -565,7 +564,7 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) let value = ALoan (AMutLoan (PNone, id, child)) in { value; ty } in - let merge_ashared_loans ids ty0 pm0 (sv0 : typed_value) child0 _ty1 pm1 + let merge_ashared_loans ids ty0 _pm0 (sv0 : typed_value) child0 _ty1 _pm1 (sv1 : typed_value) child1 = (* Sanity checks *) sanity_check __FILE__ __LINE__ (is_aignored child0.value) span; -- cgit v1.2.3 From 2257d023478cd2fe44a0ff4d67c1c5b7e3b59061 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 14:19:46 +0200 Subject: Add missing reverse when collapsing environment --- compiler/InterpreterBorrows.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 653dea7c..a31d36cd 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2720,8 +2720,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | Some lc1 -> push_avalue (merge_g_loan_contents lc0 lc1))) borrows_loans; - (* We traversed and pushed elements in the same order as the traversal, so we do not need to reverse the list *) - let avalues = !avalues in + let avalues = List.rev !avalues in (* Reorder the avalues. We want the avalues to have the borrows first, then the loans (this structure is more stable when we merge abstractions together, -- cgit v1.2.3 From 2e3d1cdfde3e19af97e0d0fa47f92cfd66c688d9 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 14:25:23 +0200 Subject: Regenerate tests --- tests/coq/arrays/_CoqProject | 2 +- tests/coq/betree/_CoqProject | 12 ++++++------ tests/coq/demo/_CoqProject | 2 +- tests/coq/hashmap/Hashmap_Funs.v | 2 +- tests/coq/hashmap/_CoqProject | 4 ++-- tests/coq/hashmap_on_disk/HashmapMain_Funs.v | 2 +- tests/coq/hashmap_on_disk/_CoqProject | 12 ++++++------ tests/coq/misc/_CoqProject | 24 ++++++++++++------------ tests/coq/traits/_CoqProject | 2 +- tests/fstar/hashmap/Hashmap.Funs.fst | 2 +- tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst | 2 +- tests/lean/Hashmap/Funs.lean | 2 +- tests/lean/HashmapMain/Funs.lean | 2 +- 13 files changed, 35 insertions(+), 35 deletions(-) diff --git a/tests/coq/arrays/_CoqProject b/tests/coq/arrays/_CoqProject index a4e82408..4ccc7663 100644 --- a/tests/coq/arrays/_CoqProject +++ b/tests/coq/arrays/_CoqProject @@ -3,5 +3,5 @@ -arg -w -arg all -Arrays.v +Arrays.v Primitives.v diff --git a/tests/coq/betree/_CoqProject b/tests/coq/betree/_CoqProject index b14bed66..2ba444c2 100644 --- a/tests/coq/betree/_CoqProject +++ b/tests/coq/betree/_CoqProject @@ -3,10 +3,10 @@ -arg -w -arg all -BetreeMain_TypesExternal_Template.v -BetreeMain_Types.v +BetreeMain_Funs.v +BetreeMain_FunsExternal.v +BetreeMain_FunsExternal_Template.v +BetreeMain_Types.v +BetreeMain_TypesExternal.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/demo/_CoqProject b/tests/coq/demo/_CoqProject index 62554699..67e4f2a4 100644 --- a/tests/coq/demo/_CoqProject +++ b/tests/coq/demo/_CoqProject @@ -3,5 +3,5 @@ -arg -w -arg all -Demo.v +Demo.v Primitives.v diff --git a/tests/coq/hashmap/Hashmap_Funs.v b/tests/coq/hashmap/Hashmap_Funs.v index 6a4f8e99..1f2b2b22 100644 --- a/tests/coq/hashmap/Hashmap_Funs.v +++ b/tests/coq/hashmap/Hashmap_Funs.v @@ -211,7 +211,7 @@ Definition hashMap_move_elements_from_list Fixpoint hashMap_move_elements_loop (T : Type) (n : nat) (ntable : HashMap_t T) (slots : alloc_vec_Vec (List_t T)) (i : usize) : - result ((alloc_vec_Vec (List_t T)) * (HashMap_t T)) + result ((HashMap_t T) * (alloc_vec_Vec (List_t T))) := match n with | O => Fail_ OutOfFuel diff --git a/tests/coq/hashmap/_CoqProject b/tests/coq/hashmap/_CoqProject index 7f80afbf..5d98662a 100644 --- a/tests/coq/hashmap/_CoqProject +++ b/tests/coq/hashmap/_CoqProject @@ -3,6 +3,6 @@ -arg -w -arg all -Hashmap_Types.v +Hashmap_Funs.v +Hashmap_Types.v Primitives.v -Hashmap_Funs.v diff --git a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v index fd7f7f16..facd84ea 100644 --- a/tests/coq/hashmap_on_disk/HashmapMain_Funs.v +++ b/tests/coq/hashmap_on_disk/HashmapMain_Funs.v @@ -225,7 +225,7 @@ Definition hashmap_HashMap_move_elements_from_list 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 ((alloc_vec_Vec (hashmap_List_t T)) * (hashmap_HashMap_t T)) + result ((hashmap_HashMap_t T) * (alloc_vec_Vec (hashmap_List_t T))) := match n with | O => Fail_ OutOfFuel diff --git a/tests/coq/hashmap_on_disk/_CoqProject b/tests/coq/hashmap_on_disk/_CoqProject index d73541d9..837bbbaf 100644 --- a/tests/coq/hashmap_on_disk/_CoqProject +++ b/tests/coq/hashmap_on_disk/_CoqProject @@ -3,10 +3,10 @@ -arg -w -arg all -HashmapMain_Types.v -HashmapMain_FunsExternal_Template.v +HashmapMain_Funs.v +HashmapMain_FunsExternal.v +HashmapMain_FunsExternal_Template.v +HashmapMain_Types.v +HashmapMain_TypesExternal.v +HashmapMain_TypesExternal_Template.v Primitives.v -HashmapMain_Funs.v -HashmapMain_TypesExternal.v -HashmapMain_FunsExternal.v -HashmapMain_TypesExternal_Template.v diff --git a/tests/coq/misc/_CoqProject b/tests/coq/misc/_CoqProject index 308de4f4..bffb6699 100644 --- a/tests/coq/misc/_CoqProject +++ b/tests/coq/misc/_CoqProject @@ -3,16 +3,16 @@ -arg -w -arg all -External_FunsExternal_Template.v -Loops.v -External_Types.v +Bitwise.v +Constants.v +External_Funs.v +External_FunsExternal.v +External_FunsExternal_Template.v +External_Types.v +External_TypesExternal.v +External_TypesExternal_Template.v +Loops.v +NoNestedBorrows.v +Paper.v +PoloniusList.v Primitives.v -External_Funs.v -External_TypesExternal.v -Constants.v -PoloniusList.v -NoNestedBorrows.v -External_FunsExternal.v -Bitwise.v -External_TypesExternal_Template.v -Paper.v diff --git a/tests/coq/traits/_CoqProject b/tests/coq/traits/_CoqProject index 5b6199fc..14a91aa8 100644 --- a/tests/coq/traits/_CoqProject +++ b/tests/coq/traits/_CoqProject @@ -3,5 +3,5 @@ -arg -w -arg all +Primitives.v Traits.v -Primitives.v diff --git a/tests/fstar/hashmap/Hashmap.Funs.fst b/tests/fstar/hashmap/Hashmap.Funs.fst index 38be12ac..2aca9fbe 100644 --- a/tests/fstar/hashmap/Hashmap.Funs.fst +++ b/tests/fstar/hashmap/Hashmap.Funs.fst @@ -158,7 +158,7 @@ let hashMap_move_elements_from_list let rec hashMap_move_elements_loop (t : Type0) (ntable : hashMap_t t) (slots : alloc_vec_Vec (list_t t)) (i : usize) : - Tot (result ((alloc_vec_Vec (list_t t)) & (hashMap_t t))) + Tot (result ((hashMap_t t) & (alloc_vec_Vec (list_t t)))) (decreases (hashMap_move_elements_loop_decreases t ntable slots i)) = let i1 = alloc_vec_Vec_len (list_t t) slots in diff --git a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst index cf3ae858..4a032207 100644 --- a/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst +++ b/tests/fstar/hashmap_on_disk/HashmapMain.Funs.fst @@ -167,7 +167,7 @@ let hashmap_HashMap_move_elements_from_list 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 ((alloc_vec_Vec (hashmap_List_t t)) & (hashmap_HashMap_t t))) + 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 i1 = alloc_vec_Vec_len (hashmap_List_t t) slots in diff --git a/tests/lean/Hashmap/Funs.lean b/tests/lean/Hashmap/Funs.lean index 17ad26f7..cb11e5cf 100644 --- a/tests/lean/Hashmap/Funs.lean +++ b/tests/lean/Hashmap/Funs.lean @@ -157,7 +157,7 @@ def HashMap.move_elements_from_list divergent def HashMap.move_elements_loop (T : Type) (ntable : HashMap T) (slots : alloc.vec.Vec (List T)) (i : Usize) : - Result ((alloc.vec.Vec (List T)) × (HashMap T)) + Result ((HashMap T) × (alloc.vec.Vec (List T))) := let i1 := alloc.vec.Vec.len (List T) slots if i < i1 diff --git a/tests/lean/HashmapMain/Funs.lean b/tests/lean/HashmapMain/Funs.lean index 56039741..e27305b1 100644 --- a/tests/lean/HashmapMain/Funs.lean +++ b/tests/lean/HashmapMain/Funs.lean @@ -167,7 +167,7 @@ def hashmap.HashMap.move_elements_from_list divergent def hashmap.HashMap.move_elements_loop (T : Type) (ntable : hashmap.HashMap T) (slots : alloc.vec.Vec (hashmap.List T)) (i : Usize) : - Result ((alloc.vec.Vec (hashmap.List T)) × (hashmap.HashMap T)) + Result ((hashmap.HashMap T) × (alloc.vec.Vec (hashmap.List T))) := let i1 := alloc.vec.Vec.len (hashmap.List T) slots if i < i1 -- cgit v1.2.3 From 3598da14b7de6452b03e98e701996a8b6d4d5d38 Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 14:46:12 +0200 Subject: Add documentation to collapse --- compiler/InterpreterLoopsJoinCtxs.ml | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 4b5cfb82..930bffac 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -292,7 +292,33 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) (* Reduce_ctx can only be called in a context with no markers *) let reduce_ctx = reduce_ctx_with_markers None -(* TODO Adapt and comment *) +(* Collapse an environment + + This is the second part of a join, where we attempt to simplify and remove all projection markers. + This function is called after reducing the environments, and attempting to simplify all the pairs + of borrows and loans. + + We traverse all abstractions, and merge abstractions when they contain the same element, + but with dual markers (i.e., PLeft and PRight). + + For instance, if we have the abstractions + + abs@0 { | MB l0 _ |, ML l1 } + abs@1 { ︙MB l0 _ ︙, ML l2 } + + we will merge abs@0 and abs@1 into a new abstraction abs@2, removing the marker for duplicated elements, + and taking the join of the remaining elements + + abs@2 { MB l0 _, ML l1, ML l2 } + + Rem.: Doing this might introduce new pairs of borrow/loans to be merged in different abstractions: in the example above, + this could occur if there was another abstraction in the context containing ML l0, which would need to be simplified through + a further reduce. + It is unclear whether this can happen in practice. If so, a solution would be to preprocess the environments when doing + a join: while not in the current formalism, it is sound to split an element with no markers into a duplicated pair of the + same element with left and right markers. Doing this before reduce would allow to reduce all possible pairs of borrow/loans, + before finally collapsing and removing all markers. +*) let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = -- cgit v1.2.3 From f5a7a0ceccfeec0dd8801d5a874cb66c1a356f8f Mon Sep 17 00:00:00 2001 From: Aymeric Fromherz Date: Fri, 31 May 2024 15:00:23 +0200 Subject: format --- compiler/InterpreterLoopsJoinCtxs.ml | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 930bffac..b58d1b3e 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -294,30 +294,30 @@ let reduce_ctx = reduce_ctx_with_markers None (* Collapse an environment - This is the second part of a join, where we attempt to simplify and remove all projection markers. - This function is called after reducing the environments, and attempting to simplify all the pairs - of borrows and loans. + This is the second part of a join, where we attempt to simplify and remove all projection markers. + This function is called after reducing the environments, and attempting to simplify all the pairs + of borrows and loans. - We traverse all abstractions, and merge abstractions when they contain the same element, - but with dual markers (i.e., PLeft and PRight). + We traverse all abstractions, and merge abstractions when they contain the same element, + but with dual markers (i.e., PLeft and PRight). - For instance, if we have the abstractions + For instance, if we have the abstractions - abs@0 { | MB l0 _ |, ML l1 } - abs@1 { ︙MB l0 _ ︙, ML l2 } + abs@0 { | MB l0 _ |, ML l1 } + abs@1 { ︙MB l0 _ ︙, ML l2 } - we will merge abs@0 and abs@1 into a new abstraction abs@2, removing the marker for duplicated elements, - and taking the join of the remaining elements + we will merge abs@0 and abs@1 into a new abstraction abs@2, removing the marker for duplicated elements, + and taking the join of the remaining elements - abs@2 { MB l0 _, ML l1, ML l2 } + abs@2 { MB l0 _, ML l1, ML l2 } - Rem.: Doing this might introduce new pairs of borrow/loans to be merged in different abstractions: in the example above, - this could occur if there was another abstraction in the context containing ML l0, which would need to be simplified through - a further reduce. - It is unclear whether this can happen in practice. If so, a solution would be to preprocess the environments when doing - a join: while not in the current formalism, it is sound to split an element with no markers into a duplicated pair of the - same element with left and right markers. Doing this before reduce would allow to reduce all possible pairs of borrow/loans, - before finally collapsing and removing all markers. + Rem.: Doing this might introduce new pairs of borrow/loans to be merged in different abstractions: in the example above, + this could occur if there was another abstraction in the context containing ML l0, which would need to be simplified through + a further reduce. + It is unclear whether this can happen in practice. If so, a solution would be to preprocess the environments when doing + a join: while not in the current formalism, it is sound to split an element with no markers into a duplicated pair of the + same element with left and right markers. Doing this before reduce would allow to reduce all possible pairs of borrow/loans, + before finally collapsing and removing all markers. *) let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) -- cgit v1.2.3 From 0ef06470110e11835ca394b96035ea44cb881a07 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 11:48:49 +0200 Subject: Update some comments --- compiler/Substitute.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/Substitute.ml b/compiler/Substitute.ml index 37ef6987..6ea460db 100644 --- a/compiler/Substitute.ml +++ b/compiler/Substitute.ml @@ -138,10 +138,10 @@ let subst_ids_visitor (r_subst : RegionId.id -> RegionId.id) method! visit_loan_id _ bid = bsubst bid method! visit_symbolic_value_id _ id = ssubst id - (** We *do* visit span-values *) + (** We *do* visit meta-values *) method! visit_msymbolic_value env sv = self#visit_symbolic_value env sv - (** We *do* visit span-values *) + (** We *do* visit meta-values *) method! visit_mvalue env v = self#visit_typed_value env v method! visit_abstraction_id _ id = asubst id -- cgit v1.2.3 From 18623d7ee894a8e21bca9ef58fb4087cb4be558b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 12:08:36 +0200 Subject: Make minor modifications --- compiler/InterpreterBorrowsCore.ml | 20 ++++++++++---------- compiler/InterpreterPaths.ml | 2 +- compiler/Invariants.ml | 21 +++++++++++++-------- compiler/Print.ml | 1 + 4 files changed, 25 insertions(+), 19 deletions(-) diff --git a/compiler/InterpreterBorrowsCore.ml b/compiler/InterpreterBorrowsCore.ml index 3bef7b30..0469d58e 100644 --- a/compiler/InterpreterBorrowsCore.ml +++ b/compiler/InterpreterBorrowsCore.ml @@ -256,12 +256,12 @@ let lookup_loan_opt (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) method! visit_aloan_content env lc = match lc with | AMutLoan (pm, bid, av) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then raise (FoundGLoanContent (Abstract lc)) else super#visit_AMutLoan env pm bid av | ASharedLoan (pm, bids, v, av) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if BorrowId.Set.mem l bids then raise (FoundGLoanContent (Abstract lc)) @@ -401,11 +401,11 @@ let update_aloan (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) method! visit_aloan_content env lc = match lc with | AMutLoan (pm, bid, av) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then update () else super#visit_AMutLoan env pm bid av | ASharedLoan (pm, bids, v, av) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if BorrowId.Set.mem l bids then update () else super#visit_ASharedLoan env pm bids v av @@ -462,12 +462,12 @@ let lookup_borrow_opt (span : Meta.span) (ek : exploration_kind) method! visit_aborrow_content env bc = match bc with | AMutBorrow (pm, bid, av) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then raise (FoundGBorrowContent (Abstract bc)) else super#visit_AMutBorrow env pm bid av | ASharedBorrow (pm, bid) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then raise (FoundGBorrowContent (Abstract bc)) else super#visit_ASharedBorrow env pm bid @@ -584,12 +584,12 @@ let update_aborrow (span : Meta.span) (ek : exploration_kind) (l : BorrowId.id) method! visit_ABorrow env bc = match bc with | AMutBorrow (pm, bid, av) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then update () else ABorrow (super#visit_AMutBorrow env pm bid av) | ASharedBorrow (pm, bid) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; if bid = l then update () else ABorrow (super#visit_ASharedBorrow env pm bid) @@ -1199,11 +1199,11 @@ let get_first_non_ignored_aloan_in_abstraction (span : Meta.span) (abs : abs) : method! visit_aloan_content env lc = match lc with | AMutLoan (pm, bid, _) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; raise (FoundBorrowIds (Borrow bid)) | ASharedLoan (pm, bids, _, _) -> - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; raise (FoundBorrowIds (Borrows bids)) | AEndedMutLoan { given_back = _; child = _; given_back_span = _ } diff --git a/compiler/InterpreterPaths.ml b/compiler/InterpreterPaths.ml index a74017d1..b2de3b22 100644 --- a/compiler/InterpreterPaths.ml +++ b/compiler/InterpreterPaths.ml @@ -198,7 +198,7 @@ let rec access_projection (span : Meta.span) (access : projection_access) craise __FILE__ __LINE__ span "Expected a shared (abstraction) loan" | _, Abstract (ASharedLoan (pm, bids, sv, _av)) -> ( - (* Sanity check: markers can only appear when we're doing a join *) + (* Sanity check: projection markers can only appear when we're doing a join *) sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Explore the shared value *) match access_projection span access ctx update p' sv with diff --git a/compiler/Invariants.ml b/compiler/Invariants.ml index fc882423..50e6e87f 100644 --- a/compiler/Invariants.ml +++ b/compiler/Invariants.ml @@ -497,14 +497,14 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = | VBorrow bc, TRef (_, ref_ty, rkind) -> ( match (bc, rkind) with | VSharedBorrow bid, RShared | VReservedMutBorrow bid, RMut -> ( - (* Lookup the borrowed value to check it has the proper type *) + (* Lookup the borrowed value to check it has the proper type. + Note that we ignore the marker: we will check it when + checking the loan itself. *) let _, glc = lookup_loan span ek_all bid ctx in match glc with - | Concrete (VSharedLoan (_, sv)) -> + | Concrete (VSharedLoan (_, sv)) + | Abstract (ASharedLoan (_, _, sv, _)) -> sanity_check __FILE__ __LINE__ (sv.ty = ref_ty) span - | Abstract (ASharedLoan (pm, _, sv, _)) -> - sanity_check __FILE__ __LINE__ (sv.ty = ref_ty) span; - sanity_check __FILE__ __LINE__ (pm = PNone) span | _ -> craise __FILE__ __LINE__ span "Inconsistent context") | VMutBorrow (_, bv), RMut -> sanity_check __FILE__ __LINE__ @@ -517,12 +517,13 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = | VSharedLoan (_, sv) -> sanity_check __FILE__ __LINE__ (sv.ty = ty) span | VMutLoan bid -> ( - (* Lookup the borrowed value to check it has the proper type *) + (* Lookup the borrowed value to check it has the proper type. *) let glc = lookup_borrow span ek_all bid ctx in match glc with | Concrete (VMutBorrow (_, bv)) -> sanity_check __FILE__ __LINE__ (bv.ty = ty) span | Abstract (AMutBorrow (pm, _, sv)) -> + (* The marker check is redundant, but doesn't cost much *) sanity_check __FILE__ __LINE__ (pm = PNone) span; sanity_check __FILE__ __LINE__ (Substitute.erase_regions sv.ty = ty) @@ -655,7 +656,9 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = = Substitute.erase_regions borrowed_aty) span | _ -> craise __FILE__ __LINE__ span "Inconsistent context") - | AMutLoan (_, _, _) -> internal_error __FILE__ __LINE__ span + | AMutLoan (_, _, _) -> + (* We get there if the projection marker is not [PNone] *) + internal_error __FILE__ __LINE__ span | AIgnoredMutLoan (None, child_av) -> let borrowed_aty = aloan_get_expected_child_type aty in sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) span @@ -667,7 +670,9 @@ let check_typing_invariant (span : Meta.span) (ctx : eval_ctx) : unit = span; (* TODO: the type of aloans doesn't make sense, see above *) sanity_check __FILE__ __LINE__ (child_av.ty = borrowed_aty) span - | ASharedLoan (_, _, _, _) -> internal_error __FILE__ __LINE__ span + | ASharedLoan (_, _, _, _) -> + (* We get there if the projection marker is not [PNone] *) + internal_error __FILE__ __LINE__ span | AEndedMutLoan { given_back; child; given_back_span = _ } | AEndedIgnoredMutLoan { given_back; child; given_back_span = _ } -> let borrowed_aty = aloan_get_expected_child_type aty in diff --git a/compiler/Print.ml b/compiler/Print.ml index 9a3a7d16..7495d6bf 100644 --- a/compiler/Print.ml +++ b/compiler/Print.ml @@ -148,6 +148,7 @@ module Values = struct | AEndedProjBorrows _mv -> "_" | AIgnoredProjBorrows -> "_" + (** Wrap a value inside its marker, if there is one *) let add_proj_marker (pm : proj_marker) (s : string) : string = match pm with | PNone -> s -- cgit v1.2.3 From 9aa328a70011d2784a943830bffabc600caba4ab Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 12:52:04 +0200 Subject: Cleanup a bit --- compiler/InterpreterLoopsCore.ml | 16 ++-- compiler/InterpreterLoopsJoinCtxs.ml | 16 +--- compiler/InterpreterLoopsMatchCtxs.ml | 142 +++++++++++++++++---------------- compiler/InterpreterLoopsMatchCtxs.mli | 4 +- 4 files changed, 87 insertions(+), 91 deletions(-) diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 8d6caac4..4149b19e 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -26,21 +26,21 @@ type ctx_or_update = (eval_ctx, updt_env_kind) result (** Union Find *) module UF = UnionFind.Make (UnionFind.StoreMap) -(** A small utility - - - Rem.: some environments may be ill-formed (they may contain several times - the same loan or borrow - this happens for instance when merging - environments). This is the reason why we use sets in some places (for - instance, [borrow_to_abs] maps to a *set* of ids). +(** A small utility. + + Remark: we use projection markers, meaning we compute maps from/to + pairs of (projection marker, borrow/loan id). This allows us to use + this utility during a reduce phase (when we simplify the environment + and all markers should be [PNone]) as well as during a collapse (where + we actually have markers because we performed a join and are progressively + transforming the environment to get rid of those markers). *) type abs_borrows_loans_maps = { abs_ids : AbstractionId.id list; abs_to_borrows : MarkerBorrowId.Set.t AbstractionId.Map.t; abs_to_loans : MarkerBorrowId.Set.t AbstractionId.Map.t; - abs_to_borrows_loans : MarkerBorrowId.Set.t AbstractionId.Map.t; borrow_to_abs : AbstractionId.Set.t MarkerBorrowId.Map.t; loan_to_abs : AbstractionId.Set.t MarkerBorrowId.Map.t; - borrow_loan_to_abs : AbstractionId.Set.t MarkerBorrowId.Map.t; } (** See {!module:Aeneas.InterpreterLoopsMatchCtxs.MakeMatcher} and [Matcher]. diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index b58d1b3e..ce874992 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -185,15 +185,13 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = compute_abs_borrows_loans_maps span true explore env in + let ids_maps = compute_abs_borrows_loans_maps span explore env in let { abs_ids; abs_to_borrows; abs_to_loans = _; - abs_to_borrows_loans = _; borrow_to_abs = _; loan_to_abs; - borrow_loan_to_abs = _; } = ids_maps in @@ -338,16 +336,8 @@ let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) (* Explore all the *new* abstractions, and compute various maps *) let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = compute_abs_borrows_loans_maps span false explore ctx0.env in - let { - abs_ids; - abs_to_borrows; - abs_to_loans; - abs_to_borrows_loans = _; - borrow_to_abs; - loan_to_abs; - borrow_loan_to_abs = _; - } = + let ids_maps = compute_abs_borrows_loans_maps span explore ctx0.env in + let { abs_ids; abs_to_borrows; abs_to_loans; borrow_to_abs; loan_to_abs } = ids_maps in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index 713f462b..bc39d5ec 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -20,32 +20,28 @@ module S = SynthesizeSymbolic (** The local logger *) let log = Logging.loops_match_ctxs_log -let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) - (explore : abs -> bool) (env : env) : abs_borrows_loans_maps = +let compute_abs_borrows_loans_maps (span : Meta.span) (explore : abs -> bool) + (env : env) : abs_borrows_loans_maps = let abs_ids = ref [] 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 MarkerBorrowId.Map.empty in let loan_to_abs = ref MarkerBorrowId.Map.empty in - let borrow_loan_to_abs = ref MarkerBorrowId.Map.empty in let module R (M : Collections.Map) (S : Collections.Set) = struct (* [check_singleton_sets]: check that the mapping maps to a singleton. - [check_not_already_registered]: check if the mapping was not already registered. + We need this because to tweak the behavior of the sanity checks because + of the following cases: + - when computing the map from borrow ids (with marker) to the region + abstractions they belong to, the marked borrow ids can map to a single + region abstraction, i.e., to a singleton set of region abstraction ids + - however, when computing the mapping from region abstractions to + the borrow ids they contain, this time we do map abstraction ids + to sets which can compute strictly more than one value *) - let register_mapping (check_singleton_sets : bool) - (check_not_already_registered : bool) (map : S.t M.t ref) (id0 : M.key) - (id1 : S.elt) : unit = - (* Sanity check *) - (if check_singleton_sets || check_not_already_registered then - match M.find_opt id0 !map with - | None -> () - | Some set -> - sanity_check __FILE__ __LINE__ - ((not check_not_already_registered) || not (S.mem id1 set)) - span); + let register_mapping (check_singleton_sets : bool) (map : S.t M.t ref) + (id0 : M.key) (id1 : S.elt) : unit = (* Update the mapping *) map := M.update id0 @@ -53,11 +49,11 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) match ids with | None -> Some (S.singleton id1) | Some ids -> - (* Sanity check *) + (* Check that we are allowed to map id0 to a set which is not + a singleton *) sanity_check __FILE__ __LINE__ (not check_singleton_sets) span; - sanity_check __FILE__ __LINE__ - ((not check_not_already_registered) || not (S.mem id1 ids)) - span; + (* Check that the mapping was not already registered *) + sanity_check __FILE__ __LINE__ (not (S.mem id1 ids)) span; (* Update *) Some (S.add id1 ids)) !map @@ -65,20 +61,13 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) let module RAbsBorrow = R (AbstractionId.Map) (MarkerBorrowId.Set) in let module RBorrowAbs = R (MarkerBorrowId.Map) (AbstractionId.Set) in let register_borrow_id abs_id pm bid = - RAbsBorrow.register_mapping false no_duplicates abs_to_borrows abs_id - (pm, bid); - RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id (pm, bid); - RBorrowAbs.register_mapping no_duplicates no_duplicates borrow_to_abs - (pm, bid) abs_id; - RBorrowAbs.register_mapping false false borrow_loan_to_abs (pm, bid) abs_id + RAbsBorrow.register_mapping false abs_to_borrows abs_id (pm, bid); + RBorrowAbs.register_mapping true borrow_to_abs (pm, bid) abs_id in let register_loan_id abs_id pm bid = - RAbsBorrow.register_mapping false no_duplicates abs_to_loans abs_id (pm, bid); - RAbsBorrow.register_mapping false false abs_to_borrows_loans abs_id (pm, bid); - RBorrowAbs.register_mapping no_duplicates no_duplicates loan_to_abs - (pm, bid) abs_id; - RBorrowAbs.register_mapping false false borrow_loan_to_abs (pm, bid) abs_id + RAbsBorrow.register_mapping false abs_to_loans abs_id (pm, bid); + RBorrowAbs.register_mapping true loan_to_abs (pm, bid) abs_id in let explore_abs = @@ -87,10 +76,19 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) (** Make sure we don't register the ignored ids *) method! visit_aloan_content (abs_id, pm) lc = + sanity_check __FILE__ __LINE__ (pm = PNone) span; match lc with - | AMutLoan (pm, _, _) | ASharedLoan (pm, _, _, _) -> - (* Process those normally *) - super#visit_aloan_content (abs_id, pm) lc + | AMutLoan (npm, lid, child) -> + (* Add the current marker when visiting the loan id *) + self#visit_loan_id (abs_id, npm) lid; + (* Recurse with the old marker *) + super#visit_typed_avalue (abs_id, pm) child + | ASharedLoan (npm, lids, sv, child) -> + (* Add the current marker when visiting the loan ids and the shared value *) + self#visit_loan_id_set (abs_id, npm) lids; + self#visit_typed_value (abs_id, npm) sv; + (* Recurse with the old marker *) + self#visit_typed_avalue (abs_id, pm) child | AIgnoredMutLoan (_, child) | AEndedIgnoredMutLoan { child; given_back = _; given_back_span = _ } | AIgnoredSharedLoan child -> @@ -102,10 +100,16 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) (** Make sure we don't register the ignored ids *) method! visit_aborrow_content (abs_id, pm) bc = + sanity_check __FILE__ __LINE__ (pm = PNone) span; match bc with - | AMutBorrow (pm, _, _) | ASharedBorrow (pm, _) -> - (* Add the current marker, and process them recursively *) - super#visit_aborrow_content (abs_id, pm) bc + | AMutBorrow (npm, bid, child) -> + (* Add the current marker when visiting the borrow id *) + self#visit_borrow_id (abs_id, npm) bid; + (* Recurse with the old marker *) + self#visit_typed_avalue (abs_id, pm) child + | ASharedBorrow (npm, bid) -> + (* Add the current marker when visiting the borrow id *) + self#visit_borrow_id (abs_id, npm) bid | AProjSharedBorrow _ -> sanity_check __FILE__ __LINE__ (pm = PNone) span; (* Process those normally *) @@ -147,10 +151,8 @@ let compute_abs_borrows_loans_maps (span : Meta.span) (no_duplicates : bool) abs_ids = !abs_ids; abs_to_borrows = !abs_to_borrows; abs_to_loans = !abs_to_loans; - abs_to_borrows_loans = !abs_to_borrows_loans; borrow_to_abs = !borrow_to_abs; loan_to_abs = !loan_to_abs; - borrow_loan_to_abs = !borrow_loan_to_abs; } (** Match two types during a join. @@ -557,7 +559,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct an abstraction: {[ - { MB bid0, ML nbid } // where nbid fresh + { MB bid0, ML bid' } // where bid' fresh ]} and we use bid' for the borrow id that we return. @@ -565,7 +567,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct We do this because we want to make sure that, whenever a mutably borrowed value is modified in a loop iteration, then there is a fresh abstraction between this borrowed value and the fixed - abstractions. + abstractions (this is tantamount to introducing a reborrow). Example: ======== @@ -596,6 +598,15 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct to say [unit]) while the backward loop function gives back a new value for [v] (i.e., a new symbolic value which will replace [s0]). + By introducing the fresh region abstraction wet get: + {[ + abs'0 { ML l0 } // input abstraction + abs'1 { MB l0, ML l1 } // fresh abstraction + v -> MB l1 s1 + i -> 0 + ]} + + In the future, we will also compute joins at the *loop exits*: when we do so, we won't introduce reborrows like above: the forward loop function will update [v], while the backward loop function will return nothing. @@ -613,7 +624,8 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct let kind = RMut in let bv_ty = bv.ty in - sanity_check __FILE__ __LINE__ (ty_no_regions bv_ty) span; + cassert __FILE__ __LINE__ (ty_no_regions bv_ty) span + "Nested borrows are not supported yet"; let borrow_ty = mk_ref_ty (RFVar rid) bv_ty kind in let borrow_av = @@ -651,9 +663,10 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (nbid, bv)) else (* We replace bid0 and bid1 with a fresh borrow id, and introduce - an abstraction which links all of them: + an abstraction which links all of them. This time we have to introduce + markers: {[ - { MB bid0, MB bid1, ML bid2 } + { |MB bid0|, ︙MB bid1︙, ML bid2 } ]} *) let rid = fresh_region_id () in @@ -761,24 +774,16 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct (* 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. *) let type_infos = ctx0.type_ctx.type_infos in - cassert __FILE__ __LINE__ + sanity_check __FILE__ __LINE__ (not (ty_has_borrows type_infos sv.sv_ty)) - span - "Check that:\n\ - \ - there are no borrows in the symbolic value\n\ - \ - there are no borrows in the \"regular\" value\n\ - \ If there are loans in the regular value, raise an exception."; - cassert __FILE__ __LINE__ + span; + sanity_check __FILE__ __LINE__ (not (ValuesUtils.value_has_borrows type_infos v.value)) - span - "Check that:\n\ - \ - there are no borrows in the symbolic value\n\ - \ - there are no borrows in the \"regular\" value\n\ - \ If there are loans in the regular value, raise an exception."; + span; let value_is_left = not left in + (* If there are loans in the regular value, raise an exception. *) (match InterpreterBorrowsCore.get_first_loan_in_value v with | None -> () | Some (VSharedLoan (ids, _)) -> @@ -798,13 +803,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct then mk_bottom span sv.sv_ty else mk_fresh_symbolic_typed_value span sv.sv_ty - let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) (left : bool) - (v : typed_value) : typed_value = + let match_bottom_with_other (ctx0 : eval_ctx) (ctx1 : eval_ctx) + (bottom_is_left : bool) (v : typed_value) : typed_value = + let value_is_left = not bottom_is_left in (* If there are outer loans in the non-bottom value, raise an exception. Otherwise, convert it to an abstraction and return [Bottom]. *) let with_borrows = false in - let value_is_left = not left in match InterpreterBorrowsCore.get_first_outer_loan_or_borrow_in_value with_borrows v @@ -821,8 +826,6 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct if value_is_left then raise (ValueMatchFailure (LoanInLeft id)) else raise (ValueMatchFailure (LoanInRight id))) | None -> - (* *) - (* Convert the value to an abstraction *) let abs_kind : abs_kind = Loop (S.loop_id, None, LoopSynthInput) in let can_end = true in @@ -833,16 +836,13 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct destructure_shared_values ctx v in (* Add a marker to the abstraction indicating the provenance of the value *) + let pm = if value_is_left then PLeft else PRight in let absl = List.map (fun abs -> { abs with - avalues = - List.map - (add_marker_avalue span ctx0 - (if value_is_left then PLeft else PRight)) - abs.avalues; + avalues = List.map (add_marker_avalue span ctx0 pm) abs.avalues; }) absl in @@ -1246,6 +1246,8 @@ struct let match_ashared_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 pm0 bid0 _ty1 pm1 bid1 ty = + (* We are checking whether that two environments are equivalent: + there shouldn't be any projection markers *) sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let bid = match_borrow_id bid0 bid1 in let value = ABorrow (ASharedBorrow (PNone, bid)) in @@ -1253,6 +1255,8 @@ struct let match_amut_borrows (_ : eval_ctx) (_ : eval_ctx) _ty0 pm0 bid0 _av0 _ty1 pm1 bid1 _av1 ty av = + (* We are checking whether that two environments are equivalent: + there shouldn't be any projection markers *) sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let bid = match_borrow_id bid0 bid1 in let value = ABorrow (AMutBorrow (PNone, bid, av)) in @@ -1260,6 +1264,8 @@ struct let match_ashared_loans (_ : eval_ctx) (_ : eval_ctx) _ty0 pm0 ids0 _v0 _av0 _ty1 pm1 ids1 _v1 _av1 ty v av = + (* We are checking whether that two environments are equivalent: + there shouldn't be any projection markers *) sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; let bids = match_loan_ids ids0 ids1 in let value = ALoan (ASharedLoan (PNone, bids, v, av)) in @@ -1267,6 +1273,8 @@ struct let match_amut_loans (ctx0 : eval_ctx) (ctx1 : eval_ctx) _ty0 pm0 id0 _av0 _ty1 pm1 id1 _av1 ty av = + (* We are checking whether that two environments are equivalent: + there shouldn't be any projection markers *) sanity_check __FILE__ __LINE__ (pm0 = PNone && pm1 = PNone) span; log#ldebug (lazy diff --git a/compiler/InterpreterLoopsMatchCtxs.mli b/compiler/InterpreterLoopsMatchCtxs.mli index 7d214cb6..cd807358 100644 --- a/compiler/InterpreterLoopsMatchCtxs.mli +++ b/compiler/InterpreterLoopsMatchCtxs.mli @@ -13,13 +13,11 @@ open InterpreterLoopsCore (** Compute various maps linking the abstractions and the borrows/loans they contain. Parameters: - - [no_duplicates]: checks that borrows/loans are not referenced more than once - (see the documentation for {!type:InterpreterLoopsCore.abs_borrows_loans_maps}). - [explore]: this function is used to filter abstractions. - [env] *) val compute_abs_borrows_loans_maps : - Meta.span -> bool -> (abs -> bool) -> env -> abs_borrows_loans_maps + Meta.span -> (abs -> bool) -> env -> abs_borrows_loans_maps (** Generic functor to implement matching functions between values, environments, etc. -- cgit v1.2.3 From ec1e958fd7bd82a4e931e1dc7acb79eeccef92ac Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 14:30:31 +0200 Subject: Factor out some code and update some comments --- compiler/InterpreterBorrows.ml | 60 +++++++++++ compiler/InterpreterBorrows.mli | 17 +++ compiler/InterpreterLoopsFixedPoint.ml | 76 ++------------ compiler/InterpreterLoopsJoinCtxs.ml | 186 ++++++++++++++++----------------- 4 files changed, 173 insertions(+), 166 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index a31d36cd..48292181 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2814,3 +2814,63 @@ let merge_into_abstraction (span : Meta.span) (abs_kind : abs_kind) (* Return *) (ctx, nabs.abs_id) + +let reorder_loans_borrows_in_fresh_abs (span : Meta.span) (allow_markers : bool) + (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = + let reorder_in_fresh_abs (abs : abs) : abs = + (* Split between the loans and borrows *) + let is_borrow (av : typed_avalue) : bool = + match av.value with + | ABorrow _ -> true + | ALoan _ -> false + | _ -> craise __FILE__ __LINE__ span "Unexpected" + in + let aborrows, aloans = List.partition is_borrow abs.avalues in + + (* Reoder the borrows, and the loans. + + After experimenting, it seems that a good way of reordering the loans + 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). + + This is actually not as arbitrary as it might seem, because the ids give + us the order in which we introduced those borrows/loans. + *) + let get_borrow_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ABorrow (AMutBorrow (pm, bid, _) | ASharedBorrow (pm, bid)) -> + sanity_check __FILE__ __LINE__ (allow_markers || pm = PNone) span; + bid + | _ -> craise __FILE__ __LINE__ span "Unexpected" + in + let get_loan_id (av : typed_avalue) : BorrowId.id = + match av.value with + | ALoan (AMutLoan (pm, lid, _)) -> + sanity_check __FILE__ __LINE__ (allow_markers || pm = PNone) span; + lid + | ALoan (ASharedLoan (pm, lids, _, _)) -> + sanity_check __FILE__ __LINE__ (allow_markers || pm = PNone) span; + BorrowId.Set.min_elt lids + | _ -> craise __FILE__ __LINE__ span "Unexpected" + in + (* We use ordered maps to reorder the borrows and loans *) + let reorder (get_bid : typed_avalue -> BorrowId.id) + (values : typed_avalue list) : typed_avalue list = + List.map snd + (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 avalues } + in + + 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 = env_map_abs reorder_in_abs ctx.env in + + { ctx with env } diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index c119311f..0bc2bfab 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -269,3 +269,20 @@ val merge_into_abstraction : AbstractionId.id -> AbstractionId.id -> eval_ctx * AbstractionId.id + +(** Reorder the loans and borrows in the fresh abstractions. + + We do this in order to enforce some structure in the environments: this + allows us to find fixed-points. Note that this function needs to be + called typically after we merge abstractions together (see {!reduce_ctx} + and {!collapse_ctx} for instance). + + Inputs: + - [span] + - [allow_markers]: disables some sanity checks (which check that projection + markers don't appear). + - [old_abs_ids] + - [eval_ctx] + *) +val reorder_loans_borrows_in_fresh_abs : + Meta.span -> bool -> AbstractionId.Set.t -> eval_ctx -> eval_ctx diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 26505902..033deebb 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -126,70 +126,6 @@ let cleanup_fresh_values_and_abs (config : config) (span : Meta.span) let ctx = cleanup_fresh_values fixed_ids ctx in (ctx, cc) -(** Reorder the loans and borrows in the fresh abstractions. - - We do this in order to enforce some structure in the environments: this - allows us to find fixed-points. Note that this function needs to be - called typically after we merge abstractions together (see {!collapse_ctx} - and {!reduce_ctx} for instance). - *) -let reorder_loans_borrows_in_fresh_abs (span : Meta.span) - (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = - let reorder_in_fresh_abs (abs : abs) : abs = - (* Split between the loans and borrows *) - let is_borrow (av : typed_avalue) : bool = - match av.value with - | ABorrow _ -> true - | ALoan _ -> false - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - let aborrows, aloans = List.partition is_borrow abs.avalues in - - (* Reoder the borrows, and the loans. - - After experimenting, it seems that a good way of reordering the loans - 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 : typed_avalue) : BorrowId.id = - match av.value with - | ABorrow (AMutBorrow (pm, bid, _) | ASharedBorrow (pm, bid)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - bid - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - let get_loan_id (av : typed_avalue) : BorrowId.id = - match av.value with - | ALoan (AMutLoan (pm, lid, _)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - lid - | ALoan (ASharedLoan (pm, lids, _, _)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - BorrowId.Set.min_elt lids - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - (* We use ordered maps to reorder the borrows and loans *) - let reorder (get_bid : typed_avalue -> BorrowId.id) - (values : typed_avalue list) : typed_avalue list = - List.map snd - (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 avalues } - in - - 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 = env_map_abs reorder_in_abs ctx.env in - - { ctx with env } - let prepare_ashared_loans (span : Meta.span) (loop_id : LoopId.id option) : cm_fun = fun ctx0 -> @@ -251,11 +187,14 @@ let prepare_ashared_loans (span : Meta.span) (loop_id : LoopId.id option) : SL {l0, l1} s0 ]} - and introduce the corresponding abstraction for the borrow l0 - (and we do something similar for l1): + and introduce the corresponding abstractions for the borrows l0 and l1: {[ - abs'2 { SB l0, SL {l2} s2 } + abs'2 { SB l0, SL {l0'} s1 } // Reborrow for l0 + abs'3 { SB l1, SL {l1'} s2 } // Reborrow for l1 ]} + + Remark: of course we also need to replace the [SB l0] and the [SB l1] + values we find in the environments with [SB l0'] and [SB l1']. *) let push_abs_for_shared_value (abs : abs) (sv : typed_value) (lid : BorrowId.id) : unit = @@ -821,7 +760,8 @@ let compute_loop_entry_fixed_point (config : config) (span : Meta.span) (* Reorder the loans and borrows in the fresh abstractions in the fixed-point *) let fp = - reorder_loans_borrows_in_fresh_abs span (Option.get !fixed_ids).aids !fp + reorder_loans_borrows_in_fresh_abs span false (Option.get !fixed_ids).aids + !fp in (* Update the abstraction's [can_end] field and their kinds. diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index ce874992..d2f52781 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -1,6 +1,7 @@ open Types open Values open Contexts +open Utils open TypesUtils open ValuesUtils open InterpreterUtils @@ -12,64 +13,6 @@ open Errors (** The local logger *) let log = Logging.loops_join_ctxs_log -(** Reorder the loans and borrows in the fresh abstractions. - - We do this in order to enforce some structure in the environments: this - allows us to find fixed-points. Note that this function needs to be - called typically after we merge abstractions together (see {!collapse_ctx} - and {!reduce_ctx} for instance). - *) -let reorder_loans_borrows_in_fresh_abs (span : Meta.span) - (old_abs_ids : AbstractionId.Set.t) (ctx : eval_ctx) : eval_ctx = - let reorder_in_fresh_abs (abs : abs) : abs = - (* Split between the loans and borrows *) - let is_borrow (av : typed_avalue) : bool = - match av.value with - | ABorrow _ -> true - | ALoan _ -> false - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - let aborrows, aloans = List.partition is_borrow abs.avalues in - - (* Reoder the borrows, and the loans. - - After experimenting, it seems that a good way of reordering the loans - 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 : typed_avalue) : BorrowId.id = - match av.value with - | ABorrow (AMutBorrow (_, bid, _) | ASharedBorrow (_, bid)) -> bid - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - 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 - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - (* We use ordered maps to reorder the borrows and loans *) - let reorder (get_bid : typed_avalue -> BorrowId.id) - (values : typed_avalue list) : typed_avalue list = - List.map snd - (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 avalues } - in - - 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 = env_map_abs reorder_in_abs ctx.env in - - { ctx with env } - (** Reduce an environment. We do this to simplify an environment, for the purpose of finding a loop @@ -84,8 +27,8 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) In effect, this allows us to merge newly introduced abstractions/borrows with their parent abstractions. - For instance, when evaluating the first loop iteration, we start in the - following environment: + For instance, looking at the [list_nth_mut] example, when evaluating the + first loop iteration, we start in the following environment: {[ abs@0 { ML l0 } ls -> MB l0 (s2 : loops::List) @@ -115,7 +58,8 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) abs@3 { MB l1 } ]} - We finally merge the new abstractions together. It gives: + We finally merge the new abstractions together (abs@1 and abs@2 because + of l2, and abs@1 and abs@3 because of l1). It gives: {[ abs@0 { ML l0 } ls -> MB l4 (s@6 : loops::List) @@ -123,9 +67,20 @@ let reorder_loans_borrows_in_fresh_abs (span : Meta.span) abs@4 { MB l0, ML l4 } ]} - If [merge_funs] is None, we ensure that there are no markers in the environments. - If [merge_funs] is Some _, we merge environments that contain borrow/loan pairs with the same markers, omitting - pairs with the PNone marker (i.e., no marker) + If [merge_funs] is [None], we check that there are no markers in the environments. + This is the "reduce" operation. + If [merge_funs] is [Some _], when merging abstractions together, we merge the pairs + of borrows and the pairs of loans with complementary markers. This is useful to + reuse the reduce operation to implement the collapse. + For instance, when merging: + {[ + abs@0 { ML l0, |MB l1| } + abs@1 { MB l0, ︙MB l1︙ } + ]} + We get: + {[ + abs@2 { MB l1 } + ]} *) let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) @@ -274,8 +229,9 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) ^ eval_ctx_to_string ~span:(Some span) !ctx ^ "\n\n")); - (* Reorder the loans and borrows in the fresh abstractions *) - let ctx = reorder_loans_borrows_in_fresh_abs span old_ids.aids !ctx in + (* Reorder the loans and borrows in the fresh abstractions - note that we may + not have eliminated all the markers at this point. *) + let ctx = reorder_loans_borrows_in_fresh_abs span true old_ids.aids !ctx in log#ldebug (lazy @@ -287,37 +243,28 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) (* Return the new context *) ctx -(* Reduce_ctx can only be called in a context with no markers *) +(** Reduce_ctx can only be called in a context with no markers *) let reduce_ctx = reduce_ctx_with_markers None -(* Collapse an environment - - This is the second part of a join, where we attempt to simplify and remove all projection markers. - This function is called after reducing the environments, and attempting to simplify all the pairs - of borrows and loans. +(** Auxiliary function for collapse (see below). We traverse all abstractions, and merge abstractions when they contain the same element, - but with dual markers (i.e., PLeft and PRight). + but with dual markers (i.e., [PLeft] and [PRight]). For instance, if we have the abstractions - abs@0 { | MB l0 _ |, ML l1 } - abs@1 { ︙MB l0 _ ︙, ML l2 } - - we will merge abs@0 and abs@1 into a new abstraction abs@2, removing the marker for duplicated elements, - and taking the join of the remaining elements + {[ + abs@0 { | MB l0 _ |, ML l1 } + abs@1 { ︙MB l0 _ ︙, ML l2 } + ]} - abs@2 { MB l0 _, ML l1, ML l2 } - - Rem.: Doing this might introduce new pairs of borrow/loans to be merged in different abstractions: in the example above, - this could occur if there was another abstraction in the context containing ML l0, which would need to be simplified through - a further reduce. - It is unclear whether this can happen in practice. If so, a solution would be to preprocess the environments when doing - a join: while not in the current formalism, it is sound to split an element with no markers into a duplicated pair of the - same element with left and right markers. Doing this before reduce would allow to reduce all possible pairs of borrow/loans, - before finally collapsing and removing all markers. + We merge abs@0 and abs@1 into a new abstraction abs@2. This allows us to + eliminate the markers used for [MB l0]: + {[ + abs@2 { MB l0 _, ML l1, ML l2 } + ]} *) -let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) +let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) : eval_ctx = (* Debug *) @@ -482,8 +429,9 @@ let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) ^ eval_ctx_to_string ~span:(Some span) !ctx ^ "\n\n")); - (* Reorder the loans and borrows in the fresh abstractions *) - let ctx = reorder_loans_borrows_in_fresh_abs span old_ids.aids !ctx in + (* Reorder the loans and borrows in the fresh abstractions - note that we may + not have eliminated all the markers yet *) + let ctx = reorder_loans_borrows_in_fresh_abs span true old_ids.aids !ctx in log#ldebug (lazy @@ -495,16 +443,55 @@ let collapse_ctx_markers (span : Meta.span) (loop_id : LoopId.id) (* Return the new context *) ctx -(* Collapse two environments containing projection markers; this function is called after - joining environments. +(** Small utility: check whether an environment contains markers *) +let eval_ctx_has_markers (ctx : eval_ctx) : bool = + let visitor = + object + inherit [_] iter_eval_ctx + + method! visit_proj_marker _ pm = + match pm with PNone -> () | PLeft | PRight -> raise Found + end + in + try + visitor#visit_eval_ctx () ctx; + false + with Found -> true + +(** Collapse two environments containing projection markers; this function is called after + joining environments. - The collapse is done in two steps. - First, we reduce the environment, merging for instance abstractions containing MB l0 _ and ML l0, - when both elements have the same marker, e.g., PNone, PLeft, or PRight. + The collapse is done in two steps. - Second, we merge abstractions containing the same element with left and right markers respectively. + First, we reduce the environment, merging any two pair of fresh abstractions + which contain a loan (in one) and its corresponding borrow (in the other). + For instance, we merge abs@0 and abs@1 below: + {[ + abs@0 { |ML l0|, ML l1 } + abs@1 { |MB l0 _|, ML l2 } + ~~> + abs@2 { ML l1, ML l2 } + ]} + Note that we also merge abstractions when the loan/borrow don't have the same + markers. For instance, below: + {[ + abs@0 { ML l0, ML l1 } // ML l0 doesn't have markers + abs@1 { |MB l0 _|, ML l2 } + ~~> + abs@2 { ︙ML l0︙, ML l1, ML l2 } + ]} - At the end of the second step, all markers should have been removed from the resulting environment. + Second, we merge abstractions containing the same element with left and right markers + respectively. For instance: + {[ + abs@0 { | MB l0 _ |, ML l1 } + abs@1 { ︙MB l0 _ ︙, ML l2 } + ~~> + abs@2 { MB l0 _, ML l1, ML l2 } + ]} + + At the end of the second step, all markers should have been removed from the resulting + environment. *) let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) @@ -512,7 +499,10 @@ let collapse_ctx (span : Meta.span) (loop_id : LoopId.id) let ctx = reduce_ctx_with_markers (Some merge_funs) span loop_id old_ids ctx0 in - collapse_ctx_markers span loop_id merge_funs old_ids ctx + let ctx = collapse_ctx_collapse span loop_id merge_funs old_ids ctx in + (* Sanity check: there are no markers remaining *) + sanity_check __FILE__ __LINE__ (not (eval_ctx_has_markers ctx)) span; + ctx let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) (loop_id : LoopId.id) (ctx : eval_ctx) : merge_duplicates_funcs = -- cgit v1.2.3 From 67ef9b5316b6550c3386ae095197ea513ed7dfbb Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 14:56:42 +0200 Subject: Cleanup a bit --- compiler/InterpreterLoopsCore.ml | 20 ++++++++--- compiler/InterpreterLoopsJoinCtxs.ml | 67 +++++++++++++++++++---------------- compiler/InterpreterLoopsMatchCtxs.ml | 10 +----- 3 files changed, 53 insertions(+), 44 deletions(-) diff --git a/compiler/InterpreterLoopsCore.ml b/compiler/InterpreterLoopsCore.ml index 4149b19e..df808385 100644 --- a/compiler/InterpreterLoopsCore.ml +++ b/compiler/InterpreterLoopsCore.ml @@ -430,11 +430,11 @@ let ids_sets_empty_borrows_loans (ids : ids_sets) : ids_sets = in ids -(* Small utility: Add a projection marker to a typed avalue. - This can be used in combination with List.map to add markers to an entire abstraction -*) -let add_marker_avalue (span : Meta.span) (ctx : eval_ctx) (pm : proj_marker) - (av : typed_avalue) : typed_avalue = +(** Small utility: add a projection marker to a typed avalue. + This can be used in combination with List.map to add markers to an entire abstraction + *) +let typed_avalue_add_marker (span : Meta.span) (ctx : eval_ctx) + (pm : proj_marker) (av : typed_avalue) : typed_avalue = let obj = object inherit [_] map_typed_avalue as super @@ -473,3 +473,13 @@ let add_marker_avalue (span : Meta.span) (ctx : eval_ctx) (pm : proj_marker) end in obj#visit_typed_avalue () av + +(** Small utility: add a projection marker to an abstraction. + This can be used in combination with List.map to add markers to an entire abstraction + *) +let abs_add_marker (span : Meta.span) (ctx : eval_ctx) (pm : proj_marker) + (abs : abs) : abs = + { + abs with + avalues = List.map (typed_avalue_add_marker span ctx pm) abs.avalues; + } diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index d2f52781..b25ea0fc 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -67,20 +67,23 @@ let log = Logging.loops_join_ctxs_log abs@4 { MB l0, ML l4 } ]} - If [merge_funs] is [None], we check that there are no markers in the environments. - This is the "reduce" operation. - If [merge_funs] is [Some _], when merging abstractions together, we merge the pairs - of borrows and the pairs of loans with complementary markers. This is useful to - reuse the reduce operation to implement the collapse. - For instance, when merging: - {[ - abs@0 { ML l0, |MB l1| } - abs@1 { MB l0, ︙MB l1︙ } - ]} - We get: - {[ - abs@2 { MB l1 } - ]} + - If [merge_funs] is [None], we check that there are no markers in the environments. + This is the "reduce" operation. + - If [merge_funs] is [Some _], when merging abstractions together, we merge the pairs + of borrows and the pairs of loans with the same markers **if this marker is not** + [PNone]. This is useful to reuse the reduce operation to implement the collapse. + Note that we ignore borrows/loans with the [PNone] marker: the goal of the collapse + operation is to *eliminate* markers, not to simplify the environment. + + For instance, when merging: + {[ + abs@0 { ML l0, |MB l1| } + abs@1 { MB l0, ︙MB l1︙ } + ]} + We get: + {[ + abs@2 { MB l1 } + ]} *) let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) (span : Meta.span) (loop_id : LoopId.id) (old_ids : ids_sets) @@ -92,7 +95,7 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) ^ eval_ctx_to_string ~span:(Some span) ctx0 ^ "\n\n")); - let allow_markers = merge_funs <> None in + let with_markers = merge_funs <> None in let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in @@ -172,18 +175,27 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) let bids = MarkerBorrowId.Set.elements bids in List.iter (fun bid -> - if not allow_markers then + if not with_markers then sanity_check __FILE__ __LINE__ (fst bid = PNone) span; - match MarkerBorrowId.Map.find_opt bid loan_to_abs with - | None -> (* Nothing to do *) () - | Some abs_ids1 -> - if allow_markers && fst bid = PNone then () - else + (* If we use markers: we are doing a collapse, which means we attempt + to eliminate markers (and this is the only goal of the operation). + We thus ignore the non-marked values (we merge non-marked values + when doing a "real" reduce, to simplify the environment in order + to converge to a fixed-point, for instance). *) + if with_markers && fst bid = PNone then () + else + match MarkerBorrowId.Map.find_opt bid loan_to_abs with + | None -> (* Nothing to do *) () + | Some abs_ids1 -> 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) *) + (* First, find the representatives for the two abstractions. + + We may have merged some abstractions already, so maybe abs_id0 + and abs_id1 don't exist anymore, because they may have been + merged into other abstractions: we look for the abstractions + resulting from such merged. *) let abs_ref0 = UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) in @@ -207,7 +219,7 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) ^ ":\n\n" ^ eval_ctx_to_string ~span:(Some span) !ctx)); - (* Update the environment - pay attention to the order: we + (* Update the environment - pay attention to the order: we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = merge_into_abstraction span abs_kind can_end merge_funs @@ -672,12 +684,7 @@ let join_ctxs (span : Meta.span) (loop_id : LoopId.id) (fixed_ids : ids_sets) (* Add projection marker to all abstractions in the left and right environments *) let add_marker (pm : proj_marker) (ee : env_elem) : env_elem = match ee with - | EAbs abs -> - EAbs - { - abs with - avalues = List.map (add_marker_avalue span ctx0 pm) abs.avalues; - } + | EAbs abs -> EAbs (abs_add_marker span ctx0 pm abs) | x -> x in diff --git a/compiler/InterpreterLoopsMatchCtxs.ml b/compiler/InterpreterLoopsMatchCtxs.ml index bc39d5ec..3f7c023e 100644 --- a/compiler/InterpreterLoopsMatchCtxs.ml +++ b/compiler/InterpreterLoopsMatchCtxs.ml @@ -837,15 +837,7 @@ module MakeJoinMatcher (S : MatchJoinState) : PrimMatcher = struct in (* Add a marker to the abstraction indicating the provenance of the value *) let pm = if value_is_left then PLeft else PRight in - let absl = - List.map - (fun abs -> - { - abs with - avalues = List.map (add_marker_avalue span ctx0 pm) abs.avalues; - }) - absl - in + let absl = List.map (abs_add_marker span ctx0 pm) absl in push_absl absl; (* Return [Bottom] *) mk_bottom span v.ty -- cgit v1.2.3 From 311a162dcc65233d628303a1114b529b8eff29a0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 16:11:24 +0200 Subject: Change the order in which we merge abstractions --- compiler/InterpreterBorrows.ml | 86 +++++++++++++--------------------- compiler/InterpreterBorrows.mli | 46 +++++++++--------- compiler/InterpreterLoopsFixedPoint.ml | 18 +++++-- compiler/InterpreterLoopsJoinCtxs.ml | 52 ++++++++++---------- compiler/InterpreterLoopsJoinCtxs.mli | 2 +- 5 files changed, 99 insertions(+), 105 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 48292181..b46a5da8 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -566,7 +566,9 @@ let give_back_avalue_to_same_abstraction (_config : config) (span : Meta.span) | AEndedSharedLoan (_, _) -> (* Nothing special to do *) super#visit_ALoan opt_abs lc - | ASharedLoan (_, _, _, _) -> internal_error __FILE__ __LINE__ span + | ASharedLoan (_, _, _, _) -> + (* We get there if the projection marker is not [PNone] *) + internal_error __FILE__ __LINE__ span | AIgnoredMutLoan (bid_opt, child) -> (* This loan is ignored, but we may have to project on a subvalue * of the value which is given back *) @@ -2013,7 +2015,7 @@ type merge_abstraction_info = { We compute the list of loan/borrow contents, maps from borrow/loan ids to borrow/loan contents, etc. - Note that this function is very specific to [merge_into_abstraction]: we + Note that this function is very specific to [merge_into_first_abstraction]: we have strong assumptions about the shape of the abstraction, and in particular that: - its values don't contain nested borrows @@ -2032,25 +2034,6 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) ref MarkerBorrowId.Map.empty in - let push_loans pm ids (lc : g_loan_content_with_ty) : unit = - let pm_ids = - BorrowId.Set.to_seq ids - |> Seq.map (fun x -> (pm, x)) - |> MarkerBorrowId.Set.of_seq - in - sanity_check __FILE__ __LINE__ - (MarkerBorrowId.Set.disjoint !loans pm_ids) - span; - loans := MarkerBorrowId.Set.union !loans pm_ids; - MarkerBorrowId.Set.iter - (fun (pm, id) -> - sanity_check __FILE__ __LINE__ - (not (MarkerBorrowId.Map.mem (pm, id) !loan_to_content)) - span; - loan_to_content := MarkerBorrowId.Map.add (pm, id) lc !loan_to_content; - borrows_loans := LoanId (pm, id) :: !borrows_loans) - pm_ids - in let push_loan pm id (lc : g_loan_content_with_ty) : unit = sanity_check __FILE__ __LINE__ (not (MarkerBorrowId.Set.mem (pm, id) !loans)) @@ -2062,6 +2045,9 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) loan_to_content := MarkerBorrowId.Map.add (pm, id) lc !loan_to_content; borrows_loans := LoanId (pm, id) :: !borrows_loans in + let push_loans pm ids lc : unit = + BorrowId.Set.iter (fun id -> push_loan pm id lc) ids + in let push_borrow pm id (bc : g_borrow_content_with_ty) : unit = sanity_check __FILE__ __LINE__ (not (MarkerBorrowId.Set.mem (pm, id) !borrows)) @@ -2086,19 +2072,11 @@ let compute_merge_abstraction_info (span : Meta.span) (ctx : eval_ctx) 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 - reborrowed *) - let ty = - match Option.get env with - | Concrete ty -> ty - | Abstract _ -> craise __FILE__ __LINE__ span "Unreachable" - in - (match lc with - | VSharedLoan (bids, _) -> push_loans PNone bids (Concrete (ty, lc)) - | VMutLoan _ -> craise __FILE__ __LINE__ span "Unreachable"); - (* Continue *) - super#visit_loan_content env lc + method! visit_loan_content _ _ = + (* Could happen if we explore shared values whose sub-values are + reborrowed. We use the fact that we destructure the nested shared + loans before reducing a context or computing a join. *) + craise __FILE__ __LINE__ span "Unreachable" method! visit_borrow_content _ _ = (* Can happen if we explore shared values which contain borrows - @@ -2244,12 +2222,12 @@ type merge_duplicates_funcs = { Merge two abstractions into one, without updating the context. *) -let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) +let merge_into_first_abstraction_aux (span : Meta.span) (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" + ("merge_into_first_abstraction_aux:\n- abs0:\n" ^ abs_to_string span ctx abs0 ^ "\n\n- abs1:\n" ^ abs_to_string span ctx abs1)); @@ -2285,8 +2263,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) compute_merge_abstraction_info span ctx abs1.avalues in - (* Sanity check: there is no loan/borrows which appears in both abstractions, - unless we allow to merge duplicates *) + (* Sanity check: no markers appear unless we allow merging duplicates *) if merge_funs = None then ( sanity_check __FILE__ __LINE__ (List.for_all @@ -2313,7 +2290,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) - if a borrow/loan is present in both abstractions, we need to merge its content. - Note that it is possible that we may need to merge strictly more than 2 avalues, + Note that it is possible that we may need to merge strictly more than two avalues, because of shared loans. For instance, if we have: {[ abs'0 { shared_loan { l0, l1 } ... } @@ -2329,7 +2306,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) let push_avalue av = log#ldebug (lazy - ("merge_into_abstraction_aux: push_avalue: " + ("merge_into_first_abstraction_aux: push_avalue: " ^ typed_avalue_to_string ~span:(Some span) ctx av)); avalues := av :: !avalues in @@ -2337,14 +2314,14 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) match av with None -> () | Some av -> push_avalue av in - (* Phase 1 of the merge: We want to simplify all loan/borrow pairs. *) + (* Phase 1 of the merge: we simplify all loan/borrow pairs. *) - (* There is an asymetry in the merge: We only simplify a loan/borrow pair if the loan is in - the abstraction on the left *) + (* There is an asymetry in the merge: we only simplify a loan/borrow pair + if the loan is in the abstraction on the left *) let intersect = MarkerBorrowId.Set.inter loans0 borrows1 in - (* This function is called when handling shared loans, where the projection marker is global to a set of borrow ids. - Tracking this requires some set transformations *) + (* This function is called when handling shared loans: we have to apply a projection + marker to a set of borrow ids. *) let filter_bids (pm : proj_marker) (bids : BorrowId.Set.t) : BorrowId.Set.t = let bids = BorrowId.Set.to_seq bids @@ -2388,7 +2365,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) let bid = (pm, bid) in log#ldebug (lazy - ("merge_into_abstraction_aux: merging borrow " + ("merge_into_first_abstraction_aux: merging borrow " ^ MarkerBorrowId.to_string bid)); (* Check if the borrow has already been merged - this can happen @@ -2438,7 +2415,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) else ( log#ldebug (lazy - ("merge_into_abstraction_aux: merging loan " + ("merge_into_first_abstraction_aux: merging loan " ^ MarkerBorrowId.to_string bid)); (* Check if we need to filter it *) @@ -2496,7 +2473,7 @@ let merge_into_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) with only one marker. To do so, we linearly traverse the abstraction created through the first phase *) log#ldebug (lazy - ("merge_into_abstraction_aux: starting phase 2\n- abs:\n" + ("merge_into_first_abstraction_aux: starting phase 2\n- abs:\n" ^ abs_to_string span ctx { abs0 with avalues = abs_values })); (* We first reset the list of avalues, and will construct avalues similarly to the previous phase *) @@ -2777,7 +2754,7 @@ let ctx_merge_regions (ctx : eval_ctx) (rid : RegionId.id) let env = Substitute.env_subst_rids rsubst ctx.env in { ctx with env } -let merge_into_abstraction (span : Meta.span) (abs_kind : abs_kind) +let merge_into_first_abstraction (span : Meta.span) (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 = @@ -2787,13 +2764,14 @@ let merge_into_abstraction (span : Meta.span) (abs_kind : abs_kind) (* Merge them *) let nabs = - merge_into_abstraction_aux span abs_kind can_end merge_funs ctx abs0 abs1 + merge_into_first_abstraction_aux span abs_kind can_end merge_funs ctx abs0 + abs1 in - (* Update the environment: replace the abstraction 1 with the result of the merge, - remove the abstraction 0 *) - let ctx = fst (ctx_subst_abs span ctx abs_id1 nabs) in - let ctx = fst (ctx_remove_abs span ctx abs_id0) in + (* Update the environment: replace the abstraction 0 with the result of the merge, + remove the abstraction 1 *) + let ctx = fst (ctx_subst_abs span ctx abs_id0 nabs) in + let ctx = fst (ctx_remove_abs span ctx abs_id1) 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 diff --git a/compiler/InterpreterBorrows.mli b/compiler/InterpreterBorrows.mli index 0bc2bfab..cf14e94b 100644 --- a/compiler/InterpreterBorrows.mli +++ b/compiler/InterpreterBorrows.mli @@ -212,24 +212,36 @@ type merge_duplicates_funcs = { (** Merge an abstraction into another abstraction. - We insert the result of the merge in place of the second abstraction (and in + We insert the result of the merge in place of the first abstraction (and in particular, we don't simply push the merged abstraction at the end of the environment: this helps preserving the structure of the environment, when computing loop fixed points for instance). - When we merge two abstractions together, we remove the loans/borrows - which appear in one and whose associated loans/borrows appear in the - other. For instance: + When we merge two abstractions together, we remove the loans which appear + in the *left* abstraction and whose corresponding borrows appear in the + **right** abstraction. + For instance: {[ abs'0 { mut_borrow l0, mut_loan l1 } // Rem.: mut_loan l1 abs'1 { mut_borrow l1, mut_borrow l2 } // Rem.: mut_borrow l1 ~~> - abs'01 { mut_borrow l0, mut_borrow l2 } + abs'2 { mut_borrow l0, mut_borrow l2 } + ]} + + We also simplify the markers, when the same value appears in both abstractions + but with different markers. For instance: + {[ + abs'0 { |mut_borrow l0|, mut_loan l1 } + abs'1 { ︙mut_borrow l0︙, mut_borrow l1 } + + ~~> + + abs'2 { mut_borrow l0 } ]} - Also, we merge all their regions together. For instance, if [abs'0] projects + Finally, we merge all their regions together. For instance, if [abs'0] projects region [r0] and [abs'1] projects region [r1], we pick one of the two, say [r0] (the one with the smallest index in practice) and substitute [r1] with [r0] in the whole context. @@ -237,22 +249,10 @@ type merge_duplicates_funcs = { Parameters: - [kind] - [can_end] - - [merge_funs]: Those functions are used to merge borrows/loans with the - *same ids*. For instance, when performing environment joins we may introduce - abstractions which both contain loans/borrows with the same ids. When we - later merge those abstractions together, we need to call a merge function - to reconcile the borrows/loans. For instance, if both abstractions contain - the same shared loan [l0], we will call {!merge_ashared_borrows} to derive - a shared value for the merged shared loans. - - For instance, this happens for the following abstractions: - {[ - abs'0 { mut_borrow l0, mut_loan l1 } // mut_borrow l0 ! - abs'1 { mut_borrow l0, mut_loan l2 } // mut_borrow l0 ! - ]} - If you want to forbid this, provide [None]. In that case, [merge_into_abstraction] - actually simply performs some sort of a union. - + - [merge_funs]: those functions are used to merge borrows/loans with the + *same ids* but different markers. This is necessary when doing a collapse + (see the computation of joins). + If [merge_funs] are not provided, we check that there are no markers. - [ctx] - [abs_id0] - [abs_id1] @@ -260,7 +260,7 @@ type merge_duplicates_funcs = { We return the updated context as well as the id of the new abstraction which results from the merge. *) -val merge_into_abstraction : +val merge_into_first_abstraction : Meta.span -> abs_kind -> bool -> diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 033deebb..79beb761 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -696,10 +696,22 @@ let compute_loop_entry_fixed_point (config : config) (span : Meta.span) region id to abstraction id *) let fp = ref fp in let rg_to_abs = ref RegionGroupId.Map.empty in + (* List the ids of all the abstractions in the context, in the order in + which they appear (this is important to preserve some structure: + we will explore them in this order) *) + let all_abs_ids = + List.filter_map + (function EAbs abs -> Some abs.abs_id | _ -> None) + !fp.env + in let _ = RegionGroupId.Map.iter (fun rg_id ids -> - let ids = AbstractionId.Set.elements ids in + (* Make sure we explore the ids in the order in which they appear + in the context *) + let ids = + List.filter (fun id -> AbstractionId.Set.mem id ids) all_abs_ids + in (* Retrieve the first id of the group *) match ids with | [] -> @@ -742,8 +754,8 @@ let compute_loop_entry_fixed_point (config : config) (span : Meta.span) ^ AbstractionId.to_string !id0)); (* Note that we merge *into* [id0] *) let fp', id0' = - merge_into_abstraction span loop_id abs_kind false !fp id - !id0 + merge_into_first_abstraction span loop_id abs_kind false + !fp !id0 id in fp := fp'; id0 := id0'; diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index b25ea0fc..8ad5272a 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -146,10 +146,10 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) let ids_maps = compute_abs_borrows_loans_maps span explore env in let { abs_ids; - abs_to_borrows; - abs_to_loans = _; - borrow_to_abs = _; - loan_to_abs; + abs_to_borrows = _; + abs_to_loans; + borrow_to_abs; + loan_to_abs = _; } = ids_maps in @@ -164,27 +164,28 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) (* Merge all the mergeable abs. - We iterate over the abstractions, then over the borrows in the abstractions. + We iterate over the abstractions, then over the loans in the abstractions. We do this because we want to control the order in which abstractions are merged (the ids are iterated in increasing order). Otherwise, we - could simply iterate over all the borrows in [borrow_to_abs]... + could simply iterate over all the borrows in [loan_to_abs]... *) List.iter (fun abs_id0 -> - let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in - let bids = MarkerBorrowId.Set.elements bids in + let lids = AbstractionId.Map.find abs_id0 abs_to_loans in + let lids = MarkerBorrowId.Set.elements lids in List.iter - (fun bid -> + (fun lid -> if not with_markers then - sanity_check __FILE__ __LINE__ (fst bid = PNone) span; + sanity_check __FILE__ __LINE__ (fst lid = PNone) span; (* If we use markers: we are doing a collapse, which means we attempt to eliminate markers (and this is the only goal of the operation). We thus ignore the non-marked values (we merge non-marked values when doing a "real" reduce, to simplify the environment in order to converge to a fixed-point, for instance). *) - if with_markers && fst bid = PNone then () + if with_markers && fst lid = PNone then () else - match MarkerBorrowId.Map.find_opt bid loan_to_abs with + (* Find the borrow corresponding to the loan we want to eliminate *) + match MarkerBorrowId.Map.find_opt lid borrow_to_abs with | None -> (* Nothing to do *) () | Some abs_ids1 -> AbstractionId.Set.iter @@ -220,10 +221,12 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) ^ eval_ctx_to_string ~span:(Some span) !ctx)); (* Update the environment - pay attention to the order: - we merge [abs_id1] *into* [abs_id0] *) + we merge [abs_id1] *into* [abs_id0]. + In particular, as [abs_id0] contains the loan, it has + to be on the left. *) let nctx, abs_id = - merge_into_abstraction span abs_kind can_end merge_funs - !ctx abs_id1 abs_id0 + merge_into_first_abstraction span abs_kind can_end + merge_funs !ctx abs_id0 abs_id1 in ctx := nctx; @@ -231,7 +234,7 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in UnionFind.set abs_ref_merged abs_id)) abs_ids1) - bids) + lids) abs_ids; log#ldebug @@ -366,8 +369,8 @@ let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction span abs_kind can_end - (Some merge_funs) !ctx abs_id1 abs_id0 + merge_into_first_abstraction span abs_kind can_end + (Some merge_funs) !ctx abs_id0 abs_id1 in ctx := nctx; @@ -422,8 +425,8 @@ let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) (* Update the environment - pay attention to the order: we we merge [abs_id1] *into* [abs_id0] *) let nctx, abs_id = - merge_into_abstraction span abs_kind can_end - (Some merge_funs) !ctx abs_id1 abs_id0 + merge_into_first_abstraction span abs_kind can_end + (Some merge_funs) !ctx abs_id0 abs_id1 in ctx := nctx; @@ -544,7 +547,7 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) (* 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 the one from the left), because we will merge those regions together - anyway (see the comments for {!merge_into_abstraction}). + anyway (see the comments for {!merge_into_first_abstraction}). *) let ty = ty0 in let child = child0 in @@ -612,12 +615,13 @@ let mk_collapse_ctx_merge_duplicate_funs (span : Meta.span) merge_ashared_loans; } -let merge_into_abstraction (span : Meta.span) (loop_id : LoopId.id) +let merge_into_first_abstraction (span : Meta.span) (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 span loop_id ctx in - merge_into_abstraction span abs_kind can_end (Some merge_funs) ctx aid0 aid1 + merge_into_first_abstraction span abs_kind can_end (Some merge_funs) ctx aid0 + aid1 (** Collapse an environment, merging the duplicated borrows/loans. @@ -965,7 +969,7 @@ let loop_join_origin_with_continue_ctxs (config : config) (span : Meta.span) ("loop_join_origin_with_continue_ctxs:join_one: after join-collapse:\n" ^ eval_ctx_to_string ~span:(Some span) !joined_ctx)); - (* Reduce again to reach fixed point *) + (* Reduce again to reach a fixed point *) joined_ctx := reduce_ctx span loop_id fixed_ids !joined_ctx; log#ldebug (lazy diff --git a/compiler/InterpreterLoopsJoinCtxs.mli b/compiler/InterpreterLoopsJoinCtxs.mli index f4b5194a..a194e25b 100644 --- a/compiler/InterpreterLoopsJoinCtxs.mli +++ b/compiler/InterpreterLoopsJoinCtxs.mli @@ -15,7 +15,7 @@ open InterpreterLoopsCore - [aid0] - [aid1] *) -val merge_into_abstraction : +val merge_into_first_abstraction : Meta.span -> loop_id -> abs_kind -> -- cgit v1.2.3 From b259af6d427fa188037dafe1ef19704f31fbbf2c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 17:24:06 +0200 Subject: Fix a bug when composing the continuations in eval_statement --- compiler/Cps.ml | 6 ++ compiler/InterpreterExpansion.ml | 10 +- compiler/InterpreterStatements.ml | 221 +++++++++++++++++++------------------- compiler/SymbolicAst.ml | 16 +-- 4 files changed, 131 insertions(+), 122 deletions(-) diff --git a/compiler/Cps.ml b/compiler/Cps.ml index 142c2b08..f7694ba2 100644 --- a/compiler/Cps.ml +++ b/compiler/Cps.ml @@ -106,6 +106,12 @@ let cc_singleton file line span cf el = | Some _ -> internal_error file line span | _ -> None +let cf_singleton file line span el = + match el with + | Some [ e ] -> Some e + | Some _ -> internal_error file line span + | _ -> None + (** It happens that we need to concatenate lists of results, for instance when evaluating the branches of a match. When applying the continuations to build the symbolic expressions, we need diff --git a/compiler/InterpreterExpansion.ml b/compiler/InterpreterExpansion.ml index 388d7382..4393e89f 100644 --- a/compiler/InterpreterExpansion.ml +++ b/compiler/InterpreterExpansion.ml @@ -478,7 +478,7 @@ let expand_symbolic_value_no_branching (config : config) (span : Meta.span) (* Debug *) log#ldebug (lazy - ("expand_symbolic_value_no_branching:" ^ symbolic_value_to_string ctx sv)); + ("expand_symbolic_value_no_branching: " ^ symbolic_value_to_string ctx sv)); (* Remember the initial context for printing purposes *) let ctx0 = ctx in (* Compute the expanded value - note that when doing so, we may introduce @@ -631,6 +631,8 @@ let greedy_expand_symbolics_with_borrows (config : config) (span : Meta.span) : (* We reverse the environment before exploring it - this way the values get expanded in a more "logical" order (this is only for convenience) *) obj#visit_env () (List.rev ctx.env); + log#ldebug + (lazy "greedy_expand_symbolics_with_borrows: no value to expand\n"); (* Nothing to expand: continue *) (ctx, fun e -> e) with FoundSymbolicValue sv -> @@ -674,6 +676,12 @@ let greedy_expand_symbolics_with_borrows (config : config) (span : Meta.span) : | TVar _ | TLiteral _ | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> craise __FILE__ __LINE__ span "Unreachable" in + (* *) + log#ldebug + (lazy + ("\ngreedy_expand_symbolics_with_borrows: after expansion:\n" + ^ eval_ctx_to_string ~span:(Some span) ctx + ^ "\n\n")); (* Compose and continue *) comp cc (expand ctx) in diff --git a/compiler/InterpreterStatements.ml b/compiler/InterpreterStatements.ml index c6a65757..19510c2e 100644 --- a/compiler/InterpreterStatements.ml +++ b/compiler/InterpreterStatements.ml @@ -914,116 +914,111 @@ let rec eval_statement (config : config) (st : statement) : stl_cm_fun = (* Sanity check *) Invariants.check_invariants st.span ctx; - (* Evaluate *) - let stl, cf_eval_st = - log#ldebug - (lazy - ("\neval_statement: cf_eval_st: statement:\n" - ^ statement_to_string_with_tab ctx st - ^ "\n\n")); - match st.content with - | Assign (p, rvalue) -> ( - (* We handle global assignments separately *) - match rvalue with - | Global (gid, generics) -> - (* Evaluate the global *) - eval_global config st.span p gid generics ctx - | _ -> - (* Evaluate the rvalue *) - let res, ctx, cc = - eval_rvalue_not_global config st.span rvalue ctx - in - (* Assign *) - log#ldebug - (lazy - ("about to assign to place: " ^ place_to_string ctx p - ^ "\n- Context:\n" - ^ eval_ctx_to_string ~span:(Some st.span) ctx)); - let (ctx, res), cf_assign = - match res with - | Error EPanic -> ((ctx, Panic), fun e -> e) - | Ok rv -> - (* Update the synthesized AST - here we store additional span-information. - * We do it only in specific cases (it is not always useful, and - * also it can lead to issues - for instance, if we borrow a - * reserved borrow, we later can't translate it to pure values...) *) - let cc = - match rvalue with - | Global _ -> craise __FILE__ __LINE__ st.span "Unreachable" - | Use _ - | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) - | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> - let rp = rvalue_get_place rvalue in - let rp = - match rp with - | Some rp -> Some (S.mk_mplace st.span rp ctx) - | None -> None - in - S.synthesize_assignment ctx - (S.mk_mplace st.span p ctx) - rv rp - in - let ctx, cc = - comp cc (assign_to_place config st.span rv p ctx) - in - ((ctx, Unit), cc) - in - let cc = cc_comp cc cf_assign in - (* Compose and apply *) - ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc)) - | FakeRead p -> - let ctx, cc = eval_fake_read config st.span p ctx in - ([ (ctx, Unit) ], cc_singleton __FILE__ __LINE__ st.span cc) - | SetDiscriminant (p, variant_id) -> - let (ctx, res), cc = set_discriminant config st.span p variant_id ctx in - ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Drop p -> - let ctx, cc = drop_value config st.span p ctx in - ([ (ctx, Unit) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Assert assertion -> - let (ctx, res), cc = eval_assertion config st.span assertion ctx in - ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Call call -> eval_function_call config st.span call ctx - | Panic -> ([ (ctx, Panic) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Return -> ([ (ctx, Return) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Break i -> ([ (ctx, Break i) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Continue i -> - ([ (ctx, Continue i) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Nop -> ([ (ctx, Unit) ], cc_singleton __FILE__ __LINE__ st.span cc) - | Sequence (st1, st2) -> - (* Evaluate the first statement *) - let ctx_resl, cf_st1 = eval_statement config st1 ctx in - (* Evaluate the sequence (evaluate the second statement if the first - statement successfully evaluated, otherwise transfmit the control-flow - break) *) - let ctx_res_cfl = - List.map - (fun (ctx, res) -> - match res with - (* Evaluation successful: evaluate the second statement *) - | Unit -> eval_statement config st2 ctx - (* Control-flow break: transmit. We enumerate the cases on purpose *) - | Panic | Break _ | Continue _ | Return | LoopReturn _ - | EndEnterLoop _ | EndContinue _ -> - ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc)) - ctx_resl - in - (* Put everything together: - - we return the flattened list of contexts and results - - we need to build the continuation which will build the whole - expression from the continuations for the individual branches - *) - let ctx_resl, cf_st2 = - comp_seqs __FILE__ __LINE__ st.span ctx_res_cfl - in - (ctx_resl, cc_comp cf_st1 cf_st2) - | Loop loop_body -> - let eval_loop_body = eval_statement config loop_body in - InterpreterLoops.eval_loop config st.span eval_loop_body ctx - | Switch switch -> eval_switch config st.span switch ctx - in - (* Compose and apply *) - (stl, cc_comp cc cf_eval_st) + (* Evaluate the statement *) + comp cc (eval_statement_raw config st ctx) + +and eval_statement_raw (config : config) (st : statement) : stl_cm_fun = + fun ctx -> + log#ldebug + (lazy + ("\neval_statement_raw: statement:\n" + ^ statement_to_string_with_tab ctx st + ^ "\n\n")); + match st.content with + | Assign (p, rvalue) -> ( + (* We handle global assignments separately *) + match rvalue with + | Global (gid, generics) -> + (* Evaluate the global *) + eval_global config st.span p gid generics ctx + | _ -> + (* Evaluate the rvalue *) + let res, ctx, cc = eval_rvalue_not_global config st.span rvalue ctx in + (* Assign *) + log#ldebug + (lazy + ("about to assign to place: " ^ place_to_string ctx p + ^ "\n- Context:\n" + ^ eval_ctx_to_string ~span:(Some st.span) ctx)); + let (ctx, res), cf_assign = + match res with + | Error EPanic -> ((ctx, Panic), fun e -> e) + | Ok rv -> + (* Update the synthesized AST - here we store additional span-information. + * We do it only in specific cases (it is not always useful, and + * also it can lead to issues - for instance, if we borrow a + * reserved borrow, we later can't translate it to pure values...) *) + let cc = + match rvalue with + | Global _ -> craise __FILE__ __LINE__ st.span "Unreachable" + | Use _ + | RvRef (_, (BShared | BMut | BTwoPhaseMut | BShallow)) + | UnaryOp _ | BinaryOp _ | Discriminant _ | Aggregate _ -> + let rp = rvalue_get_place rvalue in + let rp = + match rp with + | Some rp -> Some (S.mk_mplace st.span rp ctx) + | None -> None + in + S.synthesize_assignment ctx + (S.mk_mplace st.span p ctx) + rv rp + in + let ctx, cc = + comp cc (assign_to_place config st.span rv p ctx) + in + ((ctx, Unit), cc) + in + let cc = cc_comp cc cf_assign in + (* Compose and apply *) + ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc)) + | FakeRead p -> + let ctx, cc = eval_fake_read config st.span p ctx in + ([ (ctx, Unit) ], cc_singleton __FILE__ __LINE__ st.span cc) + | SetDiscriminant (p, variant_id) -> + let (ctx, res), cc = set_discriminant config st.span p variant_id ctx in + ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc) + | Drop p -> + let ctx, cc = drop_value config st.span p ctx in + ([ (ctx, Unit) ], cc_singleton __FILE__ __LINE__ st.span cc) + | Assert assertion -> + let (ctx, res), cc = eval_assertion config st.span assertion ctx in + ([ (ctx, res) ], cc_singleton __FILE__ __LINE__ st.span cc) + | Call call -> eval_function_call config st.span call ctx + | Panic -> ([ (ctx, Panic) ], cf_singleton __FILE__ __LINE__ st.span) + | Return -> ([ (ctx, Return) ], cf_singleton __FILE__ __LINE__ st.span) + | Break i -> ([ (ctx, Break i) ], cf_singleton __FILE__ __LINE__ st.span) + | Continue i -> ([ (ctx, Continue i) ], cf_singleton __FILE__ __LINE__ st.span) + | Nop -> ([ (ctx, Unit) ], cf_singleton __FILE__ __LINE__ st.span) + | Sequence (st1, st2) -> + (* Evaluate the first statement *) + let ctx_resl, cf_st1 = eval_statement config st1 ctx in + (* Evaluate the sequence (evaluate the second statement if the first + statement successfully evaluated, otherwise transfmit the control-flow + break) *) + let ctx_res_cfl = + List.map + (fun (ctx, res) -> + match res with + (* Evaluation successful: evaluate the second statement *) + | Unit -> eval_statement config st2 ctx + (* Control-flow break: transmit. We enumerate the cases on purpose *) + | Panic | Break _ | Continue _ | Return | LoopReturn _ + | EndEnterLoop _ | EndContinue _ -> + ([ (ctx, res) ], cf_singleton __FILE__ __LINE__ st.span)) + ctx_resl + in + (* Put everything together: + - we return the flattened list of contexts and results + - we need to build the continuation which will build the whole + expression from the continuations for the individual branches + *) + let ctx_resl, cf_st2 = comp_seqs __FILE__ __LINE__ st.span ctx_res_cfl in + (ctx_resl, cc_comp cf_st1 cf_st2) + | Loop loop_body -> + let eval_loop_body = eval_statement config loop_body in + InterpreterLoops.eval_loop config st.span eval_loop_body ctx + | Switch switch -> eval_switch config st.span switch ctx and eval_global (config : config) (span : Meta.span) (dest : place) (gid : GlobalDeclId.id) (generics : generic_args) : stl_cm_fun = @@ -1609,11 +1604,11 @@ and eval_function_body (config : config) (body : statement) : stl_cm_fun = let ctx_res_cfl = List.map (fun (ctx, res) -> - log#ldebug (lazy "eval_function_body: cf_finish"); (* Note that we *don't* check the result ({!Panic}, {!Return}, etc.): we - * delegate the check to the caller. *) + delegate the check to the caller. *) + log#ldebug (lazy "eval_function_body: cf_finish"); (* Expand the symbolic values if necessary - we need to do that before - * checking the invariants *) + checking the invariants *) let ctx, cf = greedy_expand_symbolic_values config body.span ctx in (* Sanity check *) Invariants.check_invariants body.span ctx; diff --git a/compiler/SymbolicAst.ml b/compiler/SymbolicAst.ml index e9143ab5..750297e4 100644 --- a/compiler/SymbolicAst.ml +++ b/compiler/SymbolicAst.ml @@ -37,7 +37,7 @@ type call_id = type call = { call_id : call_id; - ctx : Contexts.eval_ctx; + ctx : (Contexts.eval_ctx[@opaque]); (** The context upon calling the function (after the operands have been evaluated). We need it to compute the translated values for shared borrows (we need to perform lookups). @@ -123,9 +123,9 @@ class ['self] iter_expression_base = (** **Rem.:** here, {!expression} is not at all equivalent to the expressions used in LLBC or in lambda-calculus: they are simply a first step towards lambda-calculus expressions. - *) +*) type expression = - | Return of Contexts.eval_ctx * typed_value option + | Return of (Contexts.eval_ctx[@opaque]) * 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 @@ -137,7 +137,7 @@ type expression = *) | Panic | FunCall of call * expression - | EndAbstraction of Contexts.eval_ctx * abs * expression + | EndAbstraction of (Contexts.eval_ctx[@opaque]) * abs * expression (** The context is the evaluation context upon ending the abstraction, just after we removed the abstraction from the context. @@ -146,7 +146,7 @@ type expression = *) | EvalGlobal of global_decl_id * generic_args * symbolic_value * expression (** Evaluate a global to a fresh symbolic value *) - | Assertion of Contexts.eval_ctx * typed_value * expression + | Assertion of (Contexts.eval_ctx[@opaque]) * typed_value * expression (** An assertion. The context is the evaluation context from after evaluating the asserted @@ -162,7 +162,7 @@ type expression = to prettify the generated code. *) | IntroSymbolic of - Contexts.eval_ctx + (Contexts.eval_ctx[@opaque]) * mplace option * symbolic_value * value_aggregate @@ -179,7 +179,7 @@ type expression = value. It has the same purpose as for the {!Return} case. *) | ForwardEnd of - Contexts.eval_ctx + (Contexts.eval_ctx[@opaque]) * typed_value symbolic_value_id_map option * expression * expression region_group_id_map @@ -211,7 +211,7 @@ type expression = The boolean is [true]. TODO: merge this with Return. *) - | Meta of espan * expression (** Meta information *) + | Meta of (espan[@opaque]) * expression (** Meta information *) | Error of Meta.span option * string and loop = { -- cgit v1.2.3 From 5a3b8b399c182f38586b44abcf53041845d0f672 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 20:50:56 +0200 Subject: Fix an issue with the type of the values given back by loops --- compiler/InterpreterLoops.ml | 380 +++++++++++++++++++------------- compiler/InterpreterLoopsFixedPoint.ml | 9 +- compiler/InterpreterLoopsFixedPoint.mli | 5 +- 3 files changed, 237 insertions(+), 157 deletions(-) diff --git a/compiler/InterpreterLoops.ml b/compiler/InterpreterLoops.ml index 7714f5bb..90161196 100644 --- a/compiler/InterpreterLoops.ml +++ b/compiler/InterpreterLoops.ml @@ -70,6 +70,202 @@ let eval_loop_concrete (span : Meta.span) (eval_loop_body : stl_cm_fun) : in (ctx_resl, cf) +(** Auxiliary function for {!eval_loop_symbolic}. + + Match the context upon entering the loop with the loop fixed-point to + compute how to "apply" the fixed-point. Compute the correspondance from + the borrow ids in the current context to the loans which appear in the + loop context (we need this in order to know how to introduce the region + abstractions of the loop). + + We check the fixed-point at the same time to make sure the loans and borrows + inside the region abstractions are properly ordered (this is necessary for the + synthesis). + Ex.: if in the fixed point we have: + {[ + abs { MB l0, MB l1, ML l2, ML l3 } + ]} + we want to make sure that borrow l0 actually corresponds to loan l2, and + borrow l1 to loan l3. + *) +let eval_loop_symbolic_synthesize_fun_end (config : config) (span : span) + (loop_id : LoopId.id) (init_ctx : eval_ctx) (fixed_ids : ids_sets) + (fp_ctx : eval_ctx) (fp_input_svalues : SymbolicValueId.id list) + (rg_to_abs : AbstractionId.id RegionGroupId.Map.t) : + ((eval_ctx * statement_eval_res) * (eval_result -> eval_result)) + * borrow_loan_corresp = + (* First, preemptively end borrows/move values by matching the current + context with the target context *) + let ctx, cf_prepare = + log#ldebug + (lazy + ("eval_loop_symbolic_synthesize_fun_end: about to reorganize the \ + original context to match the fixed-point ctx with it:\n\ + - src ctx (fixed-point ctx):\n" ^ eval_ctx_to_string fp_ctx + ^ "\n\n-tgt ctx (original context):\n" + ^ eval_ctx_to_string init_ctx)); + + prepare_match_ctx_with_target config span loop_id fixed_ids fp_ctx init_ctx + in + + (* Actually match *) + log#ldebug + (lazy + ("eval_loop_symbolic_synthesize_fun_end: about to compute the id \ + correspondance between the fixed-point ctx and the original ctx:\n\ + - src ctx (fixed-point ctx)\n" ^ eval_ctx_to_string fp_ctx + ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ctx)); + + (* Compute the id correspondance between the contexts *) + let fp_bl_corresp = + compute_fixed_point_id_correspondance span fixed_ids ctx fp_ctx + in + log#ldebug + (lazy + ("eval_loop_symbolic_synthesize_fun_end: about to match the fixed-point \ + context with the original context:\n\ + - src ctx (fixed-point ctx)" + ^ eval_ctx_to_string ~span:(Some span) fp_ctx + ^ "\n\n-tgt ctx (original context):\n" + ^ eval_ctx_to_string ~span:(Some span) ctx + ^ "\n\n- fp_bl_corresp:\n" + ^ show_borrow_loan_corresp fp_bl_corresp + ^ "\n")); + + (* Compute the end expression, that is the expresion corresponding to the + end of the function where we call the loop (for now, when calling a loop + we never get out) *) + let res_fun_end = + comp cf_prepare + (match_ctx_with_target config span loop_id true fp_bl_corresp + fp_input_svalues fixed_ids fp_ctx ctx) + in + + (* Sanity check: the mutable borrows/loans are properly ordered. + TODO: it seems that the way the fixed points are computed makes this check + always succeed. If it happens to fail we can reorder the borrows/loans + inside the region abstractions. *) + let check_abs (abs_id : AbstractionId.id) = + let abs = ctx_lookup_abs fp_ctx abs_id in + let is_borrow (av : typed_avalue) : bool = + match av.value with + | ABorrow _ -> true + | ALoan _ -> false + | _ -> craise __FILE__ __LINE__ span "Unreachable" + in + let borrows, loans = List.partition is_borrow abs.avalues in + + let mut_borrows = + List.filter_map + (fun (av : typed_avalue) -> + match av.value with + | ABorrow (AMutBorrow (pm, bid, child_av)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; + Some bid + | ABorrow (ASharedBorrow (pm, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + None + | _ -> craise __FILE__ __LINE__ span "Unreachable") + borrows + in + + let mut_loans = + List.filter_map + (fun (av : typed_avalue) -> + match av.value with + | ALoan (AMutLoan (pm, bid, child_av)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; + Some bid + | ALoan (ASharedLoan (pm, _, _, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + None + | _ -> craise __FILE__ __LINE__ span "Unreachable") + loans + in + + sanity_check __FILE__ __LINE__ + (List.length mut_borrows = List.length mut_loans) + span; + + let borrows_loans = List.combine mut_borrows mut_loans in + List.iter + (fun (bid, lid) -> + let lid_of_bid = + BorrowId.InjSubst.find bid fp_bl_corresp.borrow_to_loan_id_map + in + sanity_check __FILE__ __LINE__ (lid_of_bid = lid) span) + borrows_loans + in + List.iter check_abs (RegionGroupId.Map.values rg_to_abs); + + (* Return *) + (res_fun_end, fp_bl_corresp) + +(** Auxiliary function for {!eval_loop_symbolic}. + + Synthesize the body of the loop. + *) +let eval_loop_symbolic_synthesize_loop_body (config : config) (span : span) + (eval_loop_body : stl_cm_fun) (loop_id : LoopId.id) (fixed_ids : ids_sets) + (fp_ctx : eval_ctx) (fp_input_svalues : SymbolicValueId.id list) + (fp_bl_corresp : borrow_loan_corresp) : + (eval_ctx * statement_eval_res) list + * (SymbolicAst.expression list option -> eval_result) = + (* First, evaluate the loop body starting from the **fixed-point** context *) + let ctx_resl, cf_loop = eval_loop_body fp_ctx in + + (* Then, do a special treatment of the break and continue cases. + For now, we forbid having breaks in loops (and eliminate breaks + in the prepasses) *) + let eval_after_loop_iter (ctx, res) = + log#ldebug (lazy "eval_loop_symbolic: eval_after_loop_iter"); + match res with + | Return -> + (* We replace the [Return] with a [LoopReturn] *) + ((ctx, LoopReturn loop_id), fun e -> e) + | Panic -> ((ctx, res), fun e -> e) + | Break _ -> + (* Breaks should have been eliminated in the prepasses *) + craise __FILE__ __LINE__ span "Unexpected break" + | Continue i -> + (* We don't support nested loops for now *) + cassert __FILE__ __LINE__ (i = 0) span + "Nested loops are not supported yet"; + log#ldebug + (lazy + ("eval_loop_symbolic: about to match the fixed-point context with \ + the context at a continue:\n\ + - src ctx (fixed-point ctx)" + ^ eval_ctx_to_string ~span:(Some span) fp_ctx + ^ "\n\n-tgt ctx (ctx at continue):\n" + ^ eval_ctx_to_string ~span:(Some span) ctx)); + match_ctx_with_target config span loop_id false fp_bl_corresp + fp_input_svalues fixed_ids fp_ctx ctx + | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> + (* For why we can't get [Unit], see the comments inside {!eval_loop_concrete}. + For [EndEnterLoop] and [EndContinue]: we don't support nested loops for now. + *) + craise __FILE__ __LINE__ span "Unreachable" + in + + (* Apply and compose *) + let ctx_resl, cfl = List.split (List.map eval_after_loop_iter ctx_resl) in + let cc (el : SymbolicAst.expression list option) : eval_result = + match el with + | None -> None + | Some el -> + let el = + List.map + (fun (cf, e) -> Option.get (cf (Some e))) + (List.combine cfl el) + in + cf_loop (Some el) + in + + (ctx_resl, cc) + (** Evaluate a loop in symbolic mode *) let eval_loop_symbolic (config : config) (span : span) (eval_loop_body : stl_cm_fun) : stl_cm_fun = @@ -105,115 +301,25 @@ let eval_loop_symbolic (config : config) (span : span) (* 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 - will end with a call to the loop translation - *) - let ((res_fun_end, cf_fun_end), fp_bl_corresp) : - ((eval_ctx * statement_eval_res) * (eval_result -> eval_result)) * _ = - (* First, preemptively end borrows/move values by matching the current - context with the target context *) - let ctx, cf_prepare = - log#ldebug - (lazy - ("eval_loop_symbolic: about to reorganize the original context to \ - match the fixed-point ctx with it:\n\ - - src ctx (fixed-point ctx):\n" ^ eval_ctx_to_string fp_ctx - ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ctx)); - - prepare_match_ctx_with_target config span loop_id fixed_ids fp_ctx ctx - in + will end with a call to the loop translation. - (* Actually match *) - log#ldebug - (lazy - ("eval_loop_symbolic: about to compute the id correspondance between \ - the fixed-point ctx and the original ctx:\n\ - - src ctx (fixed-point ctx)" ^ eval_ctx_to_string fp_ctx - ^ "\n\n-tgt ctx (original context):\n" ^ eval_ctx_to_string ctx)); - - (* Compute the id correspondance between the contexts *) - let fp_bl_corresp = - compute_fixed_point_id_correspondance span fixed_ids ctx fp_ctx - in - log#ldebug - (lazy - ("eval_loop_symbolic: about to match the fixed-point context with the \ - original context:\n\ - - src ctx (fixed-point ctx)" - ^ eval_ctx_to_string ~span:(Some span) fp_ctx - ^ "\n\n-tgt ctx (original context):\n" - ^ eval_ctx_to_string ~span:(Some span) ctx)); - - (* Compute the end expression, that is the expresion corresponding to the - end of the function where we call the loop (for now, when calling a loop - we never get out) *) - let res_fun_end = - comp cf_prepare - (match_ctx_with_target config span loop_id true fp_bl_corresp - fp_input_svalues fixed_ids fp_ctx ctx) - in - (res_fun_end, fp_bl_corresp) + We update the loop fixed point at the same time by reordering the borrows/ + loans which appear inside it. + *) + let (res_fun_end, cf_fun_end), fp_bl_corresp = + eval_loop_symbolic_synthesize_fun_end config span loop_id ctx fixed_ids + fp_ctx fp_input_svalues rg_to_abs in + log#ldebug (lazy "eval_loop_symbolic: matched the fixed-point context with the original \ - context"); + context."); (* Synthesize the loop body *) - let (resl_loop_body, cf_loop_body) : - (eval_ctx * statement_eval_res) list - * (SymbolicAst.expression list option -> eval_result) = - (* First, evaluate the loop body starting from the **fixed-point** context *) - let ctx_resl, cf_loop = eval_loop_body fp_ctx in - - (* Then, do a special treatment of the break and continue cases. - For now, we forbid having breaks in loops (and eliminate breaks - in the prepasses) *) - let eval_after_loop_iter (ctx, res) = - log#ldebug (lazy "eval_loop_symbolic: eval_after_loop_iter"); - match res with - | Return -> - (* We replace the [Return] with a [LoopReturn] *) - ((ctx, LoopReturn loop_id), fun e -> e) - | Panic -> ((ctx, res), fun e -> e) - | Break _ -> - (* Breaks should have been eliminated in the prepasses *) - craise __FILE__ __LINE__ span "Unexpected break" - | Continue i -> - (* We don't support nested loops for now *) - cassert __FILE__ __LINE__ (i = 0) span - "Nested loops are not supported yet"; - log#ldebug - (lazy - ("eval_loop_symbolic: about to match the fixed-point context \ - with the context at a continue:\n\ - - src ctx (fixed-point ctx)" - ^ eval_ctx_to_string ~span:(Some span) fp_ctx - ^ "\n\n-tgt ctx (ctx at continue):\n" - ^ eval_ctx_to_string ~span:(Some span) ctx)); - match_ctx_with_target config span loop_id false fp_bl_corresp - fp_input_svalues fixed_ids fp_ctx ctx - | Unit | LoopReturn _ | EndEnterLoop _ | EndContinue _ -> - (* For why we can't get [Unit], see the comments inside {!eval_loop_concrete}. - For [EndEnterLoop] and [EndContinue]: we don't support nested loops for now. - *) - craise __FILE__ __LINE__ span "Unreachable" - in - - (* Apply and compose *) - let ctx_resl, cfl = List.split (List.map eval_after_loop_iter ctx_resl) in - let cc (el : SymbolicAst.expression list option) : eval_result = - match el with - | None -> None - | Some el -> - let el = - List.map - (fun (cf, e) -> Option.get (cf (Some e))) - (List.combine cfl el) - in - cf_loop (Some el) - in - - (ctx_resl, cc) + let resl_loop_body, cf_loop_body = + eval_loop_symbolic_synthesize_loop_body config span eval_loop_body loop_id + fixed_ids fp_ctx fp_input_svalues fp_bl_corresp in log#ldebug @@ -242,61 +348,33 @@ let eval_loop_symbolic (config : config) (span : span) return nothing. *) let rg_to_given_back = - let compute_abs_given_back_tys (abs : abs) : rty list = + let compute_abs_given_back_tys (abs_id : AbstractionId.id) : rty list = + let abs = ctx_lookup_abs fp_ctx abs_id in + log#ldebug + (lazy + ("eval_loop_symbolic: compute_abs_given_back_tys:\n- abs:\n" + ^ abs_to_string span ctx abs ^ "\n")); + let is_borrow (av : typed_avalue) : bool = match av.value with | ABorrow _ -> true | ALoan _ -> false | _ -> craise __FILE__ __LINE__ span "Unreachable" in - let borrows, loans = List.partition is_borrow abs.avalues in - - let borrows = - List.filter_map - (fun (av : typed_avalue) -> - match av.value with - | ABorrow (AMutBorrow (pm, bid, child_av)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; - Some (bid, child_av.ty) - | ABorrow (ASharedBorrow (pm, _)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - None - | _ -> craise __FILE__ __LINE__ span "Unreachable") - borrows - in - let borrows = ref (BorrowId.Map.of_list borrows) in - - let loan_ids = - List.filter_map - (fun (av : typed_avalue) -> - match av.value with - | ALoan (AMutLoan (pm, bid, child_av)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; - Some bid - | ALoan (ASharedLoan (pm, _, _, _)) -> - sanity_check __FILE__ __LINE__ (pm = PNone) span; - None - | _ -> craise __FILE__ __LINE__ span "Unreachable") - loans - in - - (* List the given back types, in the order given by the loans *) - let given_back_tys = - List.map - (fun lid -> - let bid = - BorrowId.InjSubst.find lid fp_bl_corresp.loan_to_borrow_id_map - in - let ty = BorrowId.Map.find bid !borrows in - borrows := BorrowId.Map.remove bid !borrows; - ty) - loan_ids - in - sanity_check __FILE__ __LINE__ (BorrowId.Map.is_empty !borrows) span; - - given_back_tys + let borrows, _ = List.partition is_borrow abs.avalues in + + List.filter_map + (fun (av : typed_avalue) -> + match av.value with + | ABorrow (AMutBorrow (pm, _, child_av)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + sanity_check __FILE__ __LINE__ (is_aignored child_av.value) span; + Some child_av.ty + | ABorrow (ASharedBorrow (pm, _)) -> + sanity_check __FILE__ __LINE__ (pm = PNone) span; + None + | _ -> craise __FILE__ __LINE__ span "Unreachable") + borrows in RegionGroupId.Map.map compute_abs_given_back_tys rg_to_abs in diff --git a/compiler/InterpreterLoopsFixedPoint.ml b/compiler/InterpreterLoopsFixedPoint.ml index 79beb761..b68f2a4d 100644 --- a/compiler/InterpreterLoopsFixedPoint.ml +++ b/compiler/InterpreterLoopsFixedPoint.ml @@ -393,7 +393,7 @@ let prepare_ashared_loans_no_synth (span : Meta.span) (loop_id : LoopId.id) let compute_loop_entry_fixed_point (config : config) (span : Meta.span) (loop_id : LoopId.id) (eval_loop_body : stl_cm_fun) (ctx0 : eval_ctx) : - eval_ctx * ids_sets * abs RegionGroupId.Map.t = + eval_ctx * ids_sets * AbstractionId.id RegionGroupId.Map.t = (* Introduce "reborrows" for the shared values in the abstractions, so that the shared values in the fixed abstractions never get modified (technically, they are immutable, but in practice we can introduce more shared loans, or @@ -702,7 +702,9 @@ let compute_loop_entry_fixed_point (config : config) (span : Meta.span) let all_abs_ids = List.filter_map (function EAbs abs -> Some abs.abs_id | _ -> None) - !fp.env + (* TODO: we may want to use a different order, for instance the order + in which the regions were ended. *) + (List.rev !fp.env) in let _ = RegionGroupId.Map.iter @@ -764,8 +766,7 @@ let compute_loop_entry_fixed_point (config : config) (span : Meta.span) craise __FILE__ __LINE__ span "Unexpected") ids; (* Register the mapping *) - let abs = ctx_lookup_abs !fp !id0 in - rg_to_abs := RegionGroupId.Map.add_strict rg_id abs !rg_to_abs) + rg_to_abs := RegionGroupId.Map.add_strict rg_id !id0 !rg_to_abs) !fp_ended_aids in let rg_to_abs = !rg_to_abs in diff --git a/compiler/InterpreterLoopsFixedPoint.mli b/compiler/InterpreterLoopsFixedPoint.mli index 59d42812..8db7b973 100644 --- a/compiler/InterpreterLoopsFixedPoint.mli +++ b/compiler/InterpreterLoopsFixedPoint.mli @@ -81,10 +81,11 @@ val compute_loop_entry_fixed_point : Meta.span -> loop_id -> (* This function is the function to evaluate the loop body (eval_statement applied - to the proper arguments) *) + to the proper arguments). We need to take it as input because [compute_loop_entry_fixed_point] + is mutually recursive with [eval_statement], but doesn't live in the same module. *) Cps.stl_cm_fun -> eval_ctx -> - eval_ctx * ids_sets * abs SymbolicAst.region_group_id_map + eval_ctx * ids_sets * AbstractionId.id 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 -- cgit v1.2.3 From 374eb6fe2e35791e4f18e415cd8d761d89a8bec5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Mon, 3 Jun 2024 21:29:08 +0200 Subject: Add a test --- tests/coq/misc/NoNestedBorrows.v | 73 +++++++++++++++++++----------------- tests/fstar/misc/NoNestedBorrows.fst | 73 +++++++++++++++++++----------------- tests/lean/NoNestedBorrows.lean | 73 +++++++++++++++++++----------------- tests/src/no_nested_borrows.rs | 7 +++- 4 files changed, 123 insertions(+), 103 deletions(-) diff --git a/tests/coq/misc/NoNestedBorrows.v b/tests/coq/misc/NoNestedBorrows.v index a83347a7..de31fec7 100644 --- a/tests/coq/misc/NoNestedBorrows.v +++ b/tests/coq/misc/NoNestedBorrows.v @@ -243,14 +243,19 @@ Check (choose_test )%return. Definition test_char : result char := Ok (char_of_byte Coq.Init.Byte.x61). +(** [no_nested_borrows::panic_mut_borrow]: + Source: 'tests/src/no_nested_borrows.rs', lines 217:0-217:36 *) +Definition panic_mut_borrow (i : u32) : result u32 := + Fail_ Failure. + (** [no_nested_borrows::Tree] - Source: 'tests/src/no_nested_borrows.rs', lines 217:0-217:16 *) + Source: 'tests/src/no_nested_borrows.rs', lines 222:0-222: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: 'tests/src/no_nested_borrows.rs', lines 222:0-222:20 *) + Source: 'tests/src/no_nested_borrows.rs', lines 227:0-227:20 *) with NodeElem_t (T : Type) := | NodeElem_Cons : Tree_t T -> NodeElem_t T -> NodeElem_t T | NodeElem_Nil : NodeElem_t T @@ -263,7 +268,7 @@ Arguments NodeElem_Cons { _ }. Arguments NodeElem_Nil { _ }. (** [no_nested_borrows::list_length]: - Source: 'tests/src/no_nested_borrows.rs', lines 257:0-257:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 262:0-262:48 *) Fixpoint list_length (T : Type) (l : List_t T) : result u32 := match l with | List_Cons _ l1 => i <- list_length T l1; u32_add 1%u32 i @@ -272,7 +277,7 @@ Fixpoint list_length (T : Type) (l : List_t T) : result u32 := . (** [no_nested_borrows::list_nth_shared]: - Source: 'tests/src/no_nested_borrows.rs', lines 265:0-265:62 *) + Source: 'tests/src/no_nested_borrows.rs', lines 270:0-270:62 *) Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := match l with | List_Cons x tl => @@ -284,7 +289,7 @@ Fixpoint list_nth_shared (T : Type) (l : List_t T) (i : u32) : result T := . (** [no_nested_borrows::list_nth_mut]: - Source: 'tests/src/no_nested_borrows.rs', lines 281:0-281:67 *) + Source: 'tests/src/no_nested_borrows.rs', lines 286:0-286:67 *) Fixpoint list_nth_mut (T : Type) (l : List_t T) (i : u32) : result (T * (T -> result (List_t T))) @@ -305,7 +310,7 @@ Fixpoint list_nth_mut . (** [no_nested_borrows::list_rev_aux]: - Source: 'tests/src/no_nested_borrows.rs', lines 297:0-297:63 *) + Source: 'tests/src/no_nested_borrows.rs', lines 302:0-302:63 *) Fixpoint list_rev_aux (T : Type) (li : List_t T) (lo : List_t T) : result (List_t T) := match li with @@ -315,14 +320,14 @@ Fixpoint list_rev_aux . (** [no_nested_borrows::list_rev]: - Source: 'tests/src/no_nested_borrows.rs', lines 311:0-311:42 *) + Source: 'tests/src/no_nested_borrows.rs', lines 316:0-316: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]: - Source: 'tests/src/no_nested_borrows.rs', lines 316:0-316:28 *) + Source: 'tests/src/no_nested_borrows.rs', lines 321:0-321:28 *) Definition test_list_functions : result unit := let l := List_Cons 2%i32 List_Nil in let l1 := List_Cons 1%i32 l in @@ -361,7 +366,7 @@ Definition test_list_functions : result unit := Check (test_list_functions )%return. (** [no_nested_borrows::id_mut_pair1]: - Source: 'tests/src/no_nested_borrows.rs', lines 332:0-332:89 *) + Source: 'tests/src/no_nested_borrows.rs', lines 337:0-337:89 *) Definition id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : result ((T1 * T2) * ((T1 * T2) -> result (T1 * T2))) @@ -370,7 +375,7 @@ Definition id_mut_pair1 . (** [no_nested_borrows::id_mut_pair2]: - Source: 'tests/src/no_nested_borrows.rs', lines 336:0-336:88 *) + Source: 'tests/src/no_nested_borrows.rs', lines 341:0-341:88 *) Definition id_mut_pair2 (T1 T2 : Type) (p : (T1 * T2)) : result ((T1 * T2) * ((T1 * T2) -> result (T1 * T2))) @@ -379,7 +384,7 @@ Definition id_mut_pair2 . (** [no_nested_borrows::id_mut_pair3]: - Source: 'tests/src/no_nested_borrows.rs', lines 340:0-340:93 *) + Source: 'tests/src/no_nested_borrows.rs', lines 345:0-345:93 *) Definition id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : result ((T1 * T2) * (T1 -> result T1) * (T2 -> result T2)) @@ -388,7 +393,7 @@ Definition id_mut_pair3 . (** [no_nested_borrows::id_mut_pair4]: - Source: 'tests/src/no_nested_borrows.rs', lines 344:0-344:92 *) + Source: 'tests/src/no_nested_borrows.rs', lines 349:0-349:92 *) Definition id_mut_pair4 (T1 T2 : Type) (p : (T1 * T2)) : result ((T1 * T2) * (T1 -> result T1) * (T2 -> result T2)) @@ -397,7 +402,7 @@ Definition id_mut_pair4 . (** [no_nested_borrows::StructWithTuple] - Source: 'tests/src/no_nested_borrows.rs', lines 351:0-351:34 *) + Source: 'tests/src/no_nested_borrows.rs', lines 356:0-356:34 *) Record StructWithTuple_t (T1 T2 : Type) := mkStructWithTuple_t { structWithTuple_p : (T1 * T2); @@ -408,25 +413,25 @@ Arguments mkStructWithTuple_t { _ _ }. Arguments structWithTuple_p { _ _ }. (** [no_nested_borrows::new_tuple1]: - Source: 'tests/src/no_nested_borrows.rs', lines 355:0-355:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 360:0-360:48 *) Definition new_tuple1 : result (StructWithTuple_t u32 u32) := Ok {| structWithTuple_p := (1%u32, 2%u32) |} . (** [no_nested_borrows::new_tuple2]: - Source: 'tests/src/no_nested_borrows.rs', lines 359:0-359:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 364:0-364:48 *) Definition new_tuple2 : result (StructWithTuple_t i16 i16) := Ok {| structWithTuple_p := (1%i16, 2%i16) |} . (** [no_nested_borrows::new_tuple3]: - Source: 'tests/src/no_nested_borrows.rs', lines 363:0-363:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 368:0-368:48 *) Definition new_tuple3 : result (StructWithTuple_t u64 i64) := Ok {| structWithTuple_p := (1%u64, 2%i64) |} . (** [no_nested_borrows::StructWithPair] - Source: 'tests/src/no_nested_borrows.rs', lines 368:0-368:33 *) + Source: 'tests/src/no_nested_borrows.rs', lines 373:0-373:33 *) Record StructWithPair_t (T1 T2 : Type) := mkStructWithPair_t { structWithPair_p : Pair_t T1 T2; @@ -437,13 +442,13 @@ Arguments mkStructWithPair_t { _ _ }. Arguments structWithPair_p { _ _ }. (** [no_nested_borrows::new_pair1]: - Source: 'tests/src/no_nested_borrows.rs', lines 372:0-372:46 *) + Source: 'tests/src/no_nested_borrows.rs', lines 377:0-377:46 *) Definition new_pair1 : result (StructWithPair_t u32 u32) := Ok {| structWithPair_p := {| pair_x := 1%u32; pair_y := 2%u32 |} |} . (** [no_nested_borrows::test_constants]: - Source: 'tests/src/no_nested_borrows.rs', lines 380:0-380:23 *) + Source: 'tests/src/no_nested_borrows.rs', lines 385:0-385:23 *) Definition test_constants : result unit := swt <- new_tuple1; let (i, _) := swt.(structWithTuple_p) in @@ -470,7 +475,7 @@ Definition test_constants : result unit := Check (test_constants )%return. (** [no_nested_borrows::test_weird_borrows1]: - Source: 'tests/src/no_nested_borrows.rs', lines 389:0-389:28 *) + Source: 'tests/src/no_nested_borrows.rs', lines 394:0-394:28 *) Definition test_weird_borrows1 : result unit := Ok tt. @@ -478,78 +483,78 @@ Definition test_weird_borrows1 : result unit := Check (test_weird_borrows1 )%return. (** [no_nested_borrows::test_mem_replace]: - Source: 'tests/src/no_nested_borrows.rs', lines 399:0-399:37 *) + Source: 'tests/src/no_nested_borrows.rs', lines 404:0-404: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 Ok 2%u32 . (** [no_nested_borrows::test_shared_borrow_bool1]: - Source: 'tests/src/no_nested_borrows.rs', lines 406:0-406:47 *) + Source: 'tests/src/no_nested_borrows.rs', lines 411:0-411:47 *) Definition test_shared_borrow_bool1 (b : bool) : result u32 := if b then Ok 0%u32 else Ok 1%u32 . (** [no_nested_borrows::test_shared_borrow_bool2]: - Source: 'tests/src/no_nested_borrows.rs', lines 419:0-419:40 *) + Source: 'tests/src/no_nested_borrows.rs', lines 424:0-424:40 *) Definition test_shared_borrow_bool2 : result u32 := Ok 0%u32. (** [no_nested_borrows::test_shared_borrow_enum1]: - Source: 'tests/src/no_nested_borrows.rs', lines 434:0-434:52 *) + Source: 'tests/src/no_nested_borrows.rs', lines 439:0-439:52 *) Definition test_shared_borrow_enum1 (l : List_t u32) : result u32 := match l with | List_Cons _ _ => Ok 1%u32 | List_Nil => Ok 0%u32 end . (** [no_nested_borrows::test_shared_borrow_enum2]: - Source: 'tests/src/no_nested_borrows.rs', lines 446:0-446:40 *) + Source: 'tests/src/no_nested_borrows.rs', lines 451:0-451:40 *) Definition test_shared_borrow_enum2 : result u32 := Ok 0%u32. (** [no_nested_borrows::incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 457:0-457:24 *) + Source: 'tests/src/no_nested_borrows.rs', lines 462:0-462:24 *) Definition incr (x : u32) : result u32 := u32_add x 1%u32. (** [no_nested_borrows::call_incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 461:0-461:35 *) + Source: 'tests/src/no_nested_borrows.rs', lines 466:0-466:35 *) Definition call_incr (x : u32) : result u32 := incr x. (** [no_nested_borrows::read_then_incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 466:0-466:41 *) + Source: 'tests/src/no_nested_borrows.rs', lines 471:0-471:41 *) Definition read_then_incr (x : u32) : result (u32 * u32) := x1 <- u32_add x 1%u32; Ok (x, x1) . (** [no_nested_borrows::Tuple] - Source: 'tests/src/no_nested_borrows.rs', lines 472:0-472:24 *) + Source: 'tests/src/no_nested_borrows.rs', lines 477:0-477:24 *) Definition Tuple_t (T1 T2 : Type) : Type := T1 * T2. (** [no_nested_borrows::use_tuple_struct]: - Source: 'tests/src/no_nested_borrows.rs', lines 474:0-474:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 479:0-479:48 *) Definition use_tuple_struct (x : Tuple_t u32 u32) : result (Tuple_t u32 u32) := let (_, i) := x in Ok (1%u32, i) . (** [no_nested_borrows::create_tuple_struct]: - Source: 'tests/src/no_nested_borrows.rs', lines 478:0-478:61 *) + Source: 'tests/src/no_nested_borrows.rs', lines 483:0-483:61 *) Definition create_tuple_struct (x : u32) (y : u64) : result (Tuple_t u32 u64) := Ok (x, y) . (** [no_nested_borrows::IdType] - Source: 'tests/src/no_nested_borrows.rs', lines 483:0-483:20 *) + Source: 'tests/src/no_nested_borrows.rs', lines 488:0-488:20 *) Definition IdType_t (T : Type) : Type := T. (** [no_nested_borrows::use_id_type]: - Source: 'tests/src/no_nested_borrows.rs', lines 485:0-485:40 *) + Source: 'tests/src/no_nested_borrows.rs', lines 490:0-490:40 *) Definition use_id_type (T : Type) (x : IdType_t T) : result T := Ok x. (** [no_nested_borrows::create_id_type]: - Source: 'tests/src/no_nested_borrows.rs', lines 489:0-489:43 *) + Source: 'tests/src/no_nested_borrows.rs', lines 494:0-494:43 *) Definition create_id_type (T : Type) (x : T) : result (IdType_t T) := Ok x. diff --git a/tests/fstar/misc/NoNestedBorrows.fst b/tests/fstar/misc/NoNestedBorrows.fst index 340dd293..5fd775cb 100644 --- a/tests/fstar/misc/NoNestedBorrows.fst +++ b/tests/fstar/misc/NoNestedBorrows.fst @@ -211,20 +211,25 @@ let _ = assert_norm (choose_test = Ok ()) let test_char : result char = Ok 'a' +(** [no_nested_borrows::panic_mut_borrow]: + Source: 'tests/src/no_nested_borrows.rs', lines 217:0-217:36 *) +let panic_mut_borrow (i : u32) : result u32 = + Fail Failure + (** [no_nested_borrows::Tree] - Source: 'tests/src/no_nested_borrows.rs', lines 217:0-217:16 *) + Source: 'tests/src/no_nested_borrows.rs', lines 222:0-222: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: 'tests/src/no_nested_borrows.rs', lines 222:0-222:20 *) + Source: 'tests/src/no_nested_borrows.rs', lines 227:0-227: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]: - Source: 'tests/src/no_nested_borrows.rs', lines 257:0-257:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 262:0-262:48 *) let rec list_length (t : Type0) (l : list_t t) : result u32 = begin match l with | List_Cons _ l1 -> let* i = list_length t l1 in u32_add 1 i @@ -232,7 +237,7 @@ let rec list_length (t : Type0) (l : list_t t) : result u32 = end (** [no_nested_borrows::list_nth_shared]: - Source: 'tests/src/no_nested_borrows.rs', lines 265:0-265:62 *) + Source: 'tests/src/no_nested_borrows.rs', lines 270:0-270:62 *) let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = begin match l with | List_Cons x tl -> @@ -241,7 +246,7 @@ let rec list_nth_shared (t : Type0) (l : list_t t) (i : u32) : result t = end (** [no_nested_borrows::list_nth_mut]: - Source: 'tests/src/no_nested_borrows.rs', lines 281:0-281:67 *) + Source: 'tests/src/no_nested_borrows.rs', lines 286:0-286:67 *) let rec list_nth_mut (t : Type0) (l : list_t t) (i : u32) : result (t & (t -> result (list_t t))) @@ -260,7 +265,7 @@ let rec list_nth_mut end (** [no_nested_borrows::list_rev_aux]: - Source: 'tests/src/no_nested_borrows.rs', lines 297:0-297:63 *) + Source: 'tests/src/no_nested_borrows.rs', lines 302:0-302:63 *) let rec list_rev_aux (t : Type0) (li : list_t t) (lo : list_t t) : result (list_t t) = begin match li with @@ -269,13 +274,13 @@ let rec list_rev_aux end (** [no_nested_borrows::list_rev]: - Source: 'tests/src/no_nested_borrows.rs', lines 311:0-311:42 *) + Source: 'tests/src/no_nested_borrows.rs', lines 316:0-316: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]: - Source: 'tests/src/no_nested_borrows.rs', lines 316:0-316:28 *) + Source: 'tests/src/no_nested_borrows.rs', lines 321:0-321:28 *) let test_list_functions : result unit = let l = List_Cons 2 List_Nil in let l1 = List_Cons 1 l in @@ -312,7 +317,7 @@ let test_list_functions : result unit = let _ = assert_norm (test_list_functions = Ok ()) (** [no_nested_borrows::id_mut_pair1]: - Source: 'tests/src/no_nested_borrows.rs', lines 332:0-332:89 *) + Source: 'tests/src/no_nested_borrows.rs', lines 337:0-337:89 *) let id_mut_pair1 (t1 t2 : Type0) (x : t1) (y : t2) : result ((t1 & t2) & ((t1 & t2) -> result (t1 & t2))) @@ -320,7 +325,7 @@ let id_mut_pair1 Ok ((x, y), Ok) (** [no_nested_borrows::id_mut_pair2]: - Source: 'tests/src/no_nested_borrows.rs', lines 336:0-336:88 *) + Source: 'tests/src/no_nested_borrows.rs', lines 341:0-341:88 *) let id_mut_pair2 (t1 t2 : Type0) (p : (t1 & t2)) : result ((t1 & t2) & ((t1 & t2) -> result (t1 & t2))) @@ -328,7 +333,7 @@ let id_mut_pair2 let (x, x1) = p in Ok ((x, x1), Ok) (** [no_nested_borrows::id_mut_pair3]: - Source: 'tests/src/no_nested_borrows.rs', lines 340:0-340:93 *) + Source: 'tests/src/no_nested_borrows.rs', lines 345:0-345:93 *) let id_mut_pair3 (t1 t2 : Type0) (x : t1) (y : t2) : result ((t1 & t2) & (t1 -> result t1) & (t2 -> result t2)) @@ -336,7 +341,7 @@ let id_mut_pair3 Ok ((x, y), Ok, Ok) (** [no_nested_borrows::id_mut_pair4]: - Source: 'tests/src/no_nested_borrows.rs', lines 344:0-344:92 *) + Source: 'tests/src/no_nested_borrows.rs', lines 349:0-349:92 *) let id_mut_pair4 (t1 t2 : Type0) (p : (t1 & t2)) : result ((t1 & t2) & (t1 -> result t1) & (t2 -> result t2)) @@ -344,35 +349,35 @@ let id_mut_pair4 let (x, x1) = p in Ok ((x, x1), Ok, Ok) (** [no_nested_borrows::StructWithTuple] - Source: 'tests/src/no_nested_borrows.rs', lines 351:0-351:34 *) + Source: 'tests/src/no_nested_borrows.rs', lines 356:0-356:34 *) type structWithTuple_t (t1 t2 : Type0) = { p : (t1 & t2); } (** [no_nested_borrows::new_tuple1]: - Source: 'tests/src/no_nested_borrows.rs', lines 355:0-355:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 360:0-360:48 *) let new_tuple1 : result (structWithTuple_t u32 u32) = Ok { p = (1, 2) } (** [no_nested_borrows::new_tuple2]: - Source: 'tests/src/no_nested_borrows.rs', lines 359:0-359:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 364:0-364:48 *) let new_tuple2 : result (structWithTuple_t i16 i16) = Ok { p = (1, 2) } (** [no_nested_borrows::new_tuple3]: - Source: 'tests/src/no_nested_borrows.rs', lines 363:0-363:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 368:0-368:48 *) let new_tuple3 : result (structWithTuple_t u64 i64) = Ok { p = (1, 2) } (** [no_nested_borrows::StructWithPair] - Source: 'tests/src/no_nested_borrows.rs', lines 368:0-368:33 *) + Source: 'tests/src/no_nested_borrows.rs', lines 373:0-373:33 *) type structWithPair_t (t1 t2 : Type0) = { p : pair_t t1 t2; } (** [no_nested_borrows::new_pair1]: - Source: 'tests/src/no_nested_borrows.rs', lines 372:0-372:46 *) + Source: 'tests/src/no_nested_borrows.rs', lines 377:0-377:46 *) let new_pair1 : result (structWithPair_t u32 u32) = Ok { p = { x = 1; y = 2 } } (** [no_nested_borrows::test_constants]: - Source: 'tests/src/no_nested_borrows.rs', lines 380:0-380:23 *) + Source: 'tests/src/no_nested_borrows.rs', lines 385:0-385:23 *) let test_constants : result unit = let* swt = new_tuple1 in let (i, _) = swt.p in @@ -396,7 +401,7 @@ let test_constants : result unit = let _ = assert_norm (test_constants = Ok ()) (** [no_nested_borrows::test_weird_borrows1]: - Source: 'tests/src/no_nested_borrows.rs', lines 389:0-389:28 *) + Source: 'tests/src/no_nested_borrows.rs', lines 394:0-394:28 *) let test_weird_borrows1 : result unit = Ok () @@ -404,71 +409,71 @@ let test_weird_borrows1 : result unit = let _ = assert_norm (test_weird_borrows1 = Ok ()) (** [no_nested_borrows::test_mem_replace]: - Source: 'tests/src/no_nested_borrows.rs', lines 399:0-399:37 *) + Source: 'tests/src/no_nested_borrows.rs', lines 404:0-404: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 Ok 2 (** [no_nested_borrows::test_shared_borrow_bool1]: - Source: 'tests/src/no_nested_borrows.rs', lines 406:0-406:47 *) + Source: 'tests/src/no_nested_borrows.rs', lines 411:0-411:47 *) let test_shared_borrow_bool1 (b : bool) : result u32 = if b then Ok 0 else Ok 1 (** [no_nested_borrows::test_shared_borrow_bool2]: - Source: 'tests/src/no_nested_borrows.rs', lines 419:0-419:40 *) + Source: 'tests/src/no_nested_borrows.rs', lines 424:0-424:40 *) let test_shared_borrow_bool2 : result u32 = Ok 0 (** [no_nested_borrows::test_shared_borrow_enum1]: - Source: 'tests/src/no_nested_borrows.rs', lines 434:0-434:52 *) + Source: 'tests/src/no_nested_borrows.rs', lines 439:0-439:52 *) let test_shared_borrow_enum1 (l : list_t u32) : result u32 = begin match l with | List_Cons _ _ -> Ok 1 | List_Nil -> Ok 0 end (** [no_nested_borrows::test_shared_borrow_enum2]: - Source: 'tests/src/no_nested_borrows.rs', lines 446:0-446:40 *) + Source: 'tests/src/no_nested_borrows.rs', lines 451:0-451:40 *) let test_shared_borrow_enum2 : result u32 = Ok 0 (** [no_nested_borrows::incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 457:0-457:24 *) + Source: 'tests/src/no_nested_borrows.rs', lines 462:0-462:24 *) let incr (x : u32) : result u32 = u32_add x 1 (** [no_nested_borrows::call_incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 461:0-461:35 *) + Source: 'tests/src/no_nested_borrows.rs', lines 466:0-466:35 *) let call_incr (x : u32) : result u32 = incr x (** [no_nested_borrows::read_then_incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 466:0-466:41 *) + Source: 'tests/src/no_nested_borrows.rs', lines 471:0-471:41 *) let read_then_incr (x : u32) : result (u32 & u32) = let* x1 = u32_add x 1 in Ok (x, x1) (** [no_nested_borrows::Tuple] - Source: 'tests/src/no_nested_borrows.rs', lines 472:0-472:24 *) + Source: 'tests/src/no_nested_borrows.rs', lines 477:0-477:24 *) type tuple_t (t1 t2 : Type0) = t1 * t2 (** [no_nested_borrows::use_tuple_struct]: - Source: 'tests/src/no_nested_borrows.rs', lines 474:0-474:48 *) + Source: 'tests/src/no_nested_borrows.rs', lines 479:0-479:48 *) let use_tuple_struct (x : tuple_t u32 u32) : result (tuple_t u32 u32) = let (_, i) = x in Ok (1, i) (** [no_nested_borrows::create_tuple_struct]: - Source: 'tests/src/no_nested_borrows.rs', lines 478:0-478:61 *) + Source: 'tests/src/no_nested_borrows.rs', lines 483:0-483:61 *) let create_tuple_struct (x : u32) (y : u64) : result (tuple_t u32 u64) = Ok (x, y) (** [no_nested_borrows::IdType] - Source: 'tests/src/no_nested_borrows.rs', lines 483:0-483:20 *) + Source: 'tests/src/no_nested_borrows.rs', lines 488:0-488:20 *) type idType_t (t : Type0) = t (** [no_nested_borrows::use_id_type]: - Source: 'tests/src/no_nested_borrows.rs', lines 485:0-485:40 *) + Source: 'tests/src/no_nested_borrows.rs', lines 490:0-490:40 *) let use_id_type (t : Type0) (x : idType_t t) : result t = Ok x (** [no_nested_borrows::create_id_type]: - Source: 'tests/src/no_nested_borrows.rs', lines 489:0-489:43 *) + Source: 'tests/src/no_nested_borrows.rs', lines 494:0-494:43 *) let create_id_type (t : Type0) (x : t) : result (idType_t t) = Ok x diff --git a/tests/lean/NoNestedBorrows.lean b/tests/lean/NoNestedBorrows.lean index 5ae22055..0f11092d 100644 --- a/tests/lean/NoNestedBorrows.lean +++ b/tests/lean/NoNestedBorrows.lean @@ -258,16 +258,21 @@ def choose_test : Result Unit := def test_char : Result Char := Result.ok 'a' +/- [no_nested_borrows::panic_mut_borrow]: + Source: 'tests/src/no_nested_borrows.rs', lines 217:0-217:36 -/ +def panic_mut_borrow (i : U32) : Result U32 := + Result.fail .panic + mutual /- [no_nested_borrows::Tree] - Source: 'tests/src/no_nested_borrows.rs', lines 217:0-217:16 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 222:0-222:16 -/ inductive Tree (T : Type) := | Leaf : T → Tree T | Node : T → NodeElem T → Tree T → Tree T /- [no_nested_borrows::NodeElem] - Source: 'tests/src/no_nested_borrows.rs', lines 222:0-222:20 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 227:0-227:20 -/ inductive NodeElem (T : Type) := | Cons : Tree T → NodeElem T → NodeElem T | Nil : NodeElem T @@ -275,7 +280,7 @@ inductive NodeElem (T : Type) := end /- [no_nested_borrows::list_length]: - Source: 'tests/src/no_nested_borrows.rs', lines 257:0-257:48 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 262:0-262:48 -/ divergent def list_length (T : Type) (l : List T) : Result U32 := match l with | List.Cons _ l1 => do @@ -284,7 +289,7 @@ divergent def list_length (T : Type) (l : List T) : Result U32 := | List.Nil => Result.ok 0#u32 /- [no_nested_borrows::list_nth_shared]: - Source: 'tests/src/no_nested_borrows.rs', lines 265:0-265:62 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 270:0-270:62 -/ divergent def list_nth_shared (T : Type) (l : List T) (i : U32) : Result T := match l with | List.Cons x tl => @@ -296,7 +301,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]: - Source: 'tests/src/no_nested_borrows.rs', lines 281:0-281:67 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 286:0-286:67 -/ divergent def list_nth_mut (T : Type) (l : List T) (i : U32) : Result (T × (T → Result (List T))) := match l with @@ -318,7 +323,7 @@ divergent def list_nth_mut | List.Nil => Result.fail .panic /- [no_nested_borrows::list_rev_aux]: - Source: 'tests/src/no_nested_borrows.rs', lines 297:0-297:63 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 302:0-302:63 -/ divergent def list_rev_aux (T : Type) (li : List T) (lo : List T) : Result (List T) := match li with @@ -326,13 +331,13 @@ divergent def list_rev_aux | List.Nil => Result.ok lo /- [no_nested_borrows::list_rev]: - Source: 'tests/src/no_nested_borrows.rs', lines 311:0-311:42 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 316:0-316: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]: - Source: 'tests/src/no_nested_borrows.rs', lines 316:0-316:28 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 321:0-321:28 -/ def test_list_functions : Result Unit := do let l := List.Cons 2#i32 List.Nil @@ -379,7 +384,7 @@ def test_list_functions : Result Unit := #assert (test_list_functions == Result.ok ()) /- [no_nested_borrows::id_mut_pair1]: - Source: 'tests/src/no_nested_borrows.rs', lines 332:0-332:89 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 337:0-337:89 -/ def id_mut_pair1 (T1 T2 : Type) (x : T1) (y : T2) : Result ((T1 × T2) × ((T1 × T2) → Result (T1 × T2))) @@ -387,7 +392,7 @@ def id_mut_pair1 Result.ok ((x, y), Result.ok) /- [no_nested_borrows::id_mut_pair2]: - Source: 'tests/src/no_nested_borrows.rs', lines 336:0-336:88 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 341:0-341:88 -/ def id_mut_pair2 (T1 T2 : Type) (p : (T1 × T2)) : Result ((T1 × T2) × ((T1 × T2) → Result (T1 × T2))) @@ -396,7 +401,7 @@ def id_mut_pair2 Result.ok ((t, t1), Result.ok) /- [no_nested_borrows::id_mut_pair3]: - Source: 'tests/src/no_nested_borrows.rs', lines 340:0-340:93 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 345:0-345:93 -/ def id_mut_pair3 (T1 T2 : Type) (x : T1) (y : T2) : Result ((T1 × T2) × (T1 → Result T1) × (T2 → Result T2)) @@ -404,7 +409,7 @@ def id_mut_pair3 Result.ok ((x, y), Result.ok, Result.ok) /- [no_nested_borrows::id_mut_pair4]: - Source: 'tests/src/no_nested_borrows.rs', lines 344:0-344:92 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 349:0-349:92 -/ def id_mut_pair4 (T1 T2 : Type) (p : (T1 × T2)) : Result ((T1 × T2) × (T1 → Result T1) × (T2 → Result T2)) @@ -413,37 +418,37 @@ def id_mut_pair4 Result.ok ((t, t1), Result.ok, Result.ok) /- [no_nested_borrows::StructWithTuple] - Source: 'tests/src/no_nested_borrows.rs', lines 351:0-351:34 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 356:0-356:34 -/ structure StructWithTuple (T1 T2 : Type) where p : (T1 × T2) /- [no_nested_borrows::new_tuple1]: - Source: 'tests/src/no_nested_borrows.rs', lines 355:0-355:48 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 360:0-360:48 -/ def new_tuple1 : Result (StructWithTuple U32 U32) := Result.ok { p := (1#u32, 2#u32) } /- [no_nested_borrows::new_tuple2]: - Source: 'tests/src/no_nested_borrows.rs', lines 359:0-359:48 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 364:0-364:48 -/ def new_tuple2 : Result (StructWithTuple I16 I16) := Result.ok { p := (1#i16, 2#i16) } /- [no_nested_borrows::new_tuple3]: - Source: 'tests/src/no_nested_borrows.rs', lines 363:0-363:48 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 368:0-368:48 -/ def new_tuple3 : Result (StructWithTuple U64 I64) := Result.ok { p := (1#u64, 2#i64) } /- [no_nested_borrows::StructWithPair] - Source: 'tests/src/no_nested_borrows.rs', lines 368:0-368:33 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 373:0-373:33 -/ structure StructWithPair (T1 T2 : Type) where p : Pair T1 T2 /- [no_nested_borrows::new_pair1]: - Source: 'tests/src/no_nested_borrows.rs', lines 372:0-372:46 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 377:0-377:46 -/ def new_pair1 : Result (StructWithPair U32 U32) := Result.ok { p := { x := 1#u32, y := 2#u32 } } /- [no_nested_borrows::test_constants]: - Source: 'tests/src/no_nested_borrows.rs', lines 380:0-380:23 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 385:0-385:23 -/ def test_constants : Result Unit := do let swt ← new_tuple1 @@ -473,7 +478,7 @@ def test_constants : Result Unit := #assert (test_constants == Result.ok ()) /- [no_nested_borrows::test_weird_borrows1]: - Source: 'tests/src/no_nested_borrows.rs', lines 389:0-389:28 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 394:0-394:28 -/ def test_weird_borrows1 : Result Unit := Result.ok () @@ -481,7 +486,7 @@ def test_weird_borrows1 : Result Unit := #assert (test_weird_borrows1 == Result.ok ()) /- [no_nested_borrows::test_mem_replace]: - Source: 'tests/src/no_nested_borrows.rs', lines 399:0-399:37 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 404:0-404:37 -/ def test_mem_replace (px : U32) : Result U32 := let (y, _) := core.mem.replace U32 px 1#u32 if ¬ (y = 0#u32) @@ -489,71 +494,71 @@ def test_mem_replace (px : U32) : Result U32 := else Result.ok 2#u32 /- [no_nested_borrows::test_shared_borrow_bool1]: - Source: 'tests/src/no_nested_borrows.rs', lines 406:0-406:47 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 411:0-411:47 -/ def test_shared_borrow_bool1 (b : Bool) : Result U32 := if b then Result.ok 0#u32 else Result.ok 1#u32 /- [no_nested_borrows::test_shared_borrow_bool2]: - Source: 'tests/src/no_nested_borrows.rs', lines 419:0-419:40 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 424:0-424:40 -/ def test_shared_borrow_bool2 : Result U32 := Result.ok 0#u32 /- [no_nested_borrows::test_shared_borrow_enum1]: - Source: 'tests/src/no_nested_borrows.rs', lines 434:0-434:52 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 439:0-439:52 -/ def test_shared_borrow_enum1 (l : List U32) : Result U32 := match l with | List.Cons _ _ => Result.ok 1#u32 | List.Nil => Result.ok 0#u32 /- [no_nested_borrows::test_shared_borrow_enum2]: - Source: 'tests/src/no_nested_borrows.rs', lines 446:0-446:40 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 451:0-451:40 -/ def test_shared_borrow_enum2 : Result U32 := Result.ok 0#u32 /- [no_nested_borrows::incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 457:0-457:24 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 462:0-462:24 -/ def incr (x : U32) : Result U32 := x + 1#u32 /- [no_nested_borrows::call_incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 461:0-461:35 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 466:0-466:35 -/ def call_incr (x : U32) : Result U32 := incr x /- [no_nested_borrows::read_then_incr]: - Source: 'tests/src/no_nested_borrows.rs', lines 466:0-466:41 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 471:0-471:41 -/ def read_then_incr (x : U32) : Result (U32 × U32) := do let x1 ← x + 1#u32 Result.ok (x, x1) /- [no_nested_borrows::Tuple] - Source: 'tests/src/no_nested_borrows.rs', lines 472:0-472:24 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 477:0-477:24 -/ def Tuple (T1 T2 : Type) := T1 × T2 /- [no_nested_borrows::use_tuple_struct]: - Source: 'tests/src/no_nested_borrows.rs', lines 474:0-474:48 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 479:0-479:48 -/ def use_tuple_struct (x : Tuple U32 U32) : Result (Tuple U32 U32) := Result.ok (1#u32, x.#1) /- [no_nested_borrows::create_tuple_struct]: - Source: 'tests/src/no_nested_borrows.rs', lines 478:0-478:61 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 483:0-483:61 -/ def create_tuple_struct (x : U32) (y : U64) : Result (Tuple U32 U64) := Result.ok (x, y) /- [no_nested_borrows::IdType] - Source: 'tests/src/no_nested_borrows.rs', lines 483:0-483:20 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 488:0-488:20 -/ @[reducible] def IdType (T : Type) := T /- [no_nested_borrows::use_id_type]: - Source: 'tests/src/no_nested_borrows.rs', lines 485:0-485:40 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 490:0-490:40 -/ def use_id_type (T : Type) (x : IdType T) : Result T := Result.ok x /- [no_nested_borrows::create_id_type]: - Source: 'tests/src/no_nested_borrows.rs', lines 489:0-489:43 -/ + Source: 'tests/src/no_nested_borrows.rs', lines 494:0-494:43 -/ def create_id_type (T : Type) (x : T) : Result (IdType T) := Result.ok x diff --git a/tests/src/no_nested_borrows.rs b/tests/src/no_nested_borrows.rs index 9a7604e6..88c0bc09 100644 --- a/tests/src/no_nested_borrows.rs +++ b/tests/src/no_nested_borrows.rs @@ -213,6 +213,11 @@ pub fn test_char() -> char { 'a' } +/// This triggered a bug at some point +pub fn panic_mut_borrow(_: &mut u32) { + panic!() +} + /// Mutually recursive types pub enum Tree { Leaf(T), @@ -225,7 +230,7 @@ pub enum NodeElem { } /* -// TODO: those definitions requires semantic termination (breaks the Coq backend +// TODO: those definitions require semantic termination (breaks the Coq backend // because we don't use fuel in this case). /// Mutually recursive functions -- cgit v1.2.3 From 0766885b6b72e6b9a91ffa944111776b7fe24557 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jun 2024 09:21:54 +0200 Subject: Cleanup merge_abstractions --- compiler/InterpreterBorrows.ml | 279 +++++++++++++++++++++++++++-------------- 1 file changed, 183 insertions(+), 96 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index b46a5da8..ae2ce2d0 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2218,29 +2218,32 @@ type merge_duplicates_funcs = { *) } -(** Auxiliary function. +(** Auxiliary function for {!merge_abstractions}. - Merge two abstractions into one, without updating the context. - *) -let merge_into_first_abstraction_aux (span : Meta.span) (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_first_abstraction_aux:\n- abs0:\n" - ^ abs_to_string span ctx abs0 - ^ "\n\n- abs1:\n" - ^ abs_to_string span ctx abs1)); + Phase 1 of the merge: we simplify all loan/borrow pairs, if a loan is + in the left abstraction and its corresponding borrow is in the right + abstraction. - (* Check that the abstractions are destructured *) - if !Config.sanity_checks then ( - let destructure_shared_values = true in - sanity_check __FILE__ __LINE__ - (abs_is_destructured span destructure_shared_values ctx abs0) - span; - sanity_check __FILE__ __LINE__ - (abs_is_destructured span destructure_shared_values ctx abs1) - span); + Important: this is asymmetric (the loan must be in the left abstraction). + + Example: + {[ + abs0 { ML l0, MB l1 } |><| abs1 { MB l0 } + ~~> abs1 { MB l1 } + ]} + + But: + {[ + abs1 { MB l0 } |><| abs0 { ML l0, MB l1 } + ~~> abs1 { MB l0, ML l0, MB l1 } + ]} + + We return the list of merged values. + *) +let merge_abstractions_merge_loan_borrow_pairs (span : Meta.span) + (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) (abs0 : abs) + (abs1 : abs) : typed_avalue list = + log#ldebug (lazy "merge_abstractions_merge_loan_borrow_pairs"); (* Compute the relevant information *) let { @@ -2290,15 +2293,17 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) - if a borrow/loan is present in both abstractions, we need to merge its content. - Note that it is possible that we may need to merge strictly more than two avalues, - because of shared loans. For instance, if we have: + Note that we may need to merge strictly more than two avalues, because of + shared loans. For instance, if we have: {[ abs'0 { shared_loan { l0, l1 } ... } abs'1 { shared_loan { l0 } ..., shared_loan { l1 } ... } ]} We ignore this case for now: we check that whenever we merge two shared loans, - then their sets of ids are equal. + then their sets of ids are equal, and fail if it is not the case. + Remark: a way of solving this problem would be to destructure shared loans + so that they always have exactly one id. *) let merged_borrows = ref MarkerBorrowId.Set.empty in let merged_loans = ref MarkerBorrowId.Set.empty in @@ -2306,7 +2311,7 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) let push_avalue av = log#ldebug (lazy - ("merge_into_first_abstraction_aux: push_avalue: " + ("merge_abstractions_merge_loan_borrow_pairs: push_avalue: " ^ typed_avalue_to_string ~span:(Some span) ctx av)); avalues := av :: !avalues in @@ -2314,10 +2319,9 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) match av with None -> () | Some av -> push_avalue av in - (* Phase 1 of the merge: we simplify all loan/borrow pairs. *) - - (* There is an asymetry in the merge: we only simplify a loan/borrow pair - if the loan is in the abstraction on the left *) + (* Compute the intersection of: + - the loans coming from the left abstraction + - the borrows coming from the right abstraction *) let intersect = MarkerBorrowId.Set.inter loans0 borrows1 in (* This function is called when handling shared loans: we have to apply a projection @@ -2345,18 +2349,15 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) merged_loans := MarkerBorrowId.Set.add id !merged_loans in let set_loans_as_merged pm ids = - let ids = - BorrowId.Set.to_seq ids - |> Seq.map (fun x -> (pm, x)) - |> MarkerBorrowId.Set.of_seq - in - MarkerBorrowId.Set.iter set_loan_as_merged ids + BorrowId.Set.elements ids + |> List.map (fun x -> (pm, x)) + |> List.iter set_loan_as_merged in - (* Note that we first explore the borrows/loans of [abs1], because we + (* Note that we first explore the borrows/loans of [abs0], because we want to merge *into* this abstraction, and as a consequence we want to preserve its structure as much as we can *) - let borrows_loans = List.append borrows_loans1 borrows_loans0 in + let borrows_loans = List.append borrows_loans0 borrows_loans1 in (* Iterate over all the borrows/loans ids found in the abstractions *) List.iter (fun bl -> @@ -2365,7 +2366,7 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) let bid = (pm, bid) in log#ldebug (lazy - ("merge_into_first_abstraction_aux: merging borrow " + ("merge_abstractions: merging borrow " ^ MarkerBorrowId.to_string bid)); (* Check if the borrow has already been merged - this can happen @@ -2395,9 +2396,10 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) craise __FILE__ __LINE__ span "Unreachable" | Abstract (ty, bc) -> { value = ABorrow bc; ty }) | Some _, Some _ -> - (* With markers, the case where the same borrow is duplicated should now be unreachable. - Note, this is due to all shared borrows currently taking different ids, this will - not be the case anymore when shared loans will take a unique id instead of a set *) + (* Because of markers, the case where the same borrow is duplicated should + be unreachable. Note, this is due to all shared borrows currently + taking different ids, this will not be the case anymore when shared loans + will take a unique id instead of a set *) craise __FILE__ __LINE__ span "Unreachable" | None, None -> craise __FILE__ __LINE__ span "Unreachable" in @@ -2415,7 +2417,7 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) else ( log#ldebug (lazy - ("merge_into_first_abstraction_aux: merging loan " + ("merge_abstractions: merging loan " ^ MarkerBorrowId.to_string bid)); (* Check if we need to filter it *) @@ -2467,19 +2469,41 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (* Reverse the avalues (we visited the loans/borrows in order, but pushed new values at the beggining of the stack of avalues) *) - let abs_values = List.rev !avalues in + List.rev !avalues + +(** Auxiliary function for {!merge_abstractions}. + + Phase 2 of the merge: we remove markers, by merging pairs of the same + element with different markers into one element without markers. - (* Phase 2: We now remove markers, by replacing pairs of the same element with left/right markers into one element - with only one marker. To do so, we linearly traverse the abstraction created through the first phase *) + Example: + {[ + |MB l0|, MB l1, ︙MB l0︙ + ~~> + MB l0, MB l1 + ]} + *) +let merge_abstractions_merge_markers (span : Meta.span) + (merge_funs : merge_duplicates_funcs option) (ctx : eval_ctx) + (abs_values : typed_avalue list) : typed_avalue list = log#ldebug (lazy - ("merge_into_first_abstraction_aux: starting phase 2\n- abs:\n" - ^ abs_to_string span ctx { abs0 with avalues = abs_values })); + ("merge_abstractions_merge_markers:\n- avalues:\n" + ^ String.concat ", " (List.map (typed_avalue_to_string ctx) abs_values))); - (* We first reset the list of avalues, and will construct avalues similarly to the previous phase *) - avalues := []; + (* We linearly traverse the list of avalues created through the first phase. *) - (* We recompute the relevant information on the abstraction after phase 1 *) + (* Utilities to accumulate the list of values resulting from the merge *) + let avalues = ref [] in + let push_avalue av = + log#ldebug + (lazy + ("merge_abstractions_merge_markers: push_avalue: " + ^ typed_avalue_to_string ~span:(Some span) ctx av)); + avalues := av :: !avalues + in + + (* Compute some relevant information *) let { loans = _; borrows = _; @@ -2491,8 +2515,10 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) in (* We will merge elements with the same borrow/loan id, but with different markers. - Hence, we only keep track of the id here: if Borrow PLeft bid has been merged - and we see Borrow PRight bid, we should ignore Borrow PRight bid *) + Hence, we only keep track of the id here: if [Borrow PLeft bid] has been merged + and we see [Borrow PRight bid], we should ignore [Borrow PRight bid] (because + when seeing [Borrow PLeft bid] we stored [Borrow PNone bid] into the list + of values to insert in the resulting abstraction). *) let merged_borrows = ref BorrowId.Set.empty in let merged_loans = ref BorrowId.Set.empty in @@ -2519,7 +2545,8 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) See the comment in the loop below for a detailed explanation *) let avalue_from_lc = function | Concrete (_, _) -> - (* This can happen only in case of nested borrows, and should have been filtered during phase 1 *) + (* This can happen only in case of nested borrows, and should have been filtered + during phase 1 *) craise __FILE__ __LINE__ span "Unreachable" | Abstract (ty, bc) -> (match bc with @@ -2529,6 +2556,10 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) { value = ALoan bc; ty } in + let complementary_markers pm0 pm1 = + (pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft) + in + (* Some utility functions *) (* Merge two aborrow contents - note that those contents must have the same id *) let merge_aborrow_contents (ty0 : rty) (bc0 : aborrow_content) (ty1 : rty) @@ -2537,17 +2568,13 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | AMutBorrow (pm0, id0, child0), AMutBorrow (pm1, id1, child1) -> (* Sanity-check of the precondition *) sanity_check __FILE__ __LINE__ (id0 = id1) span; - sanity_check __FILE__ __LINE__ - ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) - span; + sanity_check __FILE__ __LINE__ (complementary_markers pm0 pm1) span; (Option.get merge_funs).merge_amut_borrows id0 ty0 pm0 child0 ty1 pm1 child1 | ASharedBorrow (pm0, id0), ASharedBorrow (pm1, id1) -> (* Sanity-check of the precondition *) sanity_check __FILE__ __LINE__ (id0 = id1) span; - sanity_check __FILE__ __LINE__ - ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) - span; + sanity_check __FILE__ __LINE__ (complementary_markers pm0 pm1) span; (Option.get merge_funs).merge_ashared_borrows id0 ty0 pm0 ty1 pm1 | AProjSharedBorrow _, AProjSharedBorrow _ -> (* Unreachable because requires nested borrows *) @@ -2562,7 +2589,8 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (bc1 : g_borrow_content_with_ty) : typed_avalue = match (bc0, bc1) with | Concrete _, Concrete _ -> - (* This can happen only in case of nested borrows *) + (* This can happen only in case of nested borrows - the borrow has + to appear inside a shared loan. *) craise __FILE__ __LINE__ span "Unreachable" | Abstract (ty0, bc0), Abstract (ty1, bc1) -> merge_aborrow_contents ty0 bc0 ty1 bc1 @@ -2571,32 +2599,39 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) craise __FILE__ __LINE__ span "Unreachable" in + let loan_content_to_ids (lc : g_loan_content_with_ty) : BorrowId.Set.t = + match lc with + | Abstract (_, lc) -> ( + match lc with + | AMutLoan (_, id, _) -> BorrowId.Set.singleton id + | ASharedLoan (_, ids, _, _) -> ids + | _ -> + (* Unreachable because those cases are ignored (ended/ignored borrows) + or inconsistent *) + craise __FILE__ __LINE__ span "Unreachable") + | Concrete _ -> + (* Can only happen with nested borrows *) + craise __FILE__ __LINE__ span "Unreachable" + in + let merge_aloan_contents (ty0 : rty) (lc0 : aloan_content) (ty1 : rty) (lc1 : aloan_content) : typed_avalue = match (lc0, lc1) with | AMutLoan (pm0, id0, child0), AMutLoan (pm1, id1, child1) -> (* Sanity-check of the precondition *) sanity_check __FILE__ __LINE__ (id0 = id1) span; - sanity_check __FILE__ __LINE__ - ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) - span; - (* Register the loan id *) - set_loan_as_merged id0; + sanity_check __FILE__ __LINE__ (complementary_markers pm0 pm1) span; (* Merge *) (Option.get merge_funs).merge_amut_loans id0 ty0 pm0 child0 ty1 pm1 child1 | ASharedLoan (pm0, ids0, sv0, child0), ASharedLoan (pm1, ids1, sv1, child1) -> - sanity_check __FILE__ __LINE__ - ((pm0 = PLeft && pm1 = PRight) || (pm0 = PRight && pm1 = PLeft)) - span; + sanity_check __FILE__ __LINE__ (complementary_markers pm0 pm1) span; (* 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 *) sanity_check __FILE__ __LINE__ (BorrowId.Set.equal ids0 ids1) span; let ids = ids0 in - (* Register the loan ids *) - set_loans_as_merged ids; (* Merge *) (Option.get merge_funs).merge_ashared_loans ids ty0 pm0 sv0 child0 ty1 pm1 sv1 child1 @@ -2628,26 +2663,34 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) | PRight -> PLeft in - (* We now iter over all elements in the current abstraction. For each element with a marker - (i.e., not PNone), we attempt to find the dual element in the rest of the list. If so, + (* We now iter over all the accumulated elements. For each element with a marker + (i.e., not [PNone]), we attempt to find the dual element in the rest of the list. If so, we remove both elements, and insert the same element but with no marker. Importantly, attempting the merge when first seeing a marked element allows us to preserve - the structure of the abstraction we are merging into (abs1). During phase1, we traversed - the borrow_loans of the abs1 first, and hence these elements are at the top of the list *) + the structure of the abstraction we are merging into (abs0). During phase 1, we traversed + the borrow_loans of the abs 0 first, and hence these elements are at the top of the list *) List.iter (function | BorrowId (PNone, bid) -> - (* This element has no marker. We do not filter it, hence we retrieve the contents and inject it into - the avalues list *) + sanity_check __FILE__ __LINE__ (not (borrow_is_merged bid)) span; + (* This element has no marker. We do not filter it, hence we retrieve the + contents and inject it into the avalues list *) let bc = MarkerBorrowId.Map.find (PNone, bid) borrow_to_content in - push_avalue (avalue_from_bc bc) + push_avalue (avalue_from_bc bc); + (* Setting the borrow as merged is not really necessary but we do it + for consistency, and this allows us to do some sanity checks. *) + set_borrow_as_merged bid | BorrowId (pm, bid) -> - (* Check if the borrow has already been merged. If so, it was already added to the avalues list, we skip it *) + (* Check if the borrow has already been merged. If so, it means we already + added the merged value to the avalues list, and we can thus skip it *) if borrow_is_merged bid then () else ( + (* Not merged: set it as merged *) set_borrow_as_merged bid; + (* Lookup the content of the borrow *) let bc0 = MarkerBorrowId.Map.find (pm, bid) borrow_to_content in + (* Check if there exists the same borrow but with the complementary marker *) let obc1 = MarkerBorrowId.Map.find_opt (invert_proj_marker pm, bid) @@ -2655,11 +2698,13 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) in match obc1 with | None -> - (* No dual element found, we keep the current one in the list of avalues, with the same marker *) + (* No dual element found, we keep the current one in the list of avalues, + with the same marker *) push_avalue (avalue_from_bc bc0) | Some bc1 -> (* We have borrows with left and right markers in the environment. - We merge their values, and push the result to the list of avalues. The merge will also remove the projection marker *) + We merge their values, and push the result to the list of avalues. + The merge will also remove the projection marker *) push_avalue (merge_g_borrow_contents bc0 bc1)) | LoanId (PNone, bid) -> (* Since we currently have a set of loan ids associated to a shared_borrow, we can @@ -2668,19 +2713,23 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) To do so, we use the loan id merged set for both marked and unmarked values. The assumption is that we should not have the same loan id for both an unmarked - element and a marked element. It might better to sanity-check this. + element and a marked element. It might be better to sanity-check this. Adding the loan id to the merged set will be done inside avalue_from_lc. - Rem: Once we move to a single loan id per shared_loan, this should not be needed anymore + Rem: Once we move to a single loan id per shared_loan, this should not be needed + anymore. *) if loan_is_merged bid then () else let lc = MarkerBorrowId.Map.find (PNone, bid) loan_to_content in - push_avalue (avalue_from_lc lc) + push_avalue (avalue_from_lc lc); + (* Mark as merged *) + let ids = loan_content_to_ids lc in + set_loans_as_merged ids | LoanId (pm, bid) -> ( if - (* Check if the loan has already been merged. If so, we skip it *) + (* Check if the loan has already been merged. If so, we skip it. *) loan_is_merged bid then () else @@ -2690,11 +2739,18 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) (invert_proj_marker pm, bid) loan_to_content in + (* Mark as merged *) + let ids0 = loan_content_to_ids lc0 in + set_loans_as_merged ids0; match olc1 with | None -> (* No dual element found, we keep the current one with the same marker *) push_avalue (avalue_from_lc lc0) - | Some lc1 -> push_avalue (merge_g_loan_contents lc0 lc1))) + | Some lc1 -> + push_avalue (merge_g_loan_contents lc0 lc1); + (* Mark as merged *) + let ids1 = loan_content_to_ids lc1 in + set_loans_as_merged ids1)) borrows_loans; let avalues = List.rev !avalues in @@ -2703,18 +2759,50 @@ let merge_into_first_abstraction_aux (span : Meta.span) (abs_kind : abs_kind) the loans (this structure is more stable when we merge abstractions together, meaning it is easier to find fixed points). *) + let is_borrow (av : typed_avalue) : bool = + match av.value with + | ABorrow _ -> true + | ALoan _ -> false + | _ -> craise __FILE__ __LINE__ span "Unexpected" + in + let aborrows, aloans = List.partition is_borrow avalues in + List.append aborrows aloans + +(** Auxiliary function. + + Merge two abstractions into one, without updating the context. + *) +let merge_abstractions (span : Meta.span) (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_abstractions:\n- abs0:\n" + ^ abs_to_string span ctx abs0 + ^ "\n\n- abs1:\n" + ^ abs_to_string span ctx abs1)); + + (* Check that the abstractions are destructured (i.e., there are no nested + values, etc.) *) + if !Config.sanity_checks then ( + let destructure_shared_values = true in + sanity_check __FILE__ __LINE__ + (abs_is_destructured span destructure_shared_values ctx abs0) + span; + sanity_check __FILE__ __LINE__ + (abs_is_destructured span destructure_shared_values ctx abs1) + span); + + (* Phase 1: simplify the loans coming from the left abstraction with + the borrows coming from the right abstraction. *) let avalues = - let is_borrow (av : typed_avalue) : bool = - match av.value with - | ABorrow _ -> true - | ALoan _ -> false - | _ -> craise __FILE__ __LINE__ span "Unexpected" - in - let aborrows, aloans = List.partition is_borrow avalues in - List.append aborrows aloans + merge_abstractions_merge_loan_borrow_pairs span merge_funs ctx abs0 abs1 in - (* Filter the regions *) + (* Phase 2: we now remove markers, by merging pairs of the same element with + different markers into one element. To do so, we linearly traverse the list + of avalues created through the first phase. *) + let avalues = merge_abstractions_merge_markers span merge_funs ctx avalues in (* Create the new abstraction *) let abs_id = fresh_abstraction_id () in @@ -2764,8 +2852,7 @@ let merge_into_first_abstraction (span : Meta.span) (abs_kind : abs_kind) (* Merge them *) let nabs = - merge_into_first_abstraction_aux span abs_kind can_end merge_funs ctx abs0 - abs1 + merge_abstractions span abs_kind can_end merge_funs ctx abs0 abs1 in (* Update the environment: replace the abstraction 0 with the result of the merge, -- cgit v1.2.3 From 765a98e42c066595a0af44008159020eca257f89 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jun 2024 09:48:52 +0200 Subject: Improve merge_abstractions by splitting the markers before merging --- compiler/InterpreterBorrows.ml | 75 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index ae2ce2d0..22ae8663 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2218,6 +2218,60 @@ type merge_duplicates_funcs = { *) } +(** Small utility: if a value doesn't have any marker, split it into two values + with complementary markers. We use this for {!merge_abstractions}. + + We assume the value has been destructured (there are no nested loans, + adts, the children are ignored, etc.). + *) +let typed_avalue_split_marker (span : Meta.span) (ctx : eval_ctx) + (av : typed_avalue) : typed_avalue list = + let mk_split pm mk_value = + if pm = PNone then [ mk_value PLeft; mk_value PRight ] else [ av ] + in + match av.value with + | AAdt _ | ABottom | ASymbolic _ | AIgnored -> + craise __FILE__ __LINE__ span "Unexpected" + | ABorrow bc -> ( + match bc with + | AMutBorrow (pm, bid, child) -> + sanity_check __FILE__ __LINE__ (is_aignored child.value) span; + let mk_value pm = + { av with value = ABorrow (AMutBorrow (pm, bid, child)) } + in + mk_split pm mk_value + | ASharedBorrow (pm, bid) -> + let mk_value pm = + { av with value = ABorrow (ASharedBorrow (pm, bid)) } + in + mk_split pm mk_value + | _ -> craise __FILE__ __LINE__ span "Unsupported yet") + | ALoan lc -> ( + match lc with + | AMutLoan (pm, bid, child) -> + sanity_check __FILE__ __LINE__ (is_aignored child.value) span; + let mk_value pm = + { av with value = ALoan (AMutLoan (pm, bid, child)) } + in + mk_split pm mk_value + | ASharedLoan (pm, bids, sv, child) -> + sanity_check __FILE__ __LINE__ (is_aignored child.value) span; + sanity_check __FILE__ __LINE__ + (not (value_has_borrows ctx sv.value)) + span; + let mk_value pm = + { av with value = ALoan (ASharedLoan (pm, bids, sv, child)) } + in + mk_split pm mk_value + | _ -> craise __FILE__ __LINE__ span "Unsupported yet") + +let abs_split_markers (span : Meta.span) (ctx : eval_ctx) (abs : abs) : abs = + { + abs with + avalues = + List.concat (List.map (typed_avalue_split_marker span ctx) abs.avalues); + } + (** Auxiliary function for {!merge_abstractions}. Phase 1 of the merge: we simplify all loan/borrow pairs, if a loan is @@ -2245,6 +2299,27 @@ let merge_abstractions_merge_loan_borrow_pairs (span : Meta.span) (abs1 : abs) : typed_avalue list = log#ldebug (lazy "merge_abstractions_merge_loan_borrow_pairs"); + (* Split the markers inside the abstractions (if we allow using markers). + + We do so because it enables simplification later when we are in the following case: + {[ + abs0 { ML l0 } |><| abs1 { |MB l0|, MB l1 } + ]} + + If we split before merging we get: + {[ + abs0 { |ML l0|, ︙ML l0︙ } |><| abs1 { |MB l0|, |MB l1|, ︙MB l1︙ } + ~~> merge + abs2 { ︙ML l0︙, |MB l1|, ︙MB l1︙ } + ~~> simplify the complementary markers + abs2 { ︙ML l0︙, MB l1 } + ]} + *) + let abs0, abs1 = + if merge_funs = None then (abs0, abs1) + else (abs_split_markers span ctx abs0, abs_split_markers span ctx abs1) + in + (* Compute the relevant information *) let { loans = loans0; -- cgit v1.2.3 From 3cb17966aa0c5d0e84b734c2afb4dce0f4bf22d2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jun 2024 10:52:00 +0200 Subject: Start factoring out the code of reduce_ctx and collapse_ctx --- compiler/InterpreterLoopsJoinCtxs.ml | 253 ++++++++++++++++++++++------------- 1 file changed, 162 insertions(+), 91 deletions(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 8ad5272a..e1a91707 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -13,6 +13,128 @@ open Errors (** The local logger *) let log = Logging.loops_join_ctxs_log +(** Utility. + + An environment augmented with information about its borrows/loans/abstractions + for the purpose of merging abstractions together. + We provide functions to update this information when merging two abstractions + together. We use it in {!reduce_ctx} and {!collapse_ctx}. +*) +type ctx_with_info = { ctx : eval_ctx; info : abs_borrows_loans_maps } + +let ctx_with_info_merge_into_first_abs (span : Meta.span) (abs_kind : abs_kind) + (can_end : bool) (merge_funs : merge_duplicates_funcs option) + (ctx : ctx_with_info) (abs_id0 : AbstractionId.id) + (abs_id1 : AbstractionId.id) : ctx_with_info = + (* Compute the new context and the new abstraction id *) + let nctx, nabs_id = + merge_into_first_abstraction span abs_kind can_end merge_funs ctx.ctx + abs_id0 abs_id1 + in + let nabs = ctx_lookup_abs nctx nabs_id in + (* Update the information *) + let { + abs_to_borrows = nabs_to_borrows; + abs_to_loans = nabs_to_loans; + borrow_to_abs = borrow_to_nabs; + loan_to_abs = loan_to_nabs; + _; + } = + compute_abs_borrows_loans_maps span (fun _ -> true) [ EAbs nabs ] + in + let { abs_ids; abs_to_borrows; abs_to_loans; borrow_to_abs; loan_to_abs } = + ctx.info + in + let abs_ids = + List.filter_map + (fun id -> + if id = abs_id0 then Some nabs_id + else if id = abs_id1 then None + else Some id) + abs_ids + in + (* Update the maps from makred borrows/loans to abstractions *) + let update_to_abs abs_to to_nabs to_abs = + (* Remove the old bindings *) + let abs0_elems = AbstractionId.Map.find abs_id0 abs_to in + let abs1_elems = AbstractionId.Map.find abs_id1 abs_to in + let abs01_elems = MarkerBorrowId.Set.union abs0_elems abs1_elems in + let to_abs = + MarkerBorrowId.Map.filter + (fun id _ -> not (MarkerBorrowId.Set.mem id abs01_elems)) + to_abs + in + (* Add the new ones *) + let merge _ _ _ = + (* We shouldn't have twice the same key *) + craise __FILE__ __LINE__ span "Unreachable" + in + MarkerBorrowId.Map.union merge to_nabs to_abs + in + let borrow_to_abs = + update_to_abs abs_to_borrows borrow_to_nabs borrow_to_abs + in + let loan_to_abs = update_to_abs abs_to_loans loan_to_nabs loan_to_abs in + + (* Update the maps from abstractions to marked borrows/loans *) + let update_abs_to nabs_to abs_to = + AbstractionId.Map.add_strict nabs_id + (AbstractionId.Map.find nabs_id nabs_to) + (AbstractionId.Map.remove abs_id0 + (AbstractionId.Map.remove abs_id1 abs_to)) + in + let abs_to_borrows = update_abs_to nabs_to_borrows abs_to_borrows in + let abs_to_loans = update_abs_to nabs_to_loans abs_to_loans in + let info = + { abs_ids; abs_to_borrows; abs_to_loans; borrow_to_abs; loan_to_abs } + in + { ctx = nctx; info } + +exception AbsToMerge of abstraction_id * abstraction_id + +(** Repeatedly iterate through the borrows/loans in an environment and merge the + abstractions that have to be merged according to a user-provided policy. *) +let repeat_iter_borrows_merge (span : Meta.span) (old_ids : ids_sets) + (abs_kind : abs_kind) (can_end : bool) + (merge_funs : merge_duplicates_funcs option) + (iter : + ctx_with_info -> (abstraction_id -> marker_borrow_id -> unit) -> unit) + (policy : + ctx_with_info -> + abstraction_id -> + marker_borrow_id -> + (abstraction_id * abstraction_id) option) (ctx : eval_ctx) : eval_ctx = + (* Compute the information *) + let ctx = + let is_fresh_abs_id (id : AbstractionId.id) : bool = + not (AbstractionId.Set.mem id old_ids.aids) + in + let explore (abs : abs) = is_fresh_abs_id abs.abs_id in + let info = compute_abs_borrows_loans_maps span explore ctx.env in + { ctx; info } + in + (* Explore and merge *) + let rec explore_merge (ctx : ctx_with_info) : eval_ctx = + try + iter ctx (fun aid mbid -> + (* Check if we need to merge some abstractions *) + match policy ctx aid mbid with + | None -> (* No *) () + | Some (abs_id0, abs_id1) -> + (* Yes: raise an exception *) + raise (AbsToMerge (abs_id0, abs_id1))); + (* No exception raise: return the current context *) + ctx.ctx + with AbsToMerge (abs_id0, abs_id1) -> + (* Merge and recurse *) + let ctx = + ctx_with_info_merge_into_first_abs span abs_kind can_end merge_funs ctx + abs_id0 abs_id1 + in + explore_merge ctx + in + explore_merge ctx + (** Reduce an environment. We do this to simplify an environment, for the purpose of finding a loop @@ -141,112 +263,61 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) ^ eval_ctx_to_string ~span:(Some span) ctx ^ "\n\n")); - (* Explore all the *new* abstractions, and compute various maps *) - let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = compute_abs_borrows_loans_maps span explore env in - let { - abs_ids; - abs_to_borrows = _; - abs_to_loans; - borrow_to_abs; - loan_to_abs = _; - } = - ids_maps - in - - (* Merge the abstractions together *) - 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 - (* Merge all the mergeable abs. - We iterate over the abstractions, then over the loans in the abstractions. + We iterate over the *new* abstractions, then over the loans in the abstractions. We do this because we want to control the order in which abstractions are merged (the ids are iterated in increasing order). Otherwise, we could simply iterate over all the borrows in [loan_to_abs]... *) - List.iter - (fun abs_id0 -> - let lids = AbstractionId.Map.find abs_id0 abs_to_loans in - let lids = MarkerBorrowId.Set.elements lids in - List.iter - (fun lid -> - if not with_markers then - sanity_check __FILE__ __LINE__ (fst lid = PNone) span; - (* If we use markers: we are doing a collapse, which means we attempt - to eliminate markers (and this is the only goal of the operation). - We thus ignore the non-marked values (we merge non-marked values - when doing a "real" reduce, to simplify the environment in order - to converge to a fixed-point, for instance). *) - if with_markers && fst lid = PNone then () - else - (* Find the borrow corresponding to the loan we want to eliminate *) - match MarkerBorrowId.Map.find_opt lid borrow_to_abs with - | None -> (* Nothing to do *) () - | Some abs_ids1 -> - AbstractionId.Set.iter - (fun abs_id1 -> - (* We need to merge - unless we have already merged *) - (* First, find the representatives for the two abstractions. - - We may have merged some abstractions already, so maybe abs_id0 - and abs_id1 don't exist anymore, because they may have been - merged into other abstractions: we look for the abstractions - resulting from such merged. *) - let abs_ref0 = - UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) - in - let abs_id0 = UnionFind.get abs_ref0 in - let abs_ref1 = - UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) - 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 ( - (* We actually need to merge the abstractions *) - - (* Debug *) - log#ldebug - (lazy - ("reduce_ctx: merging abstraction " - ^ AbstractionId.to_string abs_id1 - ^ " into " - ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx)); - - (* Update the environment - pay attention to the order: - we merge [abs_id1] *into* [abs_id0]. - In particular, as [abs_id0] contains the loan, it has - to be on the left. *) - let nctx, abs_id = - merge_into_first_abstraction span abs_kind can_end - merge_funs !ctx abs_id0 abs_id1 - in - ctx := nctx; - - (* Update the union find *) - let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in - UnionFind.set abs_ref_merged abs_id)) - abs_ids1) - lids) - abs_ids; + let ctx = + repeat_iter_borrows_merge span old_ids abs_kind can_end merge_funs + (fun ctx f -> + List.iter + (fun abs_id0 -> + let lids = AbstractionId.Map.find abs_id0 ctx.info.abs_to_loans in + MarkerBorrowId.Set.iter (f abs_id0) lids) + ctx.info.abs_ids) + (fun ctx abs_id0 lid -> + if not with_markers then + sanity_check __FILE__ __LINE__ (fst lid = PNone) span; + (* If we use markers: we are doing a collapse, which means we attempt + to eliminate markers (and this is the only goal of the operation). + We thus ignore the non-marked values (we merge non-marked values + when doing a "real" reduce, to simplify the environment in order + to converge to a fixed-point, for instance). *) + if with_markers && fst lid = PNone then None + else + (* Find the borrow corresponding to the loan we want to eliminate *) + match MarkerBorrowId.Map.find_opt lid ctx.info.borrow_to_abs with + | None -> (* Nothing to to *) None + | Some abs_ids1 -> ( + (* We need to merge *) + match AbstractionId.Set.elements abs_ids1 with + | [] -> None + | abs_id1 :: _ -> + log#ldebug + (lazy + ("reduce_ctx: merging abstraction " + ^ AbstractionId.to_string abs_id1 + ^ " into " + ^ AbstractionId.to_string abs_id0 + ^ ":\n\n" + ^ eval_ctx_to_string ~span:(Some span) ctx.ctx)); + Some (abs_id0, abs_id1))) + ctx + in log#ldebug (lazy ("reduce_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- after reduce:\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx + ^ eval_ctx_to_string ~span:(Some span) ctx ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions - note that we may not have eliminated all the markers at this point. *) - let ctx = reorder_loans_borrows_in_fresh_abs span true old_ids.aids !ctx in + let ctx = reorder_loans_borrows_in_fresh_abs span true old_ids.aids ctx in log#ldebug (lazy -- cgit v1.2.3 From 90a1c44c1be56e81c17373723d5098e2cfa48a37 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jun 2024 13:14:39 +0200 Subject: Factor out the code in collapse_ctx --- compiler/InterpreterBorrows.ml | 2 + compiler/InterpreterLoopsJoinCtxs.ml | 207 +++++++++-------------------------- 2 files changed, 56 insertions(+), 153 deletions(-) diff --git a/compiler/InterpreterBorrows.ml b/compiler/InterpreterBorrows.ml index 22ae8663..dee4903c 100644 --- a/compiler/InterpreterBorrows.ml +++ b/compiler/InterpreterBorrows.ml @@ -2856,6 +2856,8 @@ let merge_abstractions (span : Meta.span) (abs_kind : abs_kind) (can_end : bool) ^ abs_to_string span ctx abs0 ^ "\n\n- abs1:\n" ^ abs_to_string span ctx abs1)); + (* Sanity check: we can't merge an abstraction with itself *) + sanity_check __FILE__ __LINE__ (abs0.abs_id <> abs1.abs_id) span; (* Check that the abstractions are destructured (i.e., there are no nested values, etc.) *) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index e1a91707..7405f651 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -97,13 +97,9 @@ exception AbsToMerge of abstraction_id * abstraction_id let repeat_iter_borrows_merge (span : Meta.span) (old_ids : ids_sets) (abs_kind : abs_kind) (can_end : bool) (merge_funs : merge_duplicates_funcs option) - (iter : - ctx_with_info -> (abstraction_id -> marker_borrow_id -> unit) -> unit) - (policy : - ctx_with_info -> - abstraction_id -> - marker_borrow_id -> - (abstraction_id * abstraction_id) option) (ctx : eval_ctx) : eval_ctx = + (iter : ctx_with_info -> ('a -> unit) -> unit) + (policy : ctx_with_info -> 'a -> (abstraction_id * abstraction_id) option) + (ctx : eval_ctx) : eval_ctx = (* Compute the information *) let ctx = let is_fresh_abs_id (id : AbstractionId.id) : bool = @@ -116,9 +112,9 @@ let repeat_iter_borrows_merge (span : Meta.span) (old_ids : ids_sets) (* Explore and merge *) let rec explore_merge (ctx : ctx_with_info) : eval_ctx = try - iter ctx (fun aid mbid -> + iter ctx (fun x -> (* Check if we need to merge some abstractions *) - match policy ctx aid mbid with + match policy ctx x with | None -> (* No *) () | Some (abs_id0, abs_id1) -> (* Yes: raise an exception *) @@ -222,9 +218,6 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) 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 : AbstractionId.id) : bool = - not (AbstractionId.Set.mem id old_ids.aids) - in let is_fresh_did (id : DummyVarId.id) : bool = not (DummyVarId.Set.mem id old_ids.dids) in @@ -276,9 +269,9 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) List.iter (fun abs_id0 -> let lids = AbstractionId.Map.find abs_id0 ctx.info.abs_to_loans in - MarkerBorrowId.Set.iter (f abs_id0) lids) + MarkerBorrowId.Set.iter (fun lid -> f (abs_id0, lid)) lids) ctx.info.abs_ids) - (fun ctx abs_id0 lid -> + (fun ctx (abs_id0, lid) -> if not with_markers then sanity_check __FILE__ __LINE__ (fst lid = PNone) span; (* If we use markers: we are doing a collapse, which means we attempt @@ -351,36 +344,18 @@ let reduce_ctx = reduce_ctx_with_markers None ]} *) let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) - (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx0 : eval_ctx) + (merge_funs : merge_duplicates_funcs) (old_ids : ids_sets) (ctx : 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 ~span:(Some span) ctx0 + ^ "\n\n- initial ctx:\n" + ^ eval_ctx_to_string ~span:(Some span) ctx ^ "\n\n")); let abs_kind : abs_kind = Loop (loop_id, None, LoopSynthInput) in let can_end = true in - let is_fresh_abs_id (id : AbstractionId.id) : bool = - not (AbstractionId.Set.mem id old_ids.aids) - in - - (* Explore all the *new* abstractions, and compute various maps *) - let explore (abs : abs) = is_fresh_abs_id abs.abs_id in - let ids_maps = compute_abs_borrows_loans_maps span explore ctx0.env in - let { abs_ids; abs_to_borrows; abs_to_loans; borrow_to_abs; loan_to_abs } = - ids_maps - in - - (* Merge the abstractions together *) - 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 ctx0 in let invert_proj_marker = function | PNone -> craise __FILE__ __LINE__ span "Unreachable" @@ -390,134 +365,60 @@ let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) (* Merge all the mergeable abs where the same element in present in both abs, but with left and right markers respectively. - - We first check all borrows, then all loans *) - List.iter - (fun abs_id0 -> - let bids = AbstractionId.Map.find abs_id0 abs_to_borrows in - let bids = MarkerBorrowId.Set.elements bids in - List.iter - (fun (pm, bid) -> - if pm = PNone then () - else - (* We are looking for an element with the same borrow_id, but with the dual marker *) - match - MarkerBorrowId.Map.find_opt - (invert_proj_marker pm, bid) - borrow_to_abs - with - | None -> (* Nothing to do *) () - | Some abs_ids1 -> - 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 = - UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) - in - let abs_id0 = UnionFind.get abs_ref0 in - let abs_ref1 = - UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) - 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 ( - (* We actually need to merge the abstractions *) - - (* Debug *) - log#ldebug - (lazy - ("collapse_ctx: merging abstraction " - ^ AbstractionId.to_string abs_id1 - ^ " into " - ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx)); - - (* Update the environment - pay attention to the order: we - we merge [abs_id1] *into* [abs_id0] *) - let nctx, abs_id = - merge_into_first_abstraction span abs_kind can_end - (Some merge_funs) !ctx abs_id0 abs_id1 - in - ctx := nctx; - - (* Update the union find *) - let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in - UnionFind.set abs_ref_merged abs_id)) - abs_ids1) - bids; - (* We now traverse the loans *) - let bids = AbstractionId.Map.find abs_id0 abs_to_loans in - let bids = MarkerBorrowId.Set.elements bids in - List.iter - (fun (pm, bid) -> - if pm = PNone then () - else - (* We are looking for an element with the same borrow_id, but with the dual marker *) - match - MarkerBorrowId.Map.find_opt - (invert_proj_marker pm, bid) - loan_to_abs - with - | None -> (* Nothing to do *) () - | Some abs_ids1 -> - 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 = - UnionFind.find (AbstractionId.Map.find abs_id0 merged_abs) - in - let abs_id0 = UnionFind.get abs_ref0 in - let abs_ref1 = - UnionFind.find (AbstractionId.Map.find abs_id1 merged_abs) - 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 ( - (* We actually need to merge the abstractions *) - - (* Debug *) - log#ldebug - (lazy - ("collapse_ctx: merging abstraction " - ^ AbstractionId.to_string abs_id1 - ^ " into " - ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx)); - - (* Update the environment - pay attention to the order: we - we merge [abs_id1] *into* [abs_id0] *) - let nctx, abs_id = - merge_into_first_abstraction span abs_kind can_end - (Some merge_funs) !ctx abs_id0 abs_id1 - in - ctx := nctx; - - (* Update the union find *) - let abs_ref_merged = UnionFind.union abs_ref0 abs_ref1 in - UnionFind.set abs_ref_merged abs_id)) - abs_ids1) - bids) - abs_ids; + (* The iter function: iterate over the abstractions, and inside an abstraction + over the borrows then the loans *) + let iter ctx f = + List.iter + (fun abs_id0 -> + (* Small helper *) + let iterate is_borrow = + let m = + if is_borrow then ctx.info.abs_to_borrows else ctx.info.abs_to_loans + in + let ids = AbstractionId.Map.find abs_id0 m in + MarkerBorrowId.Set.iter (fun id -> f (abs_id0, is_borrow, id)) ids + in + (* Iterate over the borrows *) + iterate true; + (* Iterate over the loans *) + iterate false) + ctx.info.abs_ids + in + (* Check if there is an abstraction with the same borrow/loan id and the dual + marker, and merge them if it is the case. *) + let merge_policy ctx (abs_id0, is_borrow, (pm, bid)) = + if pm = PNone then None + else + (* Look for an element with the dual marker *) + match + MarkerBorrowId.Map.find_opt + (invert_proj_marker pm, bid) + (if is_borrow then ctx.info.borrow_to_abs else ctx.info.loan_to_abs) + with + | None -> (* Nothing to do *) None + | Some abs_ids1 -> ( + (* We need to merge *) + match AbstractionId.Set.elements abs_ids1 with + | [] -> None + | abs_id1 :: _ -> Some (abs_id0, abs_id1)) + in + (* Iterate and merge *) + let ctx = + repeat_iter_borrows_merge span old_ids abs_kind can_end (Some merge_funs) + iter merge_policy ctx + in log#ldebug (lazy ("collapse_ctx:\n\n- fixed_ids:\n" ^ show_ids_sets old_ids ^ "\n\n- after collapse:\n" - ^ eval_ctx_to_string ~span:(Some span) !ctx + ^ eval_ctx_to_string ~span:(Some span) ctx ^ "\n\n")); (* Reorder the loans and borrows in the fresh abstractions - note that we may not have eliminated all the markers yet *) - let ctx = reorder_loans_borrows_in_fresh_abs span true old_ids.aids !ctx in + let ctx = reorder_loans_borrows_in_fresh_abs span true old_ids.aids ctx in log#ldebug (lazy -- cgit v1.2.3 From aa847c5ea1cfc1695b95d91cd10e3dc5bace4c33 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jun 2024 13:17:26 +0200 Subject: Do more cleanup --- compiler/InterpreterLoopsJoinCtxs.ml | 84 +++++++++++++++++++----------------- 1 file changed, 44 insertions(+), 40 deletions(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 7405f651..20271f9c 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -256,49 +256,53 @@ let reduce_ctx_with_markers (merge_funs : merge_duplicates_funcs option) ^ eval_ctx_to_string ~span:(Some span) ctx ^ "\n\n")); - (* Merge all the mergeable abs. - - We iterate over the *new* abstractions, then over the loans in the abstractions. + (* + * Merge all the mergeable abs. + *) + (* We iterate over the *new* abstractions, then over the loans in the abstractions. We do this because we want to control the order in which abstractions are merged (the ids are iterated in increasing order). Otherwise, we - could simply iterate over all the borrows in [loan_to_abs]... - *) + could simply iterate over all the borrows in [loan_to_abs]... *) + let iterate ctx f = + List.iter + (fun abs_id0 -> + let lids = AbstractionId.Map.find abs_id0 ctx.info.abs_to_loans in + MarkerBorrowId.Set.iter (fun lid -> f (abs_id0, lid)) lids) + ctx.info.abs_ids + in + (* Given a loan, check if there is a fresh abstraction with the corresponding borrow *) + let merge_policy ctx (abs_id0, lid) = + if not with_markers then + sanity_check __FILE__ __LINE__ (fst lid = PNone) span; + (* If we use markers: we are doing a collapse, which means we attempt + to eliminate markers (and this is the only goal of the operation). + We thus ignore the non-marked values (we merge non-marked values + when doing a "real" reduce, to simplify the environment in order + to converge to a fixed-point, for instance). *) + if with_markers && fst lid = PNone then None + else + (* Find the borrow corresponding to the loan we want to eliminate *) + match MarkerBorrowId.Map.find_opt lid ctx.info.borrow_to_abs with + | None -> (* Nothing to to *) None + | Some abs_ids1 -> ( + (* We need to merge *) + match AbstractionId.Set.elements abs_ids1 with + | [] -> None + | abs_id1 :: _ -> + log#ldebug + (lazy + ("reduce_ctx: merging abstraction " + ^ AbstractionId.to_string abs_id1 + ^ " into " + ^ AbstractionId.to_string abs_id0 + ^ ":\n\n" + ^ eval_ctx_to_string ~span:(Some span) ctx.ctx)); + Some (abs_id0, abs_id1)) + in + (* Iterate and merge *) let ctx = - repeat_iter_borrows_merge span old_ids abs_kind can_end merge_funs - (fun ctx f -> - List.iter - (fun abs_id0 -> - let lids = AbstractionId.Map.find abs_id0 ctx.info.abs_to_loans in - MarkerBorrowId.Set.iter (fun lid -> f (abs_id0, lid)) lids) - ctx.info.abs_ids) - (fun ctx (abs_id0, lid) -> - if not with_markers then - sanity_check __FILE__ __LINE__ (fst lid = PNone) span; - (* If we use markers: we are doing a collapse, which means we attempt - to eliminate markers (and this is the only goal of the operation). - We thus ignore the non-marked values (we merge non-marked values - when doing a "real" reduce, to simplify the environment in order - to converge to a fixed-point, for instance). *) - if with_markers && fst lid = PNone then None - else - (* Find the borrow corresponding to the loan we want to eliminate *) - match MarkerBorrowId.Map.find_opt lid ctx.info.borrow_to_abs with - | None -> (* Nothing to to *) None - | Some abs_ids1 -> ( - (* We need to merge *) - match AbstractionId.Set.elements abs_ids1 with - | [] -> None - | abs_id1 :: _ -> - log#ldebug - (lazy - ("reduce_ctx: merging abstraction " - ^ AbstractionId.to_string abs_id1 - ^ " into " - ^ AbstractionId.to_string abs_id0 - ^ ":\n\n" - ^ eval_ctx_to_string ~span:(Some span) ctx.ctx)); - Some (abs_id0, abs_id1))) - ctx + repeat_iter_borrows_merge span old_ids abs_kind can_end merge_funs iterate + merge_policy ctx in log#ldebug -- cgit v1.2.3 From 2a7a18d6a07ea4967ba9ec0763e6b7d04849dc7e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jun 2024 13:33:32 +0200 Subject: Improve collapse_ctx --- compiler/InterpreterLoopsJoinCtxs.ml | 43 +++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/compiler/InterpreterLoopsJoinCtxs.ml b/compiler/InterpreterLoopsJoinCtxs.ml index 20271f9c..dbb4e5e9 100644 --- a/compiler/InterpreterLoopsJoinCtxs.ml +++ b/compiler/InterpreterLoopsJoinCtxs.ml @@ -389,6 +389,43 @@ let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) iterate false) ctx.info.abs_ids in + (* Small utility: check if we need to swap two region abstractions before + merging them. + + We might have to swap the order to make sure that if there + are loans in one abstraction and the corresponding borrows + in the other they get properly merged (if we merge them in the wrong + order, we might introduce borrowing cycles). + + Example: + If we are merging abs0 and abs1 because of the marked value + [MB l0]: + {[ + abs0 { |MB l0|, MB l1 } + abs1 { ︙MB l0︙, ML l1 } + ]} + we want to make sure that we swap them (abs1 goes to the + left) to make sure [MB l1] and [ML l1] get properly eliminated. + + Remark: in case there is a borrowing cycle between the two abstractions + (which shouldn't happen) then there isn't much we can do, and whatever + the order in which we merge, we will preserve the cycle. + *) + let swap_abs info abs_id0 abs_id1 = + let abs0_borrows = + BorrowId.Set.of_list + (List.map snd + (MarkerBorrowId.Set.elements + (AbstractionId.Map.find abs_id0 info.abs_to_borrows))) + in + let abs1_loans = + BorrowId.Set.of_list + (List.map snd + (MarkerBorrowId.Set.elements + (AbstractionId.Map.find abs_id1 info.abs_to_loans))) + in + not (BorrowId.Set.disjoint abs0_borrows abs1_loans) + in (* Check if there is an abstraction with the same borrow/loan id and the dual marker, and merge them if it is the case. *) let merge_policy ctx (abs_id0, is_borrow, (pm, bid)) = @@ -405,7 +442,11 @@ let collapse_ctx_collapse (span : Meta.span) (loop_id : LoopId.id) (* We need to merge *) match AbstractionId.Set.elements abs_ids1 with | [] -> None - | abs_id1 :: _ -> Some (abs_id0, abs_id1)) + | abs_id1 :: _ -> + (* Check if we need to swap *) + Some + (if swap_abs ctx.info abs_id0 abs_id1 then (abs_id1, abs_id0) + else (abs_id0, abs_id1))) in (* Iterate and merge *) let ctx = -- cgit v1.2.3