From f32cb06a8de6686520239485ee596c219892940e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Thu, 13 Feb 2025 23:00:27 -0800 Subject: [PATCH 01/32] Introduce Pulse.VC, a module to uniformly handle VCs --- src/checker/Pulse.VC.fst | 34 +++++++++++++++++++++++++++++ src/checker/Pulse.VC.fsti | 45 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 79 insertions(+) create mode 100644 src/checker/Pulse.VC.fst create mode 100644 src/checker/Pulse.VC.fsti diff --git a/src/checker/Pulse.VC.fst b/src/checker/Pulse.VC.fst new file mode 100644 index 000000000..54b7d0276 --- /dev/null +++ b/src/checker/Pulse.VC.fst @@ -0,0 +1,34 @@ +module Pulse.VC + +open Pulse.Syntax.Base +open Pulse.Typing +module T = FStar.Tactics.V2 + +let discharge (vc : vc_t) : T.Tac (either (list issue) (discharged vc)) = + match vc with + | Trivial -> Inr () + | EquivToken g t1 t2 -> + match T.check_equiv (elab_env g) t1 t2 with + | Some d, _ -> Inr d + | None, iss -> Inl iss + +let resolve #a #vc (w : with_vc vc a) : T.Tac (either (list issue) a) = + match discharge vc with + | Inl iss -> Inl iss + | Inr d -> Inr (w d) + +#set-options "--print_implicits --print_universes" + +let map_guarded + (#a : Type u#aa) + (#b : Type u#bb) + (x : guarded u#aa a) + (f : a -> T.Tac b) +: guarded b += + let Guarded vc foo = x in + Guarded vc (fun tok -> f (foo tok)) + +let unguard #a (x : guarded a) : T.Tac (either (list issue) a) = + let Guarded vc foo = x in + resolve foo diff --git a/src/checker/Pulse.VC.fsti b/src/checker/Pulse.VC.fsti new file mode 100644 index 000000000..4de199c51 --- /dev/null +++ b/src/checker/Pulse.VC.fsti @@ -0,0 +1,45 @@ +module Pulse.VC + +open FStar.Stubs.Reflection.Types +open Pulse.Typing +open FStar.Issue +module T = FStar.Tactics.Effect +module RT = FStar.Stubs.Tactics.Types.Reflection + +(* Recall: pulse terms are F* terms *) + +(* Types of possible verification conditions. *) +noeq +type vc_t = + | Trivial + | EquivToken : env -> term -> term -> vc_t + +(* Evidence for a VC being discharged, according to the kind. *) +let discharged (vc : vc_t) : Type = + match vc with + | Trivial -> unit + | EquivToken g t1 t2 -> RT.equiv_token (elab_env g) t1 t2 + +(* Discharge a VC, producing evidence for it. May fail. *) +val discharge (vc : vc_t) : T.Tac (either (list issue) (discharged vc)) + +type with_vc (vc : vc_t) (a:Type) = + discharged vc -> T.Tac a + +val resolve #a #vc (w : with_vc vc a) : T.Tac (either (list issue) a) + +(* Guarded values, there only if a VC succeeds. *) +noeq +type guarded (a:Type u#aa) : Type u#aa = + | Guarded : vc:_ -> with_vc vc a -> guarded a + +(* Working under a guard. *) +val map_guarded + (#a : Type u#aa) + (#b : Type u#bb) + (g : guarded a) + (f : a -> T.Tac b) + : T.Tac (guarded b) + +(* Unguarding = discharging the VC and applying the continuation. *) +val unguard #a (g : guarded a) : T.Tac (either (list issue) a) From f7199dddd6bff59f282a85aa504d6c611a0a28f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 14 Feb 2025 21:24:23 -0800 Subject: [PATCH 02/32] New guarded matching logic, matching keys, no backtracking on SMT ever --- lib/common/Pulse.Lib.Core.fsti | 46 +-- .../Pulse.Checker.Prover.ElimExists.fst | 4 +- .../Pulse.Checker.Prover.ElimExists.fsti | 4 +- src/checker/Pulse.Checker.Prover.Explode.fst | 3 +- src/checker/Pulse.Checker.Prover.Explode.fsti | 2 +- .../Pulse.Checker.Prover.Match.Base.fst | 2 + .../Pulse.Checker.Prover.Match.Base.fsti | 43 ++- .../Pulse.Checker.Prover.Match.Comb.fst | 355 ++++++++++++------ .../Pulse.Checker.Prover.Match.Comb.fsti | 4 +- .../Pulse.Checker.Prover.Match.MKeys.fst | 162 ++++++++ .../Pulse.Checker.Prover.Match.MKeys.fsti | 26 ++ .../Pulse.Checker.Prover.Match.Matchers.fst | 248 +++--------- .../Pulse.Checker.Prover.Match.Matchers.fsti | 6 +- src/checker/Pulse.Checker.Prover.Match.fsti | 9 +- src/checker/Pulse.Checker.Prover.fst | 210 ++++++----- 15 files changed, 652 insertions(+), 472 deletions(-) create mode 100644 src/checker/Pulse.Checker.Prover.Match.MKeys.fst create mode 100644 src/checker/Pulse.Checker.Prover.Match.MKeys.fsti diff --git a/lib/common/Pulse.Lib.Core.fsti b/lib/common/Pulse.Lib.Core.fsti index 37c270df7..180346051 100644 --- a/lib/common/Pulse.Lib.Core.fsti +++ b/lib/common/Pulse.Lib.Core.fsti @@ -23,29 +23,31 @@ module T = FStar.Tactics.V2 open Pulse.Lib.Dv {} open FStar.ExtractAs -(* This attribute can be used on the indexes of a slprop - to instruct the checker to call the SMT solver to relate - occurrences of that index. - - For example, if you have - - val pts_to (x:ref a) ([@@@equate_by_smt] v:a) : slprop - - Then `pts_to x (a + b)` and `pts_to x (b + a)` will be - matched by the prover by emitting an SMT query (a + b) == (b + a). Of course, - `pts_to x a` and `pts_to x a` will be matched purely by unification without - emitted a trivial SMT query (a == a). - - By default, if none of the indexes of a slprop are marked with "equate_by_smt", - the _last_ argument of a slprop is considered to be equated by SMT. This makes - it convenient to write slprops like the one below, without paying special - heed to this attribute. - - val pts_to (x:ref a) (v:a) : slprop +val equate_by_smt : unit (* remove *) +val equate_strict : unit (* remove *) +val equate_syntactic : unit (* remove *) + +(* Arguments of slprops can be marked as a matching key to + 1- Make sure we do no try to use the SMT to match resources with + different matching keys (in other words, we only use the unifier to + match the matching keys). + 2- Indicate that we only expect a single instance of the resource for + a given set of matching keys, so we allow the use of SMT for the rest + of the arguments. + + val pts_to ([@@@mkey] x : ref a) (v : a) : slprop + + Then `pts_to x (a + b)` and `pts_to x (b + a)` will be matched by the + prover by emitting an SMT query `pts_to x (a + b) == pts_to x (b + + a)`. (Note we ask for this possibly weaker fact instead of `(a + b) + == (b + a)`; this can be useful when the definition of the resource + is not injective.) + + Of course, `pts_to x a` and `pts_to x a` will be matched purely by + unification without even emitting a trivial SMT query (a == a). *) -val equate_by_smt : unit (* now meaningless. *) -val equate_strict : unit (* only use fastunif *) -val equate_syntactic : unit (* only use term_eq *) +val mkey : unit +val no_mkeys : unit (** This attribute allows to do ambiguous proving when calling a function. *) val allow_ambiguous : unit diff --git a/src/checker/Pulse.Checker.Prover.ElimExists.fst b/src/checker/Pulse.Checker.Prover.ElimExists.fst index 708d86b6d..a3b7ee971 100644 --- a/src/checker/Pulse.Checker.Prover.ElimExists.fst +++ b/src/checker/Pulse.Checker.Prover.ElimExists.fst @@ -72,8 +72,7 @@ let elim_exists (#g:env) (#ctxt:term) (| g', ctxt', star_typing_inversion_l ctxt'_emp_typing, k |) let elim_exists_pst (#preamble:_) (pst:prover_state preamble) - : T.Tac (pst':prover_state preamble { pst' `pst_extends` pst /\ - pst'.unsolved == pst.unsolved }) = + : T.Tac (list (list Pprint.document) & pst':prover_state preamble { pst' `pst_extends` pst} ) = (* Hacking progress checking: we eliminate all exists, so if there's any in the ctxt then we will make progress. *) @@ -108,6 +107,7 @@ let elim_exists_pst (#preamble:_) (pst:prover_state preamble) assume (list_as_slprop (slprop_as_list remaining_ctxt') == remaining_ctxt'); + [], { pst with progress = prog; pg = g'; diff --git a/src/checker/Pulse.Checker.Prover.ElimExists.fsti b/src/checker/Pulse.Checker.Prover.ElimExists.fsti index 3bb06d18d..b1d803260 100644 --- a/src/checker/Pulse.Checker.Prover.ElimExists.fsti +++ b/src/checker/Pulse.Checker.Prover.ElimExists.fsti @@ -31,5 +31,5 @@ val elim_exists (#g:env) (#ctxt:term) (ctxt_typing:tot_typing g ctxt tm_slprop) continuation_elaborator g ctxt g' ctxt') val elim_exists_pst (#preamble:_) (pst:prover_state preamble) - : T.Tac (pst':prover_state preamble { pst' `pst_extends` pst /\ - pst'.unsolved == pst.unsolved }) + : T.Tac (list (list Pprint.document) & pst':prover_state preamble { pst' `pst_extends` pst }) + ///\ pst'.unsolved == pst.unsolved }) diff --git a/src/checker/Pulse.Checker.Prover.Explode.fst b/src/checker/Pulse.Checker.Prover.Explode.fst index 534649488..1290634cf 100644 --- a/src/checker/Pulse.Checker.Prover.Explode.fst +++ b/src/checker/Pulse.Checker.Prover.Explode.fst @@ -83,10 +83,11 @@ let rec explode_aux let explode (#preamble:_) (pst:prover_state preamble) -: T.Tac (pst':prover_state preamble {pst' `pst_extends` pst}) +: T.Tac (list (list Pprint.document) & pst':prover_state preamble {pst' `pst_extends` pst}) = let remaining_ctxt, p1 = explode_aux pst false [] pst.remaining_ctxt in let unsolved', p2 = explode_aux pst false [] pst.unsolved in + [], { pst with unsolved = unsolved'; goals_inv = magic(); diff --git a/src/checker/Pulse.Checker.Prover.Explode.fsti b/src/checker/Pulse.Checker.Prover.Explode.fsti index afcec9377..a0b48a745 100644 --- a/src/checker/Pulse.Checker.Prover.Explode.fsti +++ b/src/checker/Pulse.Checker.Prover.Explode.fsti @@ -23,4 +23,4 @@ module T = FStar.Tactics its individual components. *) val explode (#preamble:_) (pst:prover_state preamble) -: T.Tac (pst':prover_state preamble {pst' `pst_extends` pst}) +: T.Tac (list (list Pprint.document) & pst':prover_state preamble {pst' `pst_extends` pst}) diff --git a/src/checker/Pulse.Checker.Prover.Match.Base.fst b/src/checker/Pulse.Checker.Prover.Match.Base.fst index 969d24fe3..29e0f0d94 100644 --- a/src/checker/Pulse.Checker.Prover.Match.Base.fst +++ b/src/checker/Pulse.Checker.Prover.Match.Base.fst @@ -152,6 +152,8 @@ let compose_mpr (g:env) (ss : PS.ss_t) (ctxt0 unsolved0 ctxt1 unsolved1 : list s (VE_Refl _ _) >>* VE_Sym _ _ _ (subst_append_equiv _ _ _ _) ); + + msgs = mpr1.msgs @ mpr2.msgs; } let apply_mpr_vequiv_proof diff --git a/src/checker/Pulse.Checker.Prover.Match.Base.fsti b/src/checker/Pulse.Checker.Prover.Match.Base.fsti index 268308c21..08ab06046 100644 --- a/src/checker/Pulse.Checker.Prover.Match.Base.fsti +++ b/src/checker/Pulse.Checker.Prover.Match.Base.fsti @@ -19,6 +19,7 @@ module Pulse.Checker.Prover.Match.Base open Pulse.Syntax open Pulse.Typing open Pulse.Checker.Prover.Base +open Pulse.VC module T = FStar.Tactics.V2 module PS = Pulse.Checker.Prover.Substs @@ -74,9 +75,13 @@ type match_pass_result (g:env) (ss:PS.ss_t) (ctxt0 unsolved0 : list slprop) = { unsolved_matched : list slprop; unsolved1 : list slprop; - unsolved_ok : slprop_list_equiv g (unsolved0) (unsolved_matched @ unsolved1); - + unsolved_ok : slprop_list_equiv g unsolved0 (unsolved_matched @ unsolved1); + match_ok : slprop_list_equiv g ctxt_matched (ss' $$ unsolved_matched); + + (* Some information for the user explaining why unsolved1 couldn't be + fully matched. E.g. ambiguity messages. *) + msgs : list (list Pprint.document); } (* A zero for the match pass result, no progress at all. @@ -93,6 +98,8 @@ let mpr_zero (#g #ss #ctxt0 #unsolved0 :_) : match_pass_result g ss ctxt0 unsolv unsolved_ok = slprop_list_equiv_refl _ _; match_ok = slprop_list_equiv_refl _ _; + + msgs = []; } (* FIXME: probably do not have to be in this interface, and can @@ -135,21 +142,31 @@ val apply_mpr (******************************************************************) (******************************************************************) -(* A matcher can raise this to signal a graceful failure. *) -exception NoMatch of string +(* The result of a matcher. *) -(* Ambig (q, p1, p2): q (in goals) can be matched by p1 or p2 (in ctx). *) -exception Ambig of (slprop & slprop & slprop) - -let match_success_t +noeq +type match_res_t (#preamble:_) (pst : prover_state preamble) (p q : slprop) : Type = - ss:PS.ss_t & slprop_equiv pst.pg p ss.(q) + | NoMatch : reason:string -> match_res_t pst p q + | Matched : + ss_ext : PS.ss_t -> + vc : vc_t -> + with_vc vc (slprop_equiv pst.pg p ss_ext.(q)) -> + match_res_t pst p q + (* Note: I would prefer to just write + Matched of guarded (ss:PS.ss_t & slprop_equiv pst.pg p ss.(q)) + but that seems to incur many more inference failures. *) + +(* A matcher can also raise this to signal a graceful failure, it's just +converted to NoMatch. *) +exception ENoMatch of string (* The type of a 1-to-1 matcher. The pst is "read-only". If there's -no match, it should raise NoMatch. Other exceptions are not caught. *) +no match, it returns NoMatch or raises ENoMatch. Other exceptions are +not caught. These matchers never try to discharge VCs, but instead return +guarded results (see match_res_t). *) type matcher_t = - (#preamble:_) -> - (pst : prover_state preamble) -> + (#preamble:_) -> (pst : prover_state preamble) -> (p : slprop) -> (q : slprop) -> - T.Tac (match_success_t pst p q) + T.Tac (match_res_t pst p q) diff --git a/src/checker/Pulse.Checker.Prover.Match.Comb.fst b/src/checker/Pulse.Checker.Prover.Match.Comb.fst index b15cd560e..727ea7bab 100644 --- a/src/checker/Pulse.Checker.Prover.Match.Comb.fst +++ b/src/checker/Pulse.Checker.Prover.Match.Comb.fst @@ -25,10 +25,17 @@ open Pulse.Syntax open Pulse.Typing open Pulse.PP open Pulse.Show +open Pulse.VC module RU = Pulse.RuntimeUtils module PS = Pulse.Checker.Prover.Substs + +(* Ambig (q, p1, p2): q (in goals) can be matched by p1 or p2 (in ctx). +This is internal to this module, which is in charge of calling the matchers +1 by 1 and detecting ambiguity. *) +exception Ambig of (slprop & slprop & slprop) + (* local aliases *) let (>>>) #g #t0 #t1 #t2 = VE_Trans g t0 t1 t2 let (>>*) #g #t0 #t1 #t2 = slprop_list_equiv_trans g t0 t1 t2 @@ -43,81 +50,188 @@ let wrap_matcher (matcher : matcher_t) (#preamble:_) (pst : prover_state preamble) (p q : slprop) + : T.Tac (match_res_t pst p q) = if RU.debug_at_level (fstar_env pst.pg) "prover.match" then - T.print ("Trying matcher " ^ label); - try - Some (matcher pst p q) - with - | NoMatch s -> - if RU.debug_at_level (fstar_env pst.pg) "prover.match" then - T.print ("NoMatch: " ^ s); - None - | e -> raise e + info_doc pst.pg (Some <| range_of_env pst.pg) [ + text "Trying to match"; + prefix 2 1 (doc_of_string "p =") (pp p); + prefix 2 1 (doc_of_string "q =") (pp pst.ss.(q)); + text <| "with matcher: " ^ label; + ]; + let res = try matcher pst p q with | ENoMatch s -> NoMatch s | e -> raise e in + if RU.debug_at_level (fstar_env pst.pg) "prover.match" then begin + info_doc pst.pg (Some <| range_of_env pst.pg) [ + text "Result:" ^/^ + (match res with + | NoMatch s -> text "No match: " ^/^ text s + | Matched _ _ _ -> text "Matched (with some guard)") + ] + end; + res + +(* The type of a match of q from something in a context ps. *) noeq +type match_from_context_t + (#preamble:_) (pst : prover_state preamble) + (q : slprop) + (ps : list slprop) += { + p : slprop; + rest : list slprop; + rest_ok : slprop_list_equiv pst.pg ps (p::rest); + ss' : PS.ss_t; + ss_extends : squash (ss' `ss_extends` pst.ss); + proof : guarded (slprop_equiv pst.pg p ss'.(q)); +} + +(* If we matched q from ps, we can match it from any extension of ps. *) +let frame_match_from_context + (#preamble:_) (pst : prover_state preamble) + (q : slprop) + (ps : list slprop) + (mm : match_from_context_t pst q ps) + (frame : list slprop) + : match_from_context_t pst q (frame @ ps) += { + p = mm.p; + rest = frame @ mm.rest; + rest_ok = slprop_list_equiv_append _ _ _ _ _ (VE_Refl _ _) mm.rest_ok >>> + VE_Sym _ _ _ (slprop_list_equiv_push_append _ _ _ _); + ss' = mm.ss'; + ss_extends = mm.ss_extends; + proof = mm.proof; +} + +(* Returns all successful matches of q in ps. *) +let rec get_all_matches_aux + (label : string) + (matcher : matcher_t) + (#preamble:_) (pst : prover_state preamble) + (q : slprop) + (ps0 ps : list slprop) + : T.Tac (list (match_from_context_t pst q (List.rev ps0 @ ps))) += + match ps with + | [] -> [] + | p::ps' -> + let thisone : list (match_from_context_t pst q (List.rev ps0 @ ps)) = + match wrap_matcher label matcher pst p pst.ss.(q) with + | NoMatch s -> [] + | Matched ss_ext vc ff -> + assume (Set.disjoint (PS.dom pst.ss) (PS.dom ss_ext)); + let ss' = PS.push_ss pst.ss ss_ext in + assume (ss'.(q) == ss_ext.(pst.ss.(q))); (* this should be true since it's just composing substs? *) -let rec match_f_1n + if RU.debug_at_level (fstar_env pst.pg) "prover.match" then + info_doc pst.pg (Some <| range_of_env pst.pg) [ + text ("Matched with " ^ label); + prefix 2 1 (doc_of_string "p =") (pp p); + prefix 2 1 (doc_of_string "q =") (pp pst.ss.(q)); + prefix 2 1 (doc_of_string "ss' =") (pp ss'); + prefix 2 1 (doc_of_string "ss'.(q) =") (pp ss'.(q)); + ]; + + let ff : with_vc vc (slprop_equiv pst.pg p ss_ext.(pst.ss.(q))) = ff in + let ff : with_vc vc (slprop_equiv pst.pg p ss'.(q)) = coerce_eq () ff in + (* ^ FIXME: why is the coerce needed? *) + + let mm : match_from_context_t pst q ps = { + p = p; + rest = ps'; + rest_ok = slprop_list_equiv_refl _ _; + ss' = ss'; + ss_extends = (); + proof = Guarded vc ff; + } + in + let mm = frame_match_from_context pst q ps mm (List.rev ps0) in + [mm] + in + let rest : list (match_from_context_t pst q (List.rev ps0 @ ps)) = + assume (List.rev (p::ps0) @ ps' == List.rev ps0 @ (p::ps')); // boring + get_all_matches_aux label matcher pst q (p::ps0) ps' + in + thisone @ rest + +let get_all_matches (label : string) (matcher : matcher_t) (#preamble:_) (pst : prover_state preamble) (q : slprop) - (ctxt0 : list slprop) - (* Returns new shrunk ctxt, proving the equivalence. *) - : T.Tac (option ( - p : slprop & - ctxt1 : list slprop & - ctxt1_ok : slprop_list_equiv pst.pg ctxt0 (p::ctxt1) & - ss' : (ss' : PS.ss_t {ss' `ss_extends` pst.ss}) & - pq_ok : slprop_equiv pst.pg p ss'.(q) - )) -= match ctxt0 with - | [] -> None - | p::ps -> + (ps : list slprop) + : T.Tac (list (match_from_context_t pst q ps)) += get_all_matches_aux label matcher pst q [] ps + +let rec coallesce_equal_matches + (#preamble:_) (#pst : prover_state preamble) + (#q : slprop) + (#ps : list slprop) + (ms : list (match_from_context_t pst q ps)) + : list (match_from_context_t pst q ps) += + match ms with + | [] -> [] + | m1::ms' -> + let ms' = coallesce_equal_matches ms' in + match ms' with + | [] -> [m1] + | m2::ms'' -> + if FStar.Reflection.TermEq.term_eq m1.p m2.p then + m1::ms'' + else + m1::m2::ms'' + +(* Returns the slprop that was matched, the remaining context, the + needed substitution and a **guarded** proof of the match. This basically + turns the list returned by get_all_matches into a single match, failing + if any ambiguity is detected. + + In the error case (Inl) it can add some messages for the user, for example + explaning why ambiguity was detected. +*) +let match_f_1n + (label : string) + (matcher : matcher_t) + (#preamble:_) (pst : prover_state preamble) + (q : slprop) + (ps : list slprop) + : T.Tac (either (list document) (match_from_context_t pst q ps)) += let ms = get_all_matches label matcher pst q ps in + let ms = coallesce_equal_matches ms in + match ms with + | [] -> Inl [] (* no matches *) + | [m] -> if RU.debug_at_level (fstar_env pst.pg) "prover.match" then info_doc pst.pg (Some <| range_of_env pst.pg) [ - text ("Trying to match"); - prefix 2 1 (doc_of_string "p =") (pp p); - prefix 2 1 (doc_of_string "q =") (pp pst.ss.(q)); + text ("Successful unambiguous match pass with " ^ label); + prefix 2 1 (doc_of_string "q =") (pp q); + prefix 2 1 (doc_of_string "m.p =") (pp m.p); + prefix 2 1 (doc_of_string "m.ss' =") (pp m.ss'); + prefix 2 1 (doc_of_string "m.ss'.(q) =") (pp m.ss'.(q)); ]; - match wrap_matcher label matcher pst p pst.ss.(q) with - | Some (| ss_extension, pq |) -> ( - (* ambiguity check *) - if not pst.allow_ambiguous then begin - if RU.debug_at_level (fstar_env pst.pg) "prover.match" then - T.print "Checking for ambiguity"; - match match_f_1n label matcher pst q ps with - | Some (| p', _, _, _, _ |) -> - if not (FStar.Reflection.TermEq.term_eq p p') then - raise (Ambig (q, p, p')) - | None -> () - end; - assume (Set.disjoint (PS.dom pst.ss) (PS.dom ss_extension)); - let ss' = PS.push_ss pst.ss ss_extension in + Inr m (* yay! *) + | m1::m2::_ -> + if pst.allow_ambiguous + then ( if RU.debug_at_level (fstar_env pst.pg) "prover.match" then info_doc pst.pg (Some <| range_of_env pst.pg) [ - text ("Matched with " ^ label); - prefix 2 1 (doc_of_string "p =") (pp p); - prefix 2 1 (doc_of_string "q =") (pp pst.ss.(q)); - prefix 2 1 (doc_of_string "ss' =") (pp ss'); - prefix 2 1 (doc_of_string "ss'.(q) =") (pp ss'.(q)); + text ("Successful AMBIGUOUS Match pass with " ^ label); + prefix 2 1 (doc_of_string "q =") (pp q); + prefix 2 1 (doc_of_string "m.p =") (pp m1.p); + prefix 2 1 (doc_of_string "m.ss' =") (pp m1.ss'); + prefix 2 1 (doc_of_string "m.ss'.(q) =") (pp m1.ss'.(q)); ]; - assume (ss'.(q) == ss_extension.(pst.ss.(q))); - (* ^ should be trivial from the definition of ss' + some missing lemmas in Prover.Substs *) - let pq' : slprop_equiv pst.pg p (ss'.(q)) = - coerce_eq () pq (* weird that we need to coerce? *) - in - Some (| p, ps, slprop_list_equiv_refl _ _, ss', pq' |) - ) - | None -> ( - match match_f_1n label matcher pst q ps with - | None -> None - | Some (| p', ctxt1, ctxt1_ok, ss', p'q |) -> - Some (| p', - p::ctxt1, - slprop_list_equiv_cons _ _ _ _ _ (VE_Refl _ _) ctxt1_ok >>> - slprop_list_equiv_flip _ _ _ _, - ss', - p'q |) - ) + Inr m1 + ) else + Inl [ + text "Ambiguous match for resource:" ^^ + indent (pp q); + text "It can be matched by both:" ^^ + indent (pp m1.p) ^^ hardline ^^ + text "and:" ^^ + indent (pp m2.p) ^^ hardline ^^ + text "in the context."; + ] let weaken_slprop_equiv_env (#g1 : env) @@ -125,17 +239,6 @@ let weaken_slprop_equiv_env (#p #q : slprop) (pf : slprop_equiv g1 p q) : slprop_equiv g2 p q = magic() -let report_ambig (#a:Type) (g:env) (q p p' : slprop) : T.Tac a = - fail_doc_env true g (Some <| range_of_env g) [ - text "Ambiguous match for resource:" ^^ - indent (pp q); - text "It can be matched by both:" ^^ - indent (pp p) ^^ hardline ^^ - text "and:" ^^ - indent (pp p') ^^ hardline ^^ - text "in the context."; - ] - (* Tries to match all of ctxt to all of unsolved, and returns the mpr *) let rec match_f_nn (label : string) @@ -158,22 +261,10 @@ let rec match_f_nn solved_inv = magic(); } in if RU.debug_at_level (fstar_env pst.pg) "prover.match" then - T.print ("Trying to match goal " ^ show q ^ " from context"); - match - try - match_f_1n label matcher_f pst' q mpr.ctxt1 - with - | Ambig (q, p, p') -> - if RU.debug_at_level (fstar_env pst.pg) "prover.match" then ( - T.print "Ambiguity detected... continuing to another goal"; - T.print ("q = " ^ show q); - T.print ("p = " ^ show p); - T.print ("p' = " ^ show p') - ); - None - | e -> raise e - with - | None -> + T.print ("Trying to match goal " ^ show q ^ " from context (" ^ label ^ ")"); + + match match_f_1n label matcher_f pst' q mpr.ctxt1 with + | Inl docs -> (* If that fails we're done, just adding q as unsolved. *) let mpr' = { mpr with unsolved_matched = mpr.unsolved_matched; @@ -181,45 +272,63 @@ let rec match_f_nn unsolved_ok = slprop_list_equiv_cons _ q q _ _ (VE_Refl _ _) mpr.unsolved_ok >>> slprop_list_equiv_push_append _ _ _ _; + + msgs = docs :: mpr.msgs; } in mpr' - | Some (| p, ctxt1, ctxt1_ok, ss', pq |) -> - (* Got another match, extend the mpr. *) - let mpr1 : match_pass_result (push_env pst.pg pst.uvs) pst.ss ctxt unsolved = { - ss' = ss'; - - ctxt_matched = p :: mpr.ctxt_matched; - ctxt1 = ctxt1; - ctxt_ok = mpr.ctxt_ok >>> - weaken_slprop_equiv_env (slprop_list_equiv_append_r _ _ _ _ ctxt1_ok) >>> - VE_Sym _ _ _ (slprop_list_equiv_push_append _ p mpr.ctxt_matched ctxt1); - - unsolved_matched = q :: mpr.unsolved_matched; - unsolved1 = mpr.unsolved1; - unsolved_ok = slprop_list_equiv_cons _ q q _ _ (VE_Refl _ _) mpr.unsolved_ok; - - match_ok = ( - // assume (list_as_slprop (ss'.(q) :: (mpr.ss' $$ mpr.unsolved_matched)) == - // list_as_slprop (ss' $$ q :: mpr.unsolved_matched)); - slprop_list_equiv_cons _ _ _ _ _ (weaken_slprop_equiv_env pq) mpr.match_ok >>* - ve_refl_pf _ _ (admit()) - ); - } - in - mpr1 + | Inr { p; rest; rest_ok; ss'; ss_extends; proof } -> + (* conditionally matched, try to discharge *) + + match unguard proof with + | Inl iss -> + fail_doc_with_subissues pst.pg (Some <| range_of_env pst.pg) iss [ + text "Failed to discharge match guard for goal:" ^^ + indent (pp q) ^^ hardline ^^ + text "with resource from context:" ^^ + indent (pp p); + ] + + | Inr pq -> + (* Got another match, extend the mpr. FIXME: We could accumulate all guards + instead of discharging here. *) + let unsolved_ok : slprop_list_equiv (push_env pst.pg pst.uvs) qs (mpr.unsolved_matched @ mpr.unsolved1) = + mpr.unsolved_ok + in + let ctxt_ok () : slprop_list_equiv (push_env pst.pg pst.uvs) ctxt ((p :: mpr.ctxt_matched) @ rest) = + mpr.ctxt_ok >>> + weaken_slprop_equiv_env (slprop_list_equiv_append_r _ _ _ _ rest_ok) >>> + VE_Sym _ _ _ (slprop_list_equiv_push_append _ p mpr.ctxt_matched rest) + in + let unsolved_ok : slprop_list_equiv (push_env pst.pg pst.uvs) (q::qs) ((q :: mpr.unsolved_matched) @ mpr.unsolved1) = + slprop_list_equiv_cons _ q q _ _ (VE_Refl _ _) unsolved_ok + in + let mpr1 : match_pass_result (push_env pst.pg pst.uvs) pst.ss ctxt unsolved = { + ss' = ss'; + + ctxt_matched = p :: mpr.ctxt_matched; + ctxt1 = rest; + ctxt_ok = ctxt_ok (); + + unsolved_matched = q :: mpr.unsolved_matched; + unsolved1 = coerce_eq () mpr.unsolved1; + unsolved_ok = unsolved_ok; + + match_ok = ( + slprop_list_equiv_cons _ _ _ _ _ (weaken_slprop_equiv_env pq) mpr.match_ok >>* + ve_refl_pf _ _ (admit()) + ); + + msgs = mpr.msgs; + } + in + mpr1 -(* Do a pass over all unsolved goals to see if any can be matched syntactically. *) let match_with (label : string) (matcher : matcher_t) (#preamble:_) (pst:prover_state preamble) - : T.Tac (pst':prover_state preamble { pst' `pst_extends` pst }) - = - // try - let mpr : mpr_t pst = match_f_nn label matcher pst pst.remaining_ctxt pst.unsolved in - apply_mpr pst mpr - // with - // | Ambig (q, p, p') -> - // report_ambig pst.pg q p p' - // | e -> raise e + : T.Tac (list (list document) & pst':prover_state preamble { pst' `pst_extends` pst }) += + let mpr : mpr_t pst = match_f_nn label matcher pst pst.remaining_ctxt pst.unsolved in + mpr.msgs, apply_mpr pst mpr diff --git a/src/checker/Pulse.Checker.Prover.Match.Comb.fsti b/src/checker/Pulse.Checker.Prover.Match.Comb.fsti index d87122ce5..0d1f2167c 100644 --- a/src/checker/Pulse.Checker.Prover.Match.Comb.fsti +++ b/src/checker/Pulse.Checker.Prover.Match.Comb.fsti @@ -18,6 +18,8 @@ module Pulse.Checker.Prover.Match.Comb module T = FStar.Tactics +open FStar.Pprint + open Pulse.Syntax open Pulse.Typing @@ -32,4 +34,4 @@ val match_with (label : string) (matcher : matcher_t) (#preamble:_) (pst:prover_state preamble) - : T.Tac (pst':prover_state preamble { pst' `pst_extends` pst }) + : T.Tac (list (list document) & pst':prover_state preamble { pst' `pst_extends` pst }) diff --git a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst new file mode 100644 index 000000000..581944efd --- /dev/null +++ b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst @@ -0,0 +1,162 @@ +(* + Copyright 2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module Pulse.Checker.Prover.Match.MKeys + +open FStar.List.Tot +open Pulse.Syntax +open Pulse.Typing +open Pulse.Checker.Base +open Pulse.Show + +module T = FStar.Tactics.V2 +module R = FStar.Reflection.V2 +module L = FStar.List.Tot +module TermEq = FStar.Reflection.TermEq +module PTU = Pulse.Typing.Util + +let rec equational (t:term) : bool = + match R.inspect_ln t with + // | R.Tv_Var _ -> true + | R.Tv_App h _ -> equational h + | R.Tv_Match _ _ _ -> true + | R.Tv_AscribedT t _ _ _ + | R.Tv_AscribedC t _ _ _ -> equational t + | _ -> false + +let type_of_fv (g:env) (fv:R.fv) + : T.Tac (option R.term) + = let n = R.inspect_fv fv in + match R.lookup_typ (fstar_env g) n with + | None -> None + | Some se -> + match R.inspect_sigelt se with + | R.Unk -> None + | R.Sg_Let _ lbs -> ( + L.tryPick + (fun lb -> + let lbv = R.inspect_lb lb in + if R.inspect_fv lbv.lb_fv = n + then Some lbv.lb_typ + else None) + lbs + ) + | R.Sg_Val _ _ t -> Some t + | R.Sg_Inductive _nm _univs params typ _ -> None + +let is_mkey (t:R.term) : bool = + match R.inspect_ln t with + | R.Tv_FVar fv -> + let name = R.inspect_fv fv in + name = ["Pulse"; "Lib"; "Core"; "mkey"] + | _ -> false + +let binder_is_mkey (b:R.binder) : bool = + L.existsb is_mkey (R.inspect_binder b).attrs + +let binder_is_slprop (b:R.binder) : T.Tac bool = + let r = TermEq.term_eq tm_slprop (R.inspect_binder b).sort in + T.print <| "is_slprop " ^ show (R.inspect_binder b).sort ^ " = " ^ show r; + r + +let rec zip3 (l1:list 'a) (l2:list 'b) (l3:list 'c) : T.Tac (list ('a & 'b & 'c)) = + match l1, l2, l3 with + | [], [], [] -> [] + | x::xs, y::ys, z::zs -> (x, y, z) :: zip3 xs ys zs + | _, _, _ -> + T.fail "zip3: length mismatch" + +let same_head (t0 t1:term) + : T.Tac bool + = match T.hua t0, T.hua t1 with + | Some (h0, us0, args0), Some (h1, us1, args1) -> + T.inspect_fv h0 = T.inspect_fv h1 && + L.length args0 = L.length args1 + | _ -> + true // conservative + +exception GFalse +exception GTrue + +let rec eligible_for_smt_equality (g:env) (t0 t1 : term) + : T.Tac bool += try + (* Never try to SMT-match pure slprops. In fact we never should be called + on pure slprops anyway. *) + if Tm_Pure? (inspect_term t0) || Tm_Pure? (inspect_term t1) then + raise GFalse; + (* If they are both equational, claim it fair game to try to use SMT. + Note: this is *before* the ambiguity check and we do not perform a query, + so if there is one equational resource in the context and two equational + goals, we will fail claiming ambiguity. *) + (* FIXME: This is probably quite unexpected, but otherwise + working with matches/ifs is a real pain. What do we expect the + user to write...? *) + (* ALSO FIXME: We should only try to equate matches if there is some possibility + that their branches match. No point in trying to + (if p then r|->1 else r|->2) + with + inv i p + or whatever + *) + if equational t0 && equational t1 then + raise GTrue; + let term_eq = TermEq.term_eq in + let h0, args0 = R.collect_app_ln t0 in + let h1, args1 = R.collect_app_ln t1 in + if not (term_eq h0 h1) || not (length args0 = length args1) then + raise GFalse; + + (* At this point, we have two applications with the same head. Look at mkeys. *) + + let hfv = match R.inspect_ln h0 with + | R.Tv_FVar fv + | R.Tv_UInst fv _ -> fv + | _ -> raise GFalse + in + if Pulse.Reflection.Util.fv_has_attr_string "Pulse.Lib.Core.no_mkeys" hfv then + raise GTrue; + let t = match type_of_fv g hfv with | None -> raise GFalse | Some t -> t in + let bs, _ = R.collect_arr_ln_bs t in + if L.length bs <> L.length args0 then + false + else + let bs_args0_args1 = zip3 bs args0 args1 in + let (anykey, eq) = T.fold_right (fun (b, (a0, _), (a1, _)) (anykey, eq)-> + if not eq then (anykey, false) else + if binder_is_mkey b then + let eq' = + if binder_is_slprop b then + eligible_for_smt_equality g a0 a1 + else + try + Some? (fst (PTU.check_equiv_now_nosmt (elab_env g) a0 a1)) + with | _ -> false + in + (true, eq && eq') + else + (anykey, eq) + ) bs_args0_args1 (false, true) + in + (* Attempt SMT if all keys matched. If there are no keys, + we consider that a match. To require at least one key uncomment + the conjunct below. *) + // anykey && + eq + with + | GFalse -> false + | GTrue -> true + | e -> raise e diff --git a/src/checker/Pulse.Checker.Prover.Match.MKeys.fsti b/src/checker/Pulse.Checker.Prover.Match.MKeys.fsti new file mode 100644 index 000000000..30f4784f7 --- /dev/null +++ b/src/checker/Pulse.Checker.Prover.Match.MKeys.fsti @@ -0,0 +1,26 @@ +(* + Copyright 2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module Pulse.Checker.Prover.Match.MKeys + +open FStar.Tactics.V2 +open Pulse.Syntax +open Pulse.Typing + +(* remove!*) +val same_head (t0 t1 : term): Tac bool + +val eligible_for_smt_equality (g:env) (t0 t1 : term) : Tac bool diff --git a/src/checker/Pulse.Checker.Prover.Match.Matchers.fst b/src/checker/Pulse.Checker.Prover.Match.Matchers.fst index 30b97ff55..1d9585ccc 100644 --- a/src/checker/Pulse.Checker.Prover.Match.Matchers.fst +++ b/src/checker/Pulse.Checker.Prover.Match.Matchers.fst @@ -34,6 +34,7 @@ module R = FStar.Reflection.V2 module L = FStar.List.Tot module TermEq = FStar.Reflection.TermEq module RT = FStar.Reflection.Typing +module MKeys = Pulse.Checker.Prover.Match.MKeys module RU = Pulse.RuntimeUtils module PS = Pulse.Checker.Prover.Substs @@ -48,141 +49,6 @@ let cong_l #g #t0 #t1 #t2 (d : slprop_equiv g t1 t2) : slprop_equiv g (t1 * t0) VE_Ctxt _ _ _ _ _ d (VE_Refl _ _) let ve_refl_pf (#g:env) (p q : slprop) (s : squash (p == q)) : slprop_equiv g p q = VE_Refl g p -let rec equational (t:term) : bool = - match R.inspect_ln t with - // | R.Tv_Var _ -> true - | R.Tv_App h _ -> equational h - | R.Tv_Match _ _ _ -> true - | R.Tv_AscribedT t _ _ _ - | R.Tv_AscribedC t _ _ _ -> equational t - | _ -> false - -let type_of_fv (g:env) (fv:R.fv) - : T.Tac (option R.term) - = let n = R.inspect_fv fv in - match R.lookup_typ (fstar_env g) n with - | None -> None - | Some se -> - match R.inspect_sigelt se with - | R.Unk -> None - | R.Sg_Let _ lbs -> ( - L.tryPick - (fun lb -> - let lbv = R.inspect_lb lb in - if R.inspect_fv lbv.lb_fv = n - then Some lbv.lb_typ - else None) - lbs - ) - | R.Sg_Val _ _ t -> Some t - | R.Sg_Inductive _nm _univs params typ _ -> None - -type matching_kind = - | Syntactic - | Strict - | Full - -let is_equate_by_smt (t:R.term) : bool = - match R.inspect_ln t with - | R.Tv_FVar fv -> - let name = R.inspect_fv fv in - name = ["Pulse"; "Lib"; "Core"; "equate_by_smt"] - | _ -> false - -let is_equate_strict (t:R.term) : bool = - match R.inspect_ln t with - | R.Tv_FVar fv -> - let name = R.inspect_fv fv in - name = ["Pulse"; "Lib"; "Core"; "equate_strict"] - | _ -> false - -let is_equate_syntactic (t:R.term) : bool = - match R.inspect_ln t with - | R.Tv_FVar fv -> - let name = R.inspect_fv fv in - name = ["Pulse"; "Lib"; "Core"; "equate_syntactic"] - | _ -> false - -(* Gets the strictest matching kind from a list of attributes. *) -let matching_kind_from_attr (ats : list term) : matching_kind = - if L.existsb is_equate_syntactic ats then Syntactic - else if L.existsb is_equate_strict ats then Strict - else Full - -let rec zip3 (l1:list 'a) (l2:list 'b) (l3:list 'c) : T.Tac (list ('a & 'b & 'c)) = - match l1, l2, l3 with - | [], [], [] -> [] - | x::xs, y::ys, z::zs -> (x, y, z) :: zip3 xs ys zs - | _, _, _ -> - T.fail "zip3: length mismatch" - -let same_head (g:env) (t0 t1:term) - : T.Tac bool - = match T.hua t0, T.hua t1 with - | Some (h0, us0, args0), Some (h1, us1, args1) -> - T.inspect_fv h0 = T.inspect_fv h1 && - L.length args0 = L.length args1 - | _ -> - true // conservative - -let eligible_for_smt_equality (g:env) (t0 t1:term) - : T.Tac bool - = let either_equational () = equational t0 || equational t1 in - let term_eq t0 t1 = TermEq.term_eq t0 t1 in - if term_eq t0 t1 || either_equational () then true - else - match inspect_term t0, inspect_term t1 with - | Tm_ForallSL _ _ _, Tm_ForallSL _ _ _ -> true - | _ -> ( - let h0, args0 = R.collect_app_ln t0 in - let h1, args1 = R.collect_app_ln t1 in - if term_eq h0 h1 && L.length args0 = L.length args1 - then ( - match R.inspect_ln h0 with - | R.Tv_FVar fv - | R.Tv_UInst fv _ -> ( - match type_of_fv g fv with - | None -> false - | Some t -> - let bs, _ = R.collect_arr_ln_bs t in - if L.length bs <> L.length args0 - then false - else ( - let bs_args0_args1 = zip3 bs args0 args1 in - T.fold_right (fun (b, (a0, _), (a1, _)) acc -> - if not acc then false else - let ats = (R.inspect_binder b).attrs in - match matching_kind_from_attr ats with - | Syntactic -> term_eq a0 a1 - | Strict -> begin - try - Some? (fst (PTU.check_equiv_now_nosmt (elab_env g) a0 a1)) - with | _ -> false - end - - | Full -> true - ) bs_args0_args1 true - ) - ) - | _ -> false - ) - else false - ) - | _ -> false - -let refl_uvar (t:R.term) (uvs:env) : option var = - let open R in - match inspect_ln t with - | Tv_Var v -> - let {uniq=n} = inspect_namedv v in - if contains uvs n then Some n else None - | _ -> None - -let is_uvar (t:term) (uvs:env) : option var = refl_uvar t uvs - -let contains_uvar (t:term) (uvs:env) (g:env) : T.Tac bool = - not (check_disjoint uvs (freevars t)) - // // Call into the F* unifier to solve for uvs by unifying p and q // @@ -260,69 +126,46 @@ let eq_tm_unascribe (g:env) (p q:term) : option (erased (RT.equiv (elab_env g) p ) else None -let try_unif_nosmt (g:env) (p q:term) : T.Tac (option (T.equiv_token (elab_env g) p q) & T.issues) = - let hp, args_p = R.collect_app_ln p in - let hq, args_q = R.collect_app_ln q in - if RU.debug_at_level (fstar_env g) "ggg" then - info_doc g (Some <| range_of_env g) [ - text "try_unify_nosmt"; - text "p: " ^^ pp p; - text "q: " ^^ pp q; - ]; - let r = - (* We only try to unify if the heads syntactically match. *) - if TermEq.term_eq hp hq then - PTU.check_equiv_now_nosmt (elab_env g) p q - else - None, [] - in - // if RU.debug_at_level (fstar_env g) "ggg" then - // info_doc g (Some <| range_of_env g) [ - // text "Unification result:"; - // text "p: " ^^ pp p; - // text "q: " ^^ pp q; - // text "result: " ^^ (arbitrary_string <| Pulse.Show.show (Some? (fst r), List.length (snd r) <: bool & int)); - // ]; - r - -let head_is_uvar (uvs:env) (t:term) : T.Tac bool = - let hd, _ = T.collect_app t in - match T.inspect hd with - | T.Tv_Var v -> - List.existsb (fun (x, _) -> x = v.uniq) (bindings uvs) - | _ -> false - (**************** The actual matchers *) +open Pulse.VC + (* The syntactic matcher *) let match_syntactic_11 (#preamble:_) (pst : prover_state preamble) (p q : slprop) - : T.Tac (match_success_t pst p q) + : T.Tac (match_res_t pst p q) = (* term_eq gives us provable equality between p and q, so we can use VE_Refl. *) if TermEq.term_eq p q - then (| PS.empty, VE_Refl _ _ |) - else raise (NoMatch "not term_eq") + then Matched PS.empty Trivial (fun () -> VE_Refl _ _) + else NoMatch "not term_eq" (* Fast unification / strict matcher *) let match_fastunif_11 (#preamble:_) (pst : prover_state preamble) (p q : slprop) - : T.Tac (match_success_t pst p q) + : T.Tac (match_res_t pst p q) = match PTU.check_equiv_now_nosmt (elab_env pst.pg) p q with - | Some tok, _ -> (| PS.empty, VE_Ext _ _ _ tok |) - | None, _ -> raise (NoMatch "no unif") + | Some tok, _ -> + Matched PS.empty Trivial (fun () -> VE_Ext _ _ _ tok) + | None, _ -> + NoMatch "no unif" let match_fastunif_inst_11 (#preamble:_) (pst : prover_state preamble) (p q : slprop) - : T.Tac (match_success_t pst p q) + : T.Tac (match_res_t pst p q) = let g = pst.pg in let q0 = q in (* If the heads of p and q differ, skip. *) - if not <| same_head pst.pg p q then - raise (NoMatch "head mismatch"); + if not <| MKeys.same_head p q then ( + if RU.debug_at_level (fstar_env g) "ggg" then + info_doc g (Some <| range_of_env g) [ + text "head mismatch"; + ]; + raise (ENoMatch "head mismatch") + ); (* Try to instantiate q's uvars by matching it to p. We do not trust this call so we then typecheck the result (and normalize it too). *) @@ -333,48 +176,55 @@ let match_fastunif_inst_11 fails to typecheck, say due to a bad solution of uvars by try_solve_uvars, then we must also fail here. Hence we use ForceSMT to not batch these queries. *) match T.with_policy T.ForceSMT (fun () -> T.tc_term (elab_env g) q_subst) with - | Some (q_subst', _), [] -> + | Some (q_subst', _), _ -> T.norm_well_typed_term (elab_env g) [NormSteps.unascribe; primops; iota] q_subst' - | _ -> + | None, issues -> + if RU.debug_at_level (fstar_env g) "ggg" then + info_doc_with_subissues g (Some <| range_of_env g) issues [ + text "bad uvars?"; + ]; // bad uvars, just ignore - raise (NoMatch "uvar solution did not check") + raise (ENoMatch "uvar solution did not check") in let q_subst_eq_q_norm : erased (equiv_token (elab_env g) q_subst q_norm) = magic () in if RU.debug_at_level (fstar_env g) "ggg" then info_doc g (Some <| range_of_env g) [ text "match_fastunif_inst_11"; - text "p: " ^^ pp p; - text "q: " ^^ pp q; - text "q_subst: " ^^ pp q_subst; - text "q_norm: " ^^ pp q_norm; + doc_of_string "p: " ^/^ pp p; + doc_of_string "q: " ^/^ pp q; + doc_of_string "q_subst: " ^/^ pp q_subst; + doc_of_string "q_norm: " ^/^ pp q_norm; ]; match PTU.check_equiv_now_nosmt (elab_env pst.pg) p q_norm with - | None, _ -> raise (NoMatch "no unif") + | None, issues -> + if RU.debug_at_level (fstar_env g) "ggg" then + info_doc_with_subissues g (Some <| range_of_env g) issues [ + text "match_fastunif_inst_11: check_equiv failed, no unif"; + ]; + raise (ENoMatch "no unif") | Some token, _ -> // (| ss', VE_Ext _ _ _ (RU.magic ()) |) let p_eq_q_norm : slprop_equiv g p q_norm = VE_Ext _ _ _ token in let p_eq_q : slprop_equiv g p q_subst = p_eq_q_norm >>> VE_Sym _ _ _ (VE_Ext _ _ _ q_subst_eq_q_norm) in - (| ss', p_eq_q |) + Matched ss' Trivial (fun () -> p_eq_q) -(* Full unification with SMT. Also can instantiate uvars (strict should maybe -also do this?). *) let match_full_11 (#preamble:_) (pst : prover_state preamble) (p q : slprop) - : T.Tac (match_success_t pst p q) + : T.Tac (match_res_t pst p q) = let g = pst.pg in let q0 = q in (* If the heads of p and q differ, skip. *) - if not <| same_head pst.pg p q then - raise (NoMatch "head mismatch"); - + if not <| MKeys.same_head p q then + raise (ENoMatch "head mismatch"); + (* Try to instantiate q's uvars by matching it to p. We do not trust this call so we then typecheck the result (and normalize it too). *) let ss' = try_solve_uvars pst.pg pst.uvs p q in @@ -383,6 +233,7 @@ let match_full_11 (* First typecheck q_subst and then normalize it. If it fails to typecheck, say due to a bad solution of uvars by try_solve_uvars, then we must also fail here. Hence we use ForceSMT to not batch these queries. *) + // FIXME: Do not call SMT here. match T.with_policy T.ForceSMT (fun () -> T.tc_term (elab_env g) q_subst) with | Some (q_subst', _), [] -> T.norm_well_typed_term (elab_env g) @@ -390,7 +241,7 @@ let match_full_11 q_subst' | _ -> // bad uvars, just ignore - raise (NoMatch "uvar solution did not check") + raise (ENoMatch "uvar solution did not check") in (* FIXME: extend reflection typing to provide the token. The norm_well_typed_term @@ -400,15 +251,14 @@ let match_full_11 (* Check now, after normalizing etc, that we are allowed to try an SMT query to match them. This is the part that looks at the binder attributes for strictness. If this check doesn't pass, skip. *) - if not (eligible_for_smt_equality g p q_norm) then - raise (NoMatch "not eligible for SMT"); + if not (MKeys.eligible_for_smt_equality g p q_norm) then + raise (ENoMatch "not eligible for SMT"); - (* Finally, try to match and construct proof. *) - match PTU.check_equiv_now (elab_env g) p q_norm with - | None, _ -> raise (NoMatch "no unif") - | Some token, _ -> + (* Return a guarded result *) + Matched ss' (EquivToken g p q_norm) (fun token -> let p_eq_q_norm : slprop_equiv g p q_norm = VE_Ext _ _ _ token in let p_eq_q : slprop_equiv g p q_subst = p_eq_q_norm >>> VE_Sym _ _ _ (VE_Ext _ _ _ q_subst_eq_q_norm) in - (| ss', p_eq_q |) + p_eq_q + ) diff --git a/src/checker/Pulse.Checker.Prover.Match.Matchers.fsti b/src/checker/Pulse.Checker.Prover.Match.Matchers.fsti index 253fd64eb..88953fccf 100644 --- a/src/checker/Pulse.Checker.Prover.Match.Matchers.fsti +++ b/src/checker/Pulse.Checker.Prover.Match.Matchers.fsti @@ -20,7 +20,7 @@ open Pulse.Checker.Prover.Match.Base (* The actual matchers, in 1-to-1 form. Usually called with Match.Comb.match_with *) -val match_syntactic_11 : matcher_t -val match_fastunif_11 : matcher_t +val match_syntactic_11 : matcher_t +val match_fastunif_11 : matcher_t val match_fastunif_inst_11 : matcher_t -val match_full_11 : matcher_t +val match_full_11 : matcher_t diff --git a/src/checker/Pulse.Checker.Prover.Match.fsti b/src/checker/Pulse.Checker.Prover.Match.fsti index 51d886d3f..da59d9931 100644 --- a/src/checker/Pulse.Checker.Prover.Match.fsti +++ b/src/checker/Pulse.Checker.Prover.Match.fsti @@ -17,19 +17,20 @@ module Pulse.Checker.Prover.Match module T = FStar.Tactics +open FStar.Pprint open Pulse.Checker.Prover.Base (* Full matching passes. *) val match_syntactic (#preamble:preamble) (pst:prover_state preamble) -: T.Tac (pst':prover_state preamble { pst' `pst_extends` pst }) +: T.Tac (list (list document) & pst':prover_state preamble { pst' `pst_extends` pst }) val match_fastunif (#preamble:preamble) (pst:prover_state preamble) -: T.Tac (pst':prover_state preamble { pst' `pst_extends` pst }) +: T.Tac (list (list document) & pst':prover_state preamble { pst' `pst_extends` pst }) val match_fastunif_i (#preamble:preamble) (pst:prover_state preamble) -: T.Tac (pst':prover_state preamble { pst' `pst_extends` pst }) +: T.Tac (list (list document) & pst':prover_state preamble { pst' `pst_extends` pst }) val match_full (#preamble:preamble) (pst:prover_state preamble) -: T.Tac (pst':prover_state preamble { pst' `pst_extends` pst }) +: T.Tac (list (list document) & pst':prover_state preamble { pst' `pst_extends` pst }) diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 1787977af..c21a152dd 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -232,7 +232,7 @@ let intro_any_exists noeq type prover_iteration_res_t (#preamble:_) (pst0:prover_state preamble) = | Stepped : lbl:string -> pst':prover_state preamble { pst' `pst_extends` pst0 } -> prover_iteration_res_t pst0 - | NoProgress + | NoProgress of list (list document) (* possible hints *) (* a "subtyping" in the pst for the type above. *) let res_advance (#preamble:_) @@ -242,18 +242,28 @@ let res_advance (#preamble:_) : prover_iteration_res_t pst0 = match ir with | Stepped lbl pst1' -> Stepped lbl pst1' - | NoProgress -> NoProgress + | NoProgress ms -> NoProgress ms +(* Move this type to a common module to make sure all passes adhere. *) let prover_pass_t : Type = (#preamble:_) -> (pst0:prover_state preamble) -> - T.Tac (pst:prover_state preamble{ pst `pst_extends` pst0 }) + T.Tac (list (list document) & pst:prover_state preamble{ pst `pst_extends` pst0 }) (* A helper to avoid F* issue #3339. *) noeq type prover_pass = | P : string -> prover_pass_t -> prover_pass +let adddocs docs + (#preamble:_) (#pst : prover_state preamble) + (r : prover_iteration_res_t pst) +: prover_iteration_res_t pst += + match r with + | NoProgress ms -> NoProgress (ms@docs) + | Stepped lbl pst -> Stepped lbl pst + (* Going over the passes, stopping as soon as one makes progress. *) let rec prover_iteration_loop (#preamble:_) @@ -262,9 +272,9 @@ let rec prover_iteration_loop : T.Tac (prover_iteration_res_t pst0) = match passes with - | [] -> NoProgress + | [] -> NoProgress [] | (P name pass)::passes' -> - let pst = pass pst0 in + let (docs, pst) = pass pst0 in if pst.progress then ( debug_prover pst.pg (fun _ -> Printf.sprintf "prover: %s: made progress, remaining_ctxt after pass = %s\n" @@ -275,15 +285,14 @@ let rec prover_iteration_loop Printf.sprintf "prover: %s: no progress\n" name); (* TODO: start from pst0? *) // res_advance <| prover_iteration_loop pst passes' - prover_iteration_loop pst0 passes' + adddocs docs (prover_iteration_loop pst0 passes') ) - let prover_pass_collect_exists (#preamble:_) (pst0:prover_state preamble) - : T.Tac (pst:prover_state preamble{ pst `pst_extends` pst0 }) + : T.Tac (list (list document) & pst:prover_state preamble{ pst `pst_extends` pst0 }) = let (| exs, rest, d |) = collect_exists (push_env pst0.pg pst0.uvs) pst0.unsolved in - unsolved_equiv_pst pst0 (exs@rest) d + [], unsolved_equiv_pst pst0 (exs@rest) d (* One prover iteration is applying these passes until one succeeds. If so, we return a "Stepped" with the new pst (and the prover starts @@ -297,6 +306,8 @@ let prover_iteration res_advance <| prover_iteration_loop pst [ // P "elim_pure_pst" ElimPure.elim_pure_pst; + // ^ This is done explicitly below, but check again since some proofs + // seem to lack this step. P "elim_exists" ElimExists.elim_exists_pst; P "collect_exists" prover_pass_collect_exists; P "explode" Explode.explode; @@ -342,7 +353,7 @@ let rec prover name (show (list_as_slprop pst.remaining_ctxt))); prover pst' - | NoProgress -> + | NoProgress msgs -> let pst = intro_any_exists pst prover in if pst.progress then prover pst else let () = () in @@ -374,7 +385,11 @@ let rec prover prover pst' | None -> let msg = [ - text "Cannot prove:" ^^ + text ( + if List.length non_pures > 1 + then "Cannot prove any of:" + else "Cannot prove:" + ) ^^ indent (pp <| canon_slprop_list_print non_pures); text "In the context:" ^^ indent (pp <| canon_slprop_list_print pst.remaining_ctxt) @@ -385,9 +400,14 @@ let rec prover indent (pp preamble.ctxt); ] else []) in + let pass_hints = + if Cons? (List.flatten msgs) + then [ text "Some hints:" ] @ List.flatten msgs + else [] + in // GM: I feel I should use (Some q.range) instead of None, but that makes // several error locations worse. - fail_doc pst.pg None msg + fail_doc pst.pg None (msg @ pass_hints) #pop-options #pop-options let rec get_q_at_hd (g:env) (l:list slprop) (q:slprop { L.existsb (fun v -> eq_tm v q) l }) @@ -419,95 +439,83 @@ let prove let ctxt_l = slprop_as_list ctxt in - if false && Nil? (bindings uvs) && L.existsb (fun v -> eq_tm v goals) ctxt_l - then begin - let (| l', d_eq |) = get_q_at_hd g ctxt_l goals in - let g1 = g in - let nts : PS.nt_substs = [] in - let remaining_ctxt = list_as_slprop l' in - let k : continuation_elaborator g ctxt g1 ctxt = k_elab_unit g ctxt in - assume (list_as_slprop (slprop_as_list ctxt) == ctxt); - let d_eq - : slprop_equiv g ctxt ((PS.nt_subst_term goals nts) * remaining_ctxt) = coerce_eq d_eq () in - (| g1, nts, [], remaining_ctxt, k_elab_equiv k (VE_Refl _ _) d_eq |) - end - else - let ctxt_frame_typing : slprop_typing g (ctxt * tm_emp) = RU.magic () in - let preamble = { - g0 = g; - ctxt; - frame = tm_emp; - ctxt_frame_typing; - goals; - } in - assume (list_as_slprop (slprop_as_list ctxt) == ctxt); - assume ((PS.empty).(tm_emp) == tm_emp); - let pst0 : prover_state preamble = { - pg = g; - remaining_ctxt = slprop_as_list ctxt; - remaining_ctxt_frame_typing = ctxt_frame_typing; - uvs = uvs; - ss = PS.empty; - nts = None; - solved = tm_emp; - unsolved = slprop_as_list goals; - k = k_elab_equiv (k_elab_unit g ctxt) (RU.magic ()) (RU.magic ()); - goals_inv = RU.magic (); - solved_inv = (); - progress = false; - allow_ambiguous = allow_ambiguous; - } in - - let pst = prover pst0 in - - let (| nts, effect_labels |) - : nts:PS.nt_substs & - effect_labels:list T.tot_or_ghost { - PS.well_typed_nt_substs pst.pg pst.uvs nts effect_labels /\ - PS.is_permutation nts pst.ss - } = - match pst.nts with - | Some nts -> nts - | None -> - // warn_doc pst.pg None [ - // text <| Printf.sprintf "About to translate prover state to nts (nts is None)"; - // prefix 2 1 (text "pst.pg =") (pp pst.pg); - // prefix 2 1 (text "pst.uvs =") (pp pst.uvs); - // prefix 2 1 (text "pst.ss =") (pp pst.ss); - // prefix 2 1 (text "pst.remaining_ctxt =") (pp pst.remaining_ctxt); - // prefix 2 1 (text "pst.unsolved =") (pp pst.unsolved); - // ]; - let r = PS.ss_to_nt_substs pst.pg pst.uvs pst.ss in - match r with - | Inr msg -> - fail_doc pst.pg None [ - text <| Printf.sprintf "Prover error: ill-typed substitutions (%s)" msg; - prefix 2 1 (text "pst.pg =") (pp pst.pg); - prefix 2 1 (text "pst.uvs =") (pp pst.uvs); - prefix 2 1 (text "pst.ss =") (pp pst.ss); - prefix 2 1 (text "pst.remaining_ctxt =") (pp pst.remaining_ctxt); - prefix 2 1 (text "pst.unsolved =") (pp pst.unsolved); - ] - | Inl nts -> nts in - let nts_uvs, nts_uvs_effect_labels = - PS.well_typed_nt_substs_prefix pst.pg pst.uvs nts effect_labels uvs in - let k - : continuation_elaborator - g (ctxt * tm_emp) - pst.pg ((list_as_slprop pst.remaining_ctxt * tm_emp) * (PS.nt_subst_term pst.solved nts)) = pst.k in - // admit () - let goals_inv - : slprop_equiv (push_env pst.pg pst.uvs) goals (list_as_slprop [] * pst.solved) = pst.goals_inv in - let goals_inv - : slprop_equiv pst.pg (PS.nt_subst_term goals nts) (PS.nt_subst_term (list_as_slprop [] * pst.solved) nts) = - PS.slprop_equiv_nt_substs_derived pst.pg pst.uvs goals_inv nts effect_labels in - - // goals is well-typed in initial g + uvs - // so any of the remaining uvs in pst.uvs should not be in goals - // so we can drop their substitutions from the tail of nts - assume (PS.nt_subst_term goals nts == PS.nt_subst_term goals nts_uvs); - - (| pst.pg, nts_uvs, nts_uvs_effect_labels, list_as_slprop pst.remaining_ctxt, k_elab_equiv k (RU.magic ()) (RU.magic ()) |) + let ctxt_frame_typing : slprop_typing g (ctxt * tm_emp) = RU.magic () in + let preamble = { + g0 = g; + ctxt; + frame = tm_emp; + ctxt_frame_typing; + goals; + } in + assume (list_as_slprop (slprop_as_list ctxt) == ctxt); + assume ((PS.empty).(tm_emp) == tm_emp); + let pst0 : prover_state preamble = { + pg = g; + remaining_ctxt = slprop_as_list ctxt; + remaining_ctxt_frame_typing = ctxt_frame_typing; + uvs = uvs; + ss = PS.empty; + nts = None; + solved = tm_emp; + unsolved = slprop_as_list goals; + k = k_elab_equiv (k_elab_unit g ctxt) (RU.magic ()) (RU.magic ()); + goals_inv = RU.magic (); + solved_inv = (); + progress = false; + allow_ambiguous = allow_ambiguous; + } in + + let pst = prover pst0 in + + let (| nts, effect_labels |) + : nts:PS.nt_substs & + effect_labels:list T.tot_or_ghost { + PS.well_typed_nt_substs pst.pg pst.uvs nts effect_labels /\ + PS.is_permutation nts pst.ss + } = + match pst.nts with + | Some nts -> nts + | None -> + // warn_doc pst.pg None [ + // text <| Printf.sprintf "About to translate prover state to nts (nts is None)"; + // prefix 2 1 (text "pst.pg =") (pp pst.pg); + // prefix 2 1 (text "pst.uvs =") (pp pst.uvs); + // prefix 2 1 (text "pst.ss =") (pp pst.ss); + // prefix 2 1 (text "pst.remaining_ctxt =") (pp pst.remaining_ctxt); + // prefix 2 1 (text "pst.unsolved =") (pp pst.unsolved); + // ]; + let r = PS.ss_to_nt_substs pst.pg pst.uvs pst.ss in + match r with + | Inr msg -> + fail_doc pst.pg None [ + text <| Printf.sprintf "Prover error: ill-typed substitutions (%s)" msg; + prefix 2 1 (text "pst.pg =") (pp pst.pg); + prefix 2 1 (text "pst.uvs =") (pp pst.uvs); + prefix 2 1 (text "pst.ss =") (pp pst.ss); + prefix 2 1 (text "pst.remaining_ctxt =") (pp pst.remaining_ctxt); + prefix 2 1 (text "pst.unsolved =") (pp pst.unsolved); + ] + | Inl nts -> nts + in + let nts_uvs, nts_uvs_effect_labels = + PS.well_typed_nt_substs_prefix pst.pg pst.uvs nts effect_labels uvs in + let k () + : continuation_elaborator + g (ctxt * tm_emp) + pst.pg ((list_as_slprop pst.remaining_ctxt * tm_emp) * (PS.nt_subst_term pst.solved nts)) = pst.k in + // admit () + let goals_inv + : slprop_equiv (push_env pst.pg pst.uvs) goals (list_as_slprop [] * pst.solved) = pst.goals_inv in + let goals_inv + : slprop_equiv pst.pg (PS.nt_subst_term goals nts) (PS.nt_subst_term (list_as_slprop [] * pst.solved) nts) = + PS.slprop_equiv_nt_substs_derived pst.pg pst.uvs goals_inv nts effect_labels in + + // goals is well-typed in initial g + uvs + // so any of the remaining uvs in pst.uvs should not be in goals + // so we can drop their substitutions from the tail of nts + assume (PS.nt_subst_term goals nts == PS.nt_subst_term goals nts_uvs); + + (| pst.pg, nts_uvs, nts_uvs_effect_labels, list_as_slprop pst.remaining_ctxt, k_elab_equiv (k ()) (RU.magic ()) (RU.magic ()) |) #pop-options let canon_post (c:comp_st) : comp_st = From 7dc386ca9a6f5d3577c9c56767ec3e531bafd013 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Thu, 13 Feb 2025 23:01:36 -0800 Subject: [PATCH 03/32] Allow admitting SMT queries. Now that we do not backtrack on their result, there is no harm in doing laxer checking. --- src/checker/Pulse.Main.fst | 4 ---- src/checker/Pulse.RuntimeUtils.fsti | 2 -- src/checker/Pulse.Typing.Util.fst | 10 ++++------ src/ml/Pulse_RuntimeUtils.ml | 6 ------ 4 files changed, 4 insertions(+), 18 deletions(-) diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index e6226347a..f8f824ade 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -284,10 +284,6 @@ let parse_guard_policy (s:string) : Tac guard_policy = | _ -> Tactics.fail ("Unknown guard policy: " ^ s) let main t pre : RT.dsl_tac_t = fun (g, expected_t) -> - let g = RU.env_disable_admit g in - RU.disable_admit_smt_queries fun _ -> - (* ^ Never admit queries, we currently need to backtrack - on their result. *) (* We use the ForceSMT policy by default, to discharge guards immediately when they show, allowing SMT. This proofstate and discharge them all at the end, potentially joining diff --git a/src/checker/Pulse.RuntimeUtils.fsti b/src/checker/Pulse.RuntimeUtils.fsti index e3c33d6d5..4ccd1f38d 100644 --- a/src/checker/Pulse.RuntimeUtils.fsti +++ b/src/checker/Pulse.RuntimeUtils.fsti @@ -22,8 +22,6 @@ val extend_context (tag:string) (r:option range) (ctx:context) : context val with_context (c:context) (f:unit -> T.Tac 'a) : T.Tac 'a val with_error_bound (r:Range.range) (f:unit -> T.Tac 'a) : T.Tac 'a val with_extv (k v : string) (f:unit -> T.Tac 'a) : T.Tac 'a -val env_disable_admit (e:env) : Tot (e':env{e == e'}) // admit is not observable -val disable_admit_smt_queries (f:unit -> T.Tac 'a) : T.Tac 'a val print_context (c:context) : T.Tac string val debug_at_level_no_module (s:string) : bool val debug_at_level (g:env) (s:string) : bool diff --git a/src/checker/Pulse.Typing.Util.fst b/src/checker/Pulse.Typing.Util.fst index b31edfa0f..bdea334f4 100644 --- a/src/checker/Pulse.Typing.Util.fst +++ b/src/checker/Pulse.Typing.Util.fst @@ -20,9 +20,8 @@ module T = FStar.Tactics.V2 module RU = Pulse.RuntimeUtils (* Call check_equiv under a ForceSMT guard policy *) let check_equiv_now tcenv t0 t1 = - RU.disable_admit_smt_queries (fun _ -> - T.with_policy ForceSMT (fun () -> - T.check_equiv tcenv t0 t1)) + T.with_policy ForceSMT (fun () -> + T.check_equiv tcenv t0 t1) (* Call check_equiv without allowing it to generate guards nor unfold. It's a very @@ -30,9 +29,8 @@ simple use of the core checker + unifier. The Force guard_policy is probably unneeded, as no guards should appear. *) let check_equiv_now_nosmt tcenv t0 t1 = - RU.disable_admit_smt_queries (fun _ -> - // T.with_policy ForceSMT (fun () -> - T.check_equiv_nosmt tcenv t0 t1) + // T.with_policy ForceSMT (fun () -> + T.check_equiv_nosmt tcenv t0 t1 let universe_of_now g e = T.with_policy ForceSMT (fun () -> diff --git a/src/ml/Pulse_RuntimeUtils.ml b/src/ml/Pulse_RuntimeUtils.ml index e1e9b3fe7..7f2898301 100644 --- a/src/ml/Pulse_RuntimeUtils.ml +++ b/src/ml/Pulse_RuntimeUtils.ml @@ -27,12 +27,6 @@ let rec with_context (c:context) (f: unit -> 'a utac) : 'a utac = let with_error_bound (r:FStarC_Range.range) (f: unit -> 'a utac) : 'a utac = fun ps -> FStarC_Errors.with_error_bound r (fun _ -> f () ps) -let env_disable_admit (e : FStarC_TypeChecker_Env.env) = - { e with admit = false } -let disable_admit_smt_queries (f: unit -> 'a utac) : 'a utac = - fun ps -> - let ps = { ps with main_context = env_disable_admit ps.main_context } in - f () ps let with_extv (k:string) (v:string) (f: unit -> 'a utac) : 'a utac = fun ps -> let open FStarC_Options_Ext in From ca06dd1aa6e0069302fa335d2489803bf470b0cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Sun, 16 Feb 2025 18:31:23 -0800 Subject: [PATCH 04/32] Update pulse library --- lib/common/Pulse.Lib.Core.fsti | 17 +- lib/core/Pulse.Lib.Core.fst | 6 +- lib/pulse/c/Pulse.C.Types.Base.fsti | 4 +- lib/pulse/lib/Pulse.Lib.AVLTree.fst | 388 ++++++++++-------- lib/pulse/lib/Pulse.Lib.AVLTree.fsti | 2 +- .../lib/Pulse.Lib.AnchoredReference.fsti | 4 +- lib/pulse/lib/Pulse.Lib.Array.Core.fst | 4 +- lib/pulse/lib/Pulse.Lib.Array.Core.fsti | 8 +- lib/pulse/lib/Pulse.Lib.ArrayPtr.fst | 36 +- lib/pulse/lib/Pulse.Lib.ArrayPtr.fsti | 4 +- .../lib/Pulse.Lib.BigGhostReference.fsti | 2 +- lib/pulse/lib/Pulse.Lib.BigReference.fst | 2 +- lib/pulse/lib/Pulse.Lib.BigReference.fsti | 2 +- lib/pulse/lib/Pulse.Lib.Box.fsti | 6 +- .../lib/Pulse.Lib.CancellableInvariant.fst | 8 +- lib/pulse/lib/Pulse.Lib.ConditionVar.fst | 21 +- lib/pulse/lib/Pulse.Lib.Deque.fst | 157 +++---- lib/pulse/lib/Pulse.Lib.Deque.fsti | 2 +- lib/pulse/lib/Pulse.Lib.DequeRef.fst | 10 +- lib/pulse/lib/Pulse.Lib.FlippableInv.fst | 29 +- lib/pulse/lib/Pulse.Lib.Forall.Util.fst | 3 +- lib/pulse/lib/Pulse.Lib.Forall.fst | 2 +- .../lib/Pulse.Lib.GhostFractionalTable.fst | 4 +- .../lib/Pulse.Lib.GhostFractionalTable.fsti | 4 +- .../lib/Pulse.Lib.GhostPCMReference.fsti | 2 +- lib/pulse/lib/Pulse.Lib.GhostReference.fst | 2 +- lib/pulse/lib/Pulse.Lib.GhostReference.fsti | 2 +- lib/pulse/lib/Pulse.Lib.HigherArray.fst | 39 +- lib/pulse/lib/Pulse.Lib.HigherArray.fsti | 6 +- .../lib/Pulse.Lib.HigherGhostReference.fsti | 2 +- lib/pulse/lib/Pulse.Lib.HigherReference.fsti | 2 +- lib/pulse/lib/Pulse.Lib.LinkedList.fst | 105 +++-- lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst | 2 +- .../lib/Pulse.Lib.MonotonicGhostRef.fsti | 2 +- lib/pulse/lib/Pulse.Lib.OnRange.fst | 6 +- lib/pulse/lib/Pulse.Lib.OnRange.fsti | 2 +- lib/pulse/lib/Pulse.Lib.Primitives.fsti | 1 - lib/pulse/lib/Pulse.Lib.Reference.fsti | 4 +- lib/pulse/lib/Pulse.Lib.SLPropTable.fst | 5 +- lib/pulse/lib/Pulse.Lib.SLPropTable.fsti | 5 +- lib/pulse/lib/Pulse.Lib.SeqMatch.Util.fst | 4 +- lib/pulse/lib/Pulse.Lib.SeqMatch.fst | 69 +++- lib/pulse/lib/Pulse.Lib.SeqMatch.fsti | 29 +- lib/pulse/lib/Pulse.Lib.Slice.Util.fst | 4 +- lib/pulse/lib/Pulse.Lib.Slice.fst | 120 +++--- lib/pulse/lib/Pulse.Lib.Slice.fsti | 7 +- lib/pulse/lib/Pulse.Lib.SpinLock.fst | 8 +- lib/pulse/lib/Pulse.Lib.SpinLock.fsti | 2 +- lib/pulse/lib/Pulse.Lib.Stick.fsti | 46 +-- lib/pulse/lib/Pulse.Lib.Swap.Slice.fst | 3 +- lib/pulse/lib/Pulse.Lib.Task.fst | 75 ++-- lib/pulse/lib/Pulse.Lib.Vec.fsti | 2 +- lib/pulse/lib/class/Pulse.Class.PtsTo.fst | 2 +- .../lib/pledge/Pulse.Lib.Pledge.Simple.fst | 2 +- .../lib/pledge/Pulse.Lib.Pledge.Simple.fsti | 2 +- lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst | 52 +-- lib/pulse/lib/pledge/Pulse.Lib.SmallTrade.fst | 6 +- lib/pulse/lib/pledge/Pulse.Lib.Trade.fst | 2 + 58 files changed, 751 insertions(+), 596 deletions(-) diff --git a/lib/common/Pulse.Lib.Core.fsti b/lib/common/Pulse.Lib.Core.fsti index 180346051..34b6eb634 100644 --- a/lib/common/Pulse.Lib.Core.fsti +++ b/lib/common/Pulse.Lib.Core.fsti @@ -23,10 +23,6 @@ module T = FStar.Tactics.V2 open Pulse.Lib.Dv {} open FStar.ExtractAs -val equate_by_smt : unit (* remove *) -val equate_strict : unit (* remove *) -val equate_syntactic : unit (* remove *) - (* Arguments of slprops can be marked as a matching key to 1- Make sure we do no try to use the SMT to match resources with different matching keys (in other words, we only use the unifier to @@ -179,7 +175,10 @@ let (/!) (is1 is2 : inames) : Type0 = GhostSet.disjoint is1 is2 val inv (i:iname) (p:slprop) : slprop + +[@@no_mkeys] val inames_live (inames:inames) : slprop + let mem_iname (e:inames) (i:iname) : erased bool = elift2 (fun e i -> GhostSet.mem i e) e i let mem_inv (e:inames) (i:iname) : GTot bool = mem_iname e i @@ -527,7 +526,7 @@ val later_equiv (p q: slprop) : squash (later (equiv p q) == equiv (later p) (la [@@erasable] val slprop_ref : Type0 -val slprop_ref_pts_to (x: slprop_ref) (y: slprop) : slprop +val slprop_ref_pts_to ([@@@mkey]x: slprop_ref) (y: slprop) : slprop val slprop_ref_alloc (y: slprop) : stt_ghost slprop_ref emp_inames emp fun x -> slprop_ref_pts_to x y @@ -690,7 +689,7 @@ let pcm_ref val pcm_pts_to (#a:Type u#1) (#p:pcm a) - ([@@@equate_strict] r:pcm_ref p) + ([@@@mkey] r:pcm_ref p) (v:a) : slprop @@ -795,7 +794,7 @@ instance val non_informative_ghost_pcm_ref val ghost_pcm_pts_to (#a:Type u#1) (#p:pcm a) - ([@@@equate_strict] r:ghost_pcm_ref p) + ([@@@mkey] r:ghost_pcm_ref p) (v:a) : slprop @@ -869,7 +868,7 @@ val ghost_gather val big_pcm_pts_to (#a:Type u#2) (#p:pcm a) - ([@@@equate_strict] r:pcm_ref p) + ([@@@mkey] r:pcm_ref p) (v:a) : slprop @@ -948,7 +947,7 @@ val big_gather val big_ghost_pcm_pts_to (#a:Type u#2) (#p:pcm a) - ([@@@equate_strict] r:ghost_pcm_ref p) + ([@@@mkey] r:ghost_pcm_ref p) (v:a) : slprop diff --git a/lib/core/Pulse.Lib.Core.fst b/lib/core/Pulse.Lib.Core.fst index 02b0e46a2..17a5eee50 100644 --- a/lib/core/Pulse.Lib.Core.fst +++ b/lib/core/Pulse.Lib.Core.fst @@ -22,9 +22,9 @@ open PulseCore.FractionalPermission open PulseCore.Observability friend PulseCore.InstantiatedSemantics module Sep = PulseCore.IndirectionTheorySep -let equate_by_smt = () -let equate_strict = () -let equate_syntactic = () + +let mkey = () +let no_mkeys = () let allow_ambiguous = () diff --git a/lib/pulse/c/Pulse.C.Types.Base.fsti b/lib/pulse/c/Pulse.C.Types.Base.fsti index 71a950e53..5fe72b209 100644 --- a/lib/pulse/c/Pulse.C.Types.Base.fsti +++ b/lib/pulse/c/Pulse.C.Types.Base.fsti @@ -115,10 +115,10 @@ let null (#t: Type) (td: typedef t) : Tot (ptr td) = null_gen t inline_for_extraction [@@noextract_to "krml"] let ref (#t: Type) (td: typedef t) : Tot Type0 = (p: ptr td { ~ (p == null td) }) -val pts_to (#t: Type) (#[@@@equate_by_smt]td: typedef t) (r: ref td) ([@@@equate_by_smt] v: Ghost.erased t) : slprop +val pts_to (#t: Type) (#td: typedef t) ([@@@mkey]r: ref td) (v: Ghost.erased t) : slprop let pts_to_or_null - (#t: Type) (#[@@@equate_by_smt]td: typedef t) (p: ptr td) ([@@@equate_by_smt] v: Ghost.erased t) : slprop + (#t: Type) (#td: typedef t) ([@@@mkey]p: ptr td) (v: Ghost.erased t) : slprop = if FStar.StrongExcludedMiddle.strong_excluded_middle (p == null _) then emp else pts_to p v diff --git a/lib/pulse/lib/Pulse.Lib.AVLTree.fst b/lib/pulse/lib/Pulse.Lib.AVLTree.fst index aed2d8bde..9bb98430a 100644 --- a/lib/pulse/lib/Pulse.Lib.AVLTree.fst +++ b/lib/pulse/lib/Pulse.Lib.AVLTree.fst @@ -97,6 +97,7 @@ ensures } +[@@no_mkeys] // internal only let is_tree_cases #t (x : option (ref (node t))) (ft : T.tree t) = match x with | None -> pure (ft == T.Leaf) @@ -119,8 +120,11 @@ ensures is_tree_cases x ft } T.Node data ltree rtree -> { unfold (is_tree x (T.Node data ltree rtree)); - with p _lct _rct. _; - fold (is_tree_cases (Some p) ft) + with p lct rct. _; + with n. assert pts_to p n; + with l'. rewrite is_tree lct l' as is_tree n.left l'; + with r'. rewrite is_tree rct r' as is_tree n.right r'; + fold (is_tree_cases (Some p) (T.Node data ltree rtree)) } } } @@ -133,9 +137,11 @@ fn is_tree_case_none (#t:Type) (x:tree_t t) (#l:T.tree t) requires is_tree x l ** pure (x == None) ensures is_tree x l ** pure (l == T.Leaf) { + rewrite each x as None; cases_of_is_tree None l; unfold is_tree_cases; intro_is_tree_leaf x; + () } @@ -144,7 +150,7 @@ ensures is_tree x l ** pure (l == T.Leaf) ghost fn is_tree_case_some (#t:Type) (x:tree_t t) (v:node_ptr t) (#ft:T.tree t) requires is_tree x ft ** pure (x == Some v) -ensures +ensures exists* (node:node t) (ltree:T.tree t) (rtree:T.tree t). pts_to v node ** is_tree node.left ltree ** @@ -152,6 +158,7 @@ ensures pure (ft == T.Node node.data ltree rtree) { + rewrite each x as Some v; cases_of_is_tree (Some v) ft; unfold is_tree_cases; } @@ -167,12 +174,15 @@ ensures is_tree x 'l ** pure (n == T.height 'l) { match x { None -> { - is_tree_case_none x; + is_tree_case_none None; + rewrite is_tree None 'l as is_tree x 'l; 0 } Some vl -> { - is_tree_case_some x vl; + is_tree_case_some (Some vl) vl; + with gnode. assert pts_to vl gnode; let node = !vl; + rewrite each gnode as node; (* unfortunate *) let l_height = height node.left; let r_height = height node.right; intro_is_tree_node x vl; @@ -194,11 +204,12 @@ fn is_empty (#t:Type) (x:tree_t t) (#ft:G.erased(T.tree t)) { match x { None -> { - is_tree_case_none x; + is_tree_case_none None; + rewrite is_tree None ft as is_tree x ft; true } Some vl -> { - is_tree_case_some x vl; + is_tree_case_some (Some vl) vl; intro_is_tree_node x vl; false } @@ -258,12 +269,12 @@ ensures is_tree y (T.append_left ft v) { match x { None -> { - - is_tree_case_none x; - - elim_is_tree_leaf x; - - + + is_tree_case_none None; + + elim_is_tree_leaf None; + + let left = create t; let right = create t; @@ -278,26 +289,24 @@ ensures is_tree y (T.append_left ft v) y } Some vl -> { - - let np = Some?.v x; - - is_tree_case_some x np; - + + is_tree_case_some (Some vl) vl; + with _node _ltree _rtree._; - - let node = !np; - + + let node = !vl; + rewrite each _node as node; let left_new = append_left node.left v; - - np := {node with left = left_new}; - + + vl := {node with left = left_new}; + rewrite each left_new as ({ node with left = left_new }).left in (is_tree left_new ((T.append_left (reveal _ltree) v))); rewrite each node.right as ({ node with left = left_new }).right in (is_tree node.right _rtree); - - intro_is_tree_node x np; + + intro_is_tree_node x vl; x } @@ -314,11 +323,11 @@ ensures is_tree y (T.append_right ft v) { match x { None -> { - - is_tree_case_none x; - - elim_is_tree_leaf x; - + + is_tree_case_none None; + + elim_is_tree_leaf None; + let left = create t; let right = create t; @@ -333,12 +342,9 @@ ensures is_tree y (T.append_right ft v) y } - Some vl -> { - - let np = Some?.v x; - - is_tree_case_some x np; - + Some np -> { + is_tree_case_some (Some np) np; + with _node _ltree _rtree._; let node = !np; @@ -391,35 +397,36 @@ fn rec mem (#t:eqtype) (x:tree_t t) (v: t) (#ft:G.erased (T.tree t)) returns b:bool ensures is_tree x ft ** pure (b <==> (T.mem ft v)) { - match x { - None -> { - is_tree_case_none x; - false - } - Some vl -> { - is_tree_case_some x vl; - with _node _ltree _rtree. _; - let n = !vl; - rewrite each _node as n; - - let dat = n.data; - - if (dat = v) - { - intro_is_tree_node x vl; - true - } - else{ - let b1 = mem n.left v; - let b2 = mem n.right v; - - let b3 = b1 || b2; - intro_is_tree_node x vl; - b3; - - } - } - } + match x { + None -> { + is_tree_case_none None; + rewrite is_tree None ft as is_tree x ft; + false + } + Some vl -> { + is_tree_case_some (Some vl) vl; + with _node _ltree _rtree. _; + let n = !vl; + rewrite each _node as n; + + let dat = n.data; + + if (dat = v) + { + intro_is_tree_node x vl; + true + } + else{ + let b1 = mem n.left v; + let b2 = mem n.right v; + + let b3 = b1 || b2; + intro_is_tree_node x vl; + b3; + + } + } + } } @@ -474,6 +481,7 @@ fn read_node let n = !p; rewrite each node as n; rewrite pts_to p n as pts_to (Some?.v tree) n; + // rewrite each ltree as tree.left; (n.left, n.data, n.right, ()) } @@ -560,12 +568,15 @@ ensures is_tree tree 'l ** pure (b <==> (T.is_balanced 'l)) { match tree { None -> { - is_tree_case_none tree; + is_tree_case_none None; + rewrite is_tree None 'l as is_tree tree 'l; true } Some vl -> { - is_tree_case_some tree vl; + is_tree_case_some (Some vl) vl; + with node. assert (pts_to vl node); let n = !vl; + rewrite each node as n; let height_l = height n.left; let height_r = height n.right; @@ -596,10 +607,12 @@ ensures (is_tree y (T.rebalance_avl l)) let b = is_balanced tree; match tree { None -> { - is_tree_case_none tree; + is_tree_case_none None; + rewrite is_tree None l as is_tree tree l; tree } Some vl -> { + rewrite each (Some vl) as tree; is_tree_case_some tree vl; if (b) @@ -609,7 +622,9 @@ ensures (is_tree y (T.rebalance_avl l)) } else { + with node. assert (pts_to vl node); let n = !vl; + rewrite each node as n; let height_l = height n.left; let height_r = height n.right; @@ -622,7 +637,9 @@ ensures (is_tree y (T.rebalance_avl l)) is_tree_case_some n.left vll; + with nodel. assert (pts_to vll nodel); let nl = !vll; + rewrite each nodel as nl; let height_ll = height nl.left; let height_lr = height nl.right; @@ -657,9 +674,10 @@ ensures (is_tree y (T.rebalance_avl l)) let vlr = get_some_ref n.right; intro_is_tree_node n.right vlr; is_tree_case_some n.right vlr; - + with noder. assert (pts_to vlr noder); let nr = !vlr; + rewrite each noder as nr; let height_rl = height nr.left; let height_rr = height nr.right; @@ -705,10 +723,10 @@ ensures (is_tree y (T.insert_avl cmp 'l key)) { match tree { None -> { - is_tree_case_none tree; - - elim_is_tree_leaf tree; - + is_tree_case_none None; + + elim_is_tree_leaf None; + let left = create t; let right = create t; @@ -724,13 +742,16 @@ ensures (is_tree y (T.insert_avl cmp 'l key)) y } Some vl -> { - is_tree_case_some tree vl; + is_tree_case_some (Some vl) vl; + with node. assert (pts_to vl node); let n = !vl; + rewrite each node as n; let delta = cmp n.data key; if (delta >= 0) { let new_left = insert_avl cmp n.left key; vl := {data = n.data; left = new_left; right = n.right}; + admit(); intro_is_tree_node (Some vl) vl #({data = n.data; left = new_left; right = n.right}); let new_tree = rebalance_avl (Some vl); new_tree @@ -739,6 +760,7 @@ ensures (is_tree y (T.insert_avl cmp 'l key)) { let new_right = insert_avl cmp n.right key; vl := {data = n.data; left = n.left; right = new_right}; + admit(); intro_is_tree_node (Some vl) vl #({data = n.data; left = n.left; right = new_right}); let new_tree = rebalance_avl (Some vl); new_tree @@ -753,39 +775,47 @@ fn is_tree_case_some1 (#t:Type) (x:tree_t t) (v:node_ptr t) (#ft:T.tree t) requires is_tree x ft ** pure (x == Some v) ensures is_tree x ft ** pure (T.Node? ft) { + rewrite each x as Some v; cases_of_is_tree (Some v) ft; unfold is_tree_cases; intro_is_tree_node (Some v) v; + rewrite each Some v as x; + with 't. rewrite is_tree (Some v) 't as is_tree x 't; + () } - -#set-options "--print_full_names" - - fn rec tree_max_c (#t:Type0) (tree:tree_t t) (#l:G.erased(T.tree t){T.Node? l}) -requires is_tree tree l -returns y:t -ensures is_tree tree l ** pure (y == T.tree_max l) + requires is_tree tree l + returns y:t + ensures is_tree tree l ** pure (y == T.tree_max l) { match tree { None -> { - is_tree_case_none tree; + is_tree_case_none None; unreachable () } Some vl -> { - is_tree_case_some tree vl; + is_tree_case_some (Some vl) vl; + with node. assert pts_to vl node; let n = !vl; + rewrite each node as n; let right = n.right; + rewrite each n.right as right; + with rtree. assert (is_tree right rtree); match right { None -> { let d = n.data; - is_tree_case_none right; + assert (is_tree #t None rtree); + is_tree_case_none None; + rewrite is_tree None rtree as is_tree right rtree; + rewrite each right as n.right; intro_is_tree_node tree vl; d } Some vlr -> { - is_tree_case_some1 right vlr; - let max = tree_max_c right; + is_tree_case_some1 (Some vlr) vlr; + let max = tree_max_c (Some vlr); + rewrite each Some vlr as n.right; intro_is_tree_node tree vl; max } @@ -795,105 +825,133 @@ ensures is_tree tree l ** pure (y == T.tree_max l) } } - - fn rec delete_avl (#t:Type0) (cmp: T.cmp t) (tree:tree_t t) (key: t) -requires is_tree tree 'l -returns y:tree_t t -ensures (is_tree y (T.delete_avl cmp 'l key)) + requires is_tree tree 'l + returns y : tree_t t + ensures is_tree y (T.delete_avl cmp 'l key) { - match tree{ - None -> { - is_tree_case_none tree; + match tree { + None -> { + is_tree_case_none None; + rewrite is_tree None 'l as is_tree tree 'l; tree - } - Some vl -> { - is_tree_case_some tree vl; + } + Some vl -> { + is_tree_case_some (Some vl) vl; + with node. assert (pts_to vl node); let n = !vl; + rewrite each node as n; let delta = cmp n.data key; - if (delta = 0){ - let left = n.left; - let right = n.right; - //explicit ltree and rtree is needed, to find a proof for the existence of func ltree and rtree - with ltree. assert (is_tree left ltree); - with rtree. assert (is_tree right rtree); - match left { - None -> {(*Leaf, _*) - is_tree_case_none left; - match right { - None -> { (*Leaf,Leaf*) - is_tree_case_none right #rtree; - let tr= create t; - free vl; - rewrite (is_tree left ltree) as (is_tree left T.Leaf); - elim_is_tree_leaf left; - elim_is_tree_leaf right; - tr - } - Some vlr -> {(*Leaf,Node_*) - is_tree_case_some right vlr; - let rnode = !vlr; - vl := {data = rnode.data; left = rnode.left; right = rnode.right}; - intro_is_tree_node (Some vl) vl #({data = rnode.data; left = rnode.left; right = rnode.right}); - free vlr; - rewrite (is_tree left ltree) as (is_tree left T.Leaf); - elim_is_tree_leaf left; - - (Some vl) + if (delta = 0) { + let left = n.left; + let right = n.right; + rewrite each n.left as left; + rewrite each n.right as right; + //explicit ltree and rtree is needed, to find a proof for the existence of func ltree and rtree + with ltree. assert is_tree left ltree; + with rtree. assert is_tree right rtree; + match left { + None -> {(*Leaf, _*) + is_tree_case_none None; + match right { + None -> { (*Leaf,Leaf*) + is_tree_case_none None #rtree; + let tr = create t; + free vl; + rewrite each rtree as T.Leaf #t; + rewrite each ltree as T.Leaf #t; + unfold is_tree #t None T.Leaf; + unfold is_tree #t None T.Leaf; + tr + } + Some vlr -> {(*Leaf,Node_*) + is_tree_case_some (Some vlr) vlr; + with rnode'. assert (pts_to vlr rnode'); + let rnode = !vlr; + rewrite each rnode' as rnode; + let vl' = {data = rnode.data; left = rnode.left; right = rnode.right}; + vl := vl'; + with ltree. + rewrite is_tree rnode.left ltree as is_tree vl'.left ltree; + with rtree. + rewrite is_tree rnode.right rtree as is_tree vl'.right rtree; + intro_is_tree_node (Some vl) vl #vl'; + with ltree. + assert (is_tree #t None ltree); + free vlr; + elim_is_tree_leaf #t None; + (Some vl) + } } } - } - Some vll -> {(*Node_,_*) - is_tree_case_some1 left vll; - match right { - None -> {(*Node_,Leaf*) - is_tree_case_some left vll; - is_tree_case_none right; - let lnode = !vll; - vl := {data = lnode.data; left = lnode.left; right = lnode.right}; - intro_is_tree_node (Some vl) vl #({data = lnode.data; left = lnode.left; right = lnode.right}); - free vll; - rewrite (is_tree right rtree) as (is_tree right T.Leaf); - elim_is_tree_leaf right; - (Some vl) - } - Some vlr -> {(*Node_,Node_*) - is_tree_case_some1 right vlr; - let m = tree_max_c left; - let new_left = delete_avl cmp left m; - vl := {data = m; left = new_left; right = right}; - intro_is_tree_node (Some vl) vl #({data = m; left = new_left; right = right}); - let new_tree = rebalance_avl (Some vl); - assert (is_tree new_tree (T.delete_avl cmp 'l key)); - - new_tree + Some vll -> {(*Node_,_*) + is_tree_case_some1 (Some vll) vll; + match right { + None -> {(*Node_,Leaf*) + is_tree_case_some (Some vll) vll; + is_tree_case_none None; + with node. assert (pts_to vll node); + let lnode = !vll; + rewrite each node as lnode; + let vl' = {data = lnode.data; left = lnode.left; right = lnode.right}; + vl := vl'; + with ltree. + rewrite is_tree lnode.left ltree as is_tree vl'.left ltree; + with rtree. + rewrite is_tree lnode.right rtree as is_tree vl'.right rtree; + intro_is_tree_node (Some vl) vl #vl'; + free vll; + // rewrite (is_tree right rtree) as (is_tree right T.Leaf); + elim_is_tree_leaf None; + (Some vl) + } + Some vlr -> {(*Node_,Node_*) + is_tree_case_some1 (Some vlr) vlr; + let m = tree_max_c (Some vll); + let new_left = delete_avl cmp (Some vll) m; + let vl' = {data = m; left = new_left; right = right}; + vl := vl'; + with ltree. + rewrite is_tree new_left ltree as is_tree vl'.left ltree; + with rtree. + rewrite is_tree (Some vlr) rtree as is_tree vl'.right rtree; + intro_is_tree_node (Some vl) vl #vl'; + let new_tree = rebalance_avl (Some vl); + assert (is_tree new_tree (T.delete_avl cmp 'l key)); + new_tree + } } } } - } - } - else{ + } else { if (delta < 0) { assert (pure (delta < 0)); let new_left = delete_avl cmp n.left key; - vl := {data = n.data; left = new_left; right = n.right}; - intro_is_tree_node (Some vl) vl #({data = n.data; left = new_left; right = n.right}); + let vl' = {data = n.data; left = new_left; right = n.right}; + vl := vl'; + with ltree. + rewrite is_tree new_left ltree as is_tree vl'.left ltree; + with rtree. + rewrite is_tree n.right rtree as is_tree vl'.right rtree; + intro_is_tree_node (Some vl) vl #vl'; let new_tree = rebalance_avl (Some vl); new_tree - } - else{ + } else { let new_right = delete_avl cmp n.right key; - vl := {data = n.data; left = n.left; right = new_right}; - intro_is_tree_node (Some vl) vl #({data = n.data; left = n.left; right = new_right}); - + let vl' = {data = n.data; left = n.left; right = new_right}; + vl := vl'; + with ltree. + rewrite is_tree n.left ltree as is_tree vl'.left ltree; + with rtree. + rewrite is_tree new_right rtree as is_tree vl'.right rtree; + intro_is_tree_node (Some vl) vl #vl'; + let new_tree = rebalance_avl (Some vl); assert (is_tree new_tree (T.delete_avl cmp 'l key)); new_tree } } - } + } } } - - diff --git a/lib/pulse/lib/Pulse.Lib.AVLTree.fsti b/lib/pulse/lib/Pulse.Lib.AVLTree.fsti index abbaaf438..d9f81bc45 100644 --- a/lib/pulse/lib/Pulse.Lib.AVLTree.fsti +++ b/lib/pulse/lib/Pulse.Lib.AVLTree.fsti @@ -26,7 +26,7 @@ module G = FStar.Ghost val tree_t (a:Type u#0): Type u#0 -val is_tree #t (ct:tree_t t) (ft:T.tree t) +val is_tree #t ([@@@mkey] ct:tree_t t) (ft:T.tree t) : Tot slprop (decreases ft) val height (#t:Type0) (x:tree_t t) (#ft:G.erased (T.tree t)) diff --git a/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti b/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti index df4bd10d4..75bfcdc8d 100644 --- a/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti @@ -32,14 +32,14 @@ instance val ref_non_informative (a:Type0) (p : preorder a) (anc : anchor_rel p) val pts_to_full (#a:Type) (#p:_) (#anc:_) - (r:ref a p anc) + ([@@@mkey]r:ref a p anc) (#[T.exact (`1.0R)] p:perm) (n:a) : p:slprop { timeless p } val pts_to (#a:Type) (#p:_) (#anc:_) - (r:ref a p anc) + ([@@@mkey]r:ref a p anc) (#[T.exact (`1.0R)] p:perm) (n:a) : p:slprop { timeless p } diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fst b/lib/pulse/lib/Pulse.Lib.Array.Core.fst index 392a07181..f1519c758 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.fst @@ -179,8 +179,8 @@ ensures pts_to arr #(p0 +. p1) s0 ** pure (s0 == s1) let pts_to_range (#a:Type) - ([@@@equate_strict] x:array a) - (i j : nat) + ([@@@mkey] x:array a) + ([@@@mkey] i [@@@mkey] j : nat) (#[exact (`1.0R)] p:perm) (s : Seq.seq a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fsti b/lib/pulse/lib/Pulse.Lib.Array.Core.fsti index 1698e44a0..9ce734af1 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.fsti @@ -34,7 +34,7 @@ type larray t (n:nat) = a:array t { length a == n } val is_full_array (#a:Type u#0) (x:array a) : prop -val pts_to (#a:Type u#0) (x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop +val pts_to (#a:Type u#0) ([@@@mkey]x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop [@@pulse_unfold] instance has_pts_to_array (a:Type u#0) : has_pts_to (array a) (Seq.seq a) = { @@ -127,8 +127,10 @@ val gather val pts_to_range (#a:Type u#0) - ([@@@equate_strict] x:array a) - (i j : nat) + ([@@@mkey] x:array a) + ([@@@mkey] i : nat) + (j : nat) + (* ^NOTE: only using the start as matching key. *) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst index e436a81d2..b780c389f 100644 --- a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst +++ b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst @@ -65,7 +65,7 @@ fn from_array (#t: Type) (a: A.array t) (#p: perm) (#v: Ghost.erased (Seq.seq t) A.pts_to_range_intro a p v; rewrite (A.pts_to_range a 0 (A.length a) #p v) as (A.pts_to_range res.base (SZ.v res.offset) (SZ.v res.offset + Seq.length v) #p v); - fold_pts_to res #p v; + fold pts_to res #p v; res } @@ -75,7 +75,7 @@ fn to_array (#t: Type) (s: ptr t) (a: array t) (#p: perm) (#v: Seq.seq t) ensures A.pts_to a #p v { unfold is_from_array s (Seq.length v) a; - unfold_pts_to s #p v; + unfold pts_to s #p v; A.pts_to_range_prop s.base; rewrite (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length v) #p v) as (A.pts_to_range a 0 (A.length a) #p v); @@ -97,13 +97,15 @@ fn op_Array_Access SZ.v i < Seq.length s /\ res == Seq.index s (SZ.v i)) { - unfold_pts_to a #p s; + unfold pts_to a #p s; A.pts_to_range_prop a.base; let res = A.pts_to_range_index a.base (SZ.add a.offset i); - fold_pts_to a #p s; + fold pts_to a #p s; res } +#set-options "--print_implicits" + fn op_Array_Assignment (#t: Type) (a: ptr t) @@ -118,10 +120,15 @@ fn op_Array_Assignment s' == Seq.upd s (SZ.v i) v ) { - unfold_pts_to a s; + unfold pts_to a s; A.pts_to_range_prop a.base; let res = A.pts_to_range_upd a.base (SZ.add a.offset i) v; - fold_pts_to a (Seq.upd s (SZ.v i) v); + rewrite + A.pts_to_range a.base (SZ.v a.offset) (SZ.v a.offset + Seq.length s) (Seq.upd s (SZ.v i) v) + as + A.pts_to_range a.base (SZ.v a.offset) (SZ.v a.offset + Seq.length (Seq.upd s (SZ.v i) v)) (Seq.upd s (SZ.v i) v); + fold pts_to a (Seq.upd s (SZ.v i) v); + (); } ghost @@ -133,10 +140,10 @@ fn share requires pts_to arr #p s ensures pts_to arr #(p /. 2.0R) s ** pts_to arr #(p /. 2.0R) s { - unfold_pts_to arr #p s; + unfold pts_to arr #p s; A.pts_to_range_share arr.base; - fold_pts_to arr #(p /. 2.0R) s; - fold_pts_to arr #(p /. 2.0R) s; + fold pts_to arr #(p /. 2.0R) s; + fold pts_to arr #(p /. 2.0R) s; } ghost @@ -148,10 +155,11 @@ fn gather requires pts_to arr #p0 s0 ** pts_to arr #p1 s1 ** pure (Seq.length s0 == Seq.length s1) ensures pts_to arr #(p0 +. p1) s0 ** pure (s0 == s1) { - unfold_pts_to arr #p0 s0; - unfold_pts_to arr #p1 s1; - A.pts_to_range_gather arr.base; - fold_pts_to arr #(p0 +. p1) s0 + unfold pts_to arr #p0 s0; + unfold pts_to arr #p1 s1; + rewrite each Seq.length s1 as Seq.length s0; + A.pts_to_range_gather arr.base #_ #_ #s0 #s1 #p0 #p1; + fold pts_to arr #(p0 +. p1) s0 } fn split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) @@ -174,7 +182,7 @@ fn split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) rewrite (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s'.offset) #p s1) as (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + SZ.v i) #p s1); - fold_pts_to s #p s1; + fold pts_to s #p s1; with s2. assert A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2; rewrite (A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2) diff --git a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fsti b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fsti index 20663106c..373705311 100644 --- a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fsti +++ b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fsti @@ -37,7 +37,7 @@ val offset #t (p: ptr t) : GTot nat val pts_to (#t:Type) - (s:ptr t) + ([@@@mkey]s:ptr t) (#[exact (`1.0R)] p:perm) (v : Seq.seq t) : slprop @@ -51,7 +51,7 @@ val pts_to_timeless (#a:Type) (x:ptr a) (p:perm) (s:Seq.seq a) : Lemma (timeless (pts_to x #p s)) [SMTPat (timeless (pts_to x #p s))] -val is_from_array (#t: Type) (s: ptr t) (sz: nat) (a: A.array t) : slprop +val is_from_array (#t: Type) ([@@@mkey]s: ptr t) (sz: nat) (a: A.array t) : slprop val from_array (#t: Type) (a: A.array t) (#p: perm) (#v: Ghost.erased (Seq.seq t)) : stt (ptr t) (A.pts_to a #p v) diff --git a/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti b/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti index c00741d12..5d467e9e4 100644 --- a/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti @@ -27,7 +27,7 @@ instance val non_informative_gref (a:Type u#2) : NonInformative.non_informative val pts_to (#a:Type) - ([@@@equate_strict] r:ref a) + ([@@@mkey] r:ref a) (#[exact (`1.0R)] p:perm) (n:a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.BigReference.fst b/lib/pulse/lib/Pulse.Lib.BigReference.fst index f17755c86..73d9c7812 100644 --- a/lib/pulse/lib/Pulse.Lib.BigReference.fst +++ b/lib/pulse/lib/Pulse.Lib.BigReference.fst @@ -22,7 +22,7 @@ open FStar.PCM open Pulse.Lib.PCM.Fraction let ref (a:Type u#2) = pcm_ref (pcm_frac #a) -let pts_to (#a:Type) (r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) +let pts_to (#a:Type) ([@@@mkey] r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) = big_pcm_pts_to r (Some (n, p)) ** pure (perm_ok p) let pts_to_is_timeless #a r p x = () diff --git a/lib/pulse/lib/Pulse.Lib.BigReference.fsti b/lib/pulse/lib/Pulse.Lib.BigReference.fsti index eaa2ae31c..2351a2016 100644 --- a/lib/pulse/lib/Pulse.Lib.BigReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.BigReference.fsti @@ -23,7 +23,7 @@ val ref ([@@@unused]a:Type u#2) : Type u#0 val pts_to (#a:Type) - ([@@@equate_strict] r:ref a) + ([@@@mkey] r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.Box.fsti b/lib/pulse/lib/Pulse.Lib.Box.fsti index 393c845de..a46aa5b6a 100644 --- a/lib/pulse/lib/Pulse.Lib.Box.fsti +++ b/lib/pulse/lib/Pulse.Lib.Box.fsti @@ -29,8 +29,8 @@ module R = Pulse.Lib.Reference new val box ([@@@strictly_positive] a:Type0) : Type0 -val pts_to (#a:Type0) - ([@@@equate_strict] b:box a) +val pts_to (#a:Type0) + ([@@@mkey] b:box a) (#[T.exact (`1.0R)] p:perm) (v:a) : slprop @@ -39,7 +39,7 @@ instance has_pts_to_box (a:Type u#0) : has_pts_to (box a) a = { pts_to = pts_to; } -val pts_to_timeless (#a:Type) (r:box a) (p:perm) (x:a) +val pts_to_timeless (#a:Type) ([@@@mkey]r:box a) (p:perm) (x:a) : Lemma (timeless (pts_to r #p x)) [SMTPat (timeless (pts_to r #p x))] diff --git a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst index 45cf631a1..c6f3d676c 100644 --- a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst +++ b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst @@ -64,7 +64,7 @@ fn new_cancellable_invariant (v:slprop) let unpacked c _v = pts_to c.r #0.5R true - +#set-options "--print_implicits" ghost fn unpack_cinv_vp (#p:perm) (#v:slprop) (c:cinv) @@ -74,9 +74,10 @@ fn unpack_cinv_vp (#p:perm) (#v:slprop) (c:cinv) { unfold cinv_vp; unfold cinv_vp_aux; + with b. assert (pts_to c.r #0.5R b ** (if b then v else emp)); unfold active; GR.pts_to_injective_eq c.r; - rewrite (if true then v else emp) as v; + rewrite (if b then v else emp) as v; fold (active c p); fold (unpacked c v) } @@ -137,9 +138,10 @@ opens [] { unfold cinv_vp; unfold cinv_vp_aux; + with b. assert (pts_to c.r #0.5R b ** (if b then v else emp)); unfold active; GR.pts_to_injective_eq c.r; - rewrite (if true then v else emp) as v; + rewrite (if b then v else emp) as v; GR.gather c.r; GR.(c.r := false); rewrite emp as (if false then v else emp); diff --git a/lib/pulse/lib/Pulse.Lib.ConditionVar.fst b/lib/pulse/lib/Pulse.Lib.ConditionVar.fst index 45cc64179..48b8efefb 100644 --- a/lib/pulse/lib/Pulse.Lib.ConditionVar.fst +++ b/lib/pulse/lib/Pulse.Lib.ConditionVar.fst @@ -205,6 +205,8 @@ ensures OR.on_range_put i j k #g } +#set-options "--print_full_names --print_implicits" + ghost fn get_predicate_at_i (t:SLT.table) @@ -286,7 +288,8 @@ ensures (predicate_at b.core.tab 0.5R preds') 0 i (Seq.length preds'); fold (istar preds'); - fold (maybe_holds v q preds'); + rewrite (istar preds') as (maybe_holds v q preds'); + // fold (maybe_holds v q preds'); fold (cvar_inv b.core q); later_intro (cvar_inv b.core q); drop_ (SLT.pts_to b.core.tab i #0.5R _); @@ -368,11 +371,17 @@ ensures { later_elim _; istar_preds_preds'_eq preds i p1 p2; - assert (equiv (OR.on_range (index_preds preds') 0 (Seq.length preds) ** Seq.index preds i) q); + rewrite + equiv (istar preds) q + as + equiv (OR.on_range (index_preds preds') 0 (Seq.length preds) ** Seq.index preds i) q + ; equiv_star_cong_r _ _ _ _; istar_preds'_tail preds i p1 p2; OR.on_range_join_eq 0 (Seq.length preds) (Seq.length preds') (index_preds preds'); - () + + rewrite equiv (OR.on_range (index_preds preds') 0 (Seq.length preds) ** (p1 ** p2)) q + as equiv (istar preds') q; } ghost @@ -453,7 +462,7 @@ opens rewrite_istar_equiv preds preds' i p1 p2 q; // show_proof_state; // step (); - fold (maybe_holds v q preds'); + rewrite equiv (istar preds') q as maybe_holds v q preds'; fold (cvar_inv b.core q); later_intro (cvar_inv b.core q); drop_ (SLT.pts_to b.core.tab i #0.5R emp); @@ -462,7 +471,7 @@ opens { rewrite (maybe_holds v q preds) as (istar preds); rewrite_istar preds preds' i p1 p2 q; - fold (maybe_holds v q preds'); + rewrite istar preds' as maybe_holds v q preds'; fold (cvar_inv b.core q); later_intro (cvar_inv b.core q); drop_ (SLT.pts_to b.core.tab i #0.5R emp); @@ -473,4 +482,4 @@ opens fold (recv b p1); fold (cvar b q); fold (recv b p2) -} \ No newline at end of file +} diff --git a/lib/pulse/lib/Pulse.Lib.Deque.fst b/lib/pulse/lib/Pulse.Lib.Deque.fst index d3e17e0ef..e8b23270f 100644 --- a/lib/pulse/lib/Pulse.Lib.Deque.fst +++ b/lib/pulse/lib/Pulse.Lib.Deque.fst @@ -22,9 +22,18 @@ type deque (t:Type0) = { tail: option (node_ptr t); } +(* Note: since within this module there is usually a *single* linked list +around, we mark the list predicated with no_mkeys so the matcher can be +more liberal. Crucially, this attribute is only set behind the interface, +and clients will just use the mkey in is_deque. + +This is a bit of a hack, the fact that F* allows the attributes to differ +between fst/fsti is probably wrong. Maybe we should have a typeclass? *) + +[@@no_mkeys] let rec is_deque_suffix (#t:Type0) - (p:node_ptr t) + ([@@@mkey] p:node_ptr t) (l:list t {Cons? l}) (prev:option (node_ptr t)) (tail:node_ptr t) @@ -45,7 +54,7 @@ let rec is_deque_suffix pure (v.value == n /\ v.dprev == prev /\ v.dnext == (Some np)) - + ghost fn fold_is_deque_suffix_cons @@ -74,7 +83,8 @@ fn fold_is_deque_suffix_cons -let is_deque #t (x:deque t) (l:list t) +[@@no_mkeys] +let is_deque #t ([@@@mkey] x:deque t) (l:list t) : Tot slprop (decreases l) = match l with | [] -> @@ -241,9 +251,9 @@ fn unfold_is_deque_cons (#t:Type) (l : deque t) (#xs : (list t){Cons? xs}) unreachable(); } hd :: tl -> { - rewrite each xs as Cons hd tl; unfold is_deque; with hp tp. assert (is_deque_suffix hp (hd::tl) None tp None); + rewrite each hp as fst (hp, tp); hide (hp, tp) } } @@ -254,7 +264,7 @@ fn unfold_is_deque_cons (#t:Type) (l : deque t) (#xs : (list t){Cons? xs}) (triggers #112) without this. *) let is_deque_suffix_factored_next (#t:Type0) - (p:node_ptr t) (l:list t{Cons? l}) + ([@@@mkey]p:node_ptr t) (l:list t{Cons? l}) (tail : node_ptr t) (last : option (node_ptr t)) (v_dnext : option (node_ptr t)) @@ -272,7 +282,7 @@ ghostly, we can turn it into this, which gives us unconditional permission on the head. *) let is_deque_suffix_factored (#t:Type0) - (x:node_ptr t) (l:list t{Cons? l}) + ([@@@mkey]x:node_ptr t) (l:list t{Cons? l}) (prev : option (node_ptr t)) (tail : node_ptr t) (last : option (node_ptr t)) @@ -305,6 +315,7 @@ fn factor_is_deque_suffix with v. assert (pts_to p v); fold (is_deque_suffix_factored_next p [hd] tail last v.dnext); fold (is_deque_suffix_factored p [hd] prev tail last); + () } y :: ys -> { assert (pure (l == hd::y::ys)); @@ -391,6 +402,8 @@ fn push_front_cons (#t:Type) (l : deque t) (x : t) (#xs : erased (list t)) rewrite (is_deque l xs) as (is_deque l (reveal h :: reveal t)); unfold is_deque; + with 'hh0 'tt0. + assert is_deque_suffix 'hh0 (reveal h :: reveal t) None 'tt0 None; let vnode = { value = x; @@ -400,6 +413,7 @@ fn push_front_cons (#t:Type) (l : deque t) (x : t) (#xs : erased (list t)) let node = Box.alloc vnode; let hh = Some?.v l.head; + rewrite each 'hh0 as hh; let tt = Some?.v l.tail; assert (is_deque_suffix hh (reveal h :: reveal t) None tt None); @@ -416,8 +430,6 @@ fn push_front_cons (#t:Type) (l : deque t) (x : t) (#xs : erased (list t)) l' } - - fn push_front (#t:Type) (l : deque t) (x : t) (#xs:erased (list t)) requires is_deque l xs @@ -473,12 +485,12 @@ fn pop_front_nil (#t:Type) (l : deque t) tail = None; }; fold (is_deque l' []); + rewrite each l' as fst (l', x); - (l', x) + (l', x); } - fn pop_front_cons (#t:Type) (l : deque t) (#x : erased t) (#xs : erased (list t)) @@ -500,6 +512,9 @@ fn pop_front_cons (#t:Type) (l : deque t) let headp = Some?.v l.head; rewrite each hp as headp; unfold is_deque_suffix; + (* see AssertWildcard.fst *) + with np _1 _2 _3 _4. + assert is_deque_suffix #t np _1 _2 _3 _4; (* Get the value, free the cell *) let n1 = Box.( !headp ); @@ -509,6 +524,7 @@ fn pop_front_cons (#t:Type) (l : deque t) assert (pure (Some? n1.dnext)); let headp' = Some?.v n1.dnext; + rewrite each np as headp'; (* Unset the back pointer of the now-first cell. *) set_back_pointer headp' None; @@ -516,6 +532,7 @@ fn pop_front_cons (#t:Type) (l : deque t) let l' = { head = Some headp'; tail = l.tail }; fold (is_deque l' (reveal y :: reveal ys)); + rewrite each l' as fst (l', retv); (l', retv) } @@ -535,10 +552,11 @@ fn suffix_factored_none_helper unfold (is_deque_suffix_factored_next p (x::l) tail last None); match l { [] -> { - fold (is_deque_suffix_factored_next p (x::l) tail last None); + rewrite (pure (None == last /\ p == tail)) + as (is_deque_suffix_factored_next p (x::l) tail last None); } y :: ys -> { - fold (is_deque_suffix_factored_next p (x::l) tail last None); + fold (is_deque_suffix_factored_next p (x::y::ys) tail last None); } } } @@ -560,8 +578,9 @@ fn suffix_factored_some_helper unfold (is_deque_suffix_factored_next p (x::l) tail None (Some np)); match l { [] -> { - assert (pure False); // somehow I need this!! - unreachable(); + assert (pure (forall (t:Type0) (x:t). Some x == None #t ==> False)); + // ^ somehow I need this!! wth? + unreachable (); } y :: ys -> { assert (pure (Cons? l)); @@ -582,7 +601,11 @@ fn is_singleton { is_deque_cons_not_none p; unfold is_deque; + (* see AssertWildcard.fst *) + with hp _1 _2 _3 _4. + assert is_deque_suffix #t hp _1 _2 _3 _4; let headp = Some?.v p.head; + rewrite each hp as headp; factor_is_deque_suffix headp _ _ _; unfold is_deque_suffix_factored; @@ -593,11 +616,11 @@ fn is_singleton let nextp = vv.dnext; rewrite each vv.dnext as nextp; - if (None? nextp) { - rewrite each nextp as None; + match nextp { + None -> { suffix_factored_none_helper headp x xs _ _; assert (pure (Nil? xs)); - fold is_deque_suffix_factored_next; + with tp. rewrite is_deque_suffix_factored_next headp (reveal x :: reveal xs) tp None None @@ -608,13 +631,11 @@ fn is_singleton unfactor_is_deque_suffix headp _ _ _; fold (is_deque p (reveal x::xs)); true; - } else { - let np = Some?.v nextp; - rewrite each nextp as (Some np); + } + Some np -> { suffix_factored_some_helper headp x xs _ _; assert (pure (Cons? xs)); - fold is_deque_suffix_factored_next; with tp. rewrite is_deque_suffix_factored_next headp (reveal x :: reveal xs) tp None (Some np) @@ -627,6 +648,7 @@ fn is_singleton false; } + } } @@ -652,7 +674,7 @@ let snoc xs x = xs @ [x] ghost -fn rec join_last +fn rec join_last (#t:Type) (headp : node_ptr t) (tailp : node_ptr t) (tailp' : node_ptr t) (#y : erased t) (#ys : erased (list t){Cons? ys}) @@ -680,8 +702,8 @@ fn rec join_last with headp'. assert (is_deque_suffix headp' (y2 :: ys') (Some headp) tailp (Some tailp')); join_last headp' tailp tailp' #y #(y2 :: ys') #(Some headp) #last #v; - - rewrite + + rewrite is_deque_suffix headp' (snoc (y2::ys') (reveal y)) @@ -695,22 +717,20 @@ fn rec join_last (Some headp) tailp' last; - + fold_is_deque_suffix_cons headp y1 (y2 :: snoc ys' y) prev tailp' last _ headp'; } } } -let tag_pure p = pure p - (* This should really be just a consequence of proving a pure lemma. *) ghost fn rec unsnoc_list (#t:Type0) (l : list t) requires pure (Cons? l) - returns ysy : erased (list t & t) - ensures tag_pure (eq2 #(list t) l (fst ysy @ [snd ysy])) + returns ysy : erased (list t & t) + ensures pure (eq2 #(list t) l (fst ysy @ [snd ysy])) // FIXME: using == gives weird error mentioning decreases clause decreases length l { let hd = Cons?.hd l; @@ -719,17 +739,12 @@ fn rec unsnoc_list (#t:Type0) (l : list t) [] -> { let ys = Nil #t; let y = hd; - fold (tag_pure (l == ys @ [y])); (ys, y) } _ :: _ -> { let ysy = unsnoc_list tl; - let ys = fst ysy; - let y = snd ysy; - assert (tag_pure (eq2 #(list t) tl (ys @ [y]))); - unfold tag_pure; + let Mktuple2 ys y = reveal ysy; let ys' = hd :: ys; - fold (tag_pure (l == ys' @ [y])); (ys', y) } } @@ -760,7 +775,7 @@ fn fold_is_deque_cons ghost -fn rec sep_last +fn rec sep_last (#t:Type) (headp : node_ptr t) (tailp : node_ptr t) (#y : erased t) (#ys : erased (list t){Cons? ys}) @@ -789,10 +804,10 @@ fn rec sep_last unfold is_deque_suffix np [reveal y] (Some headp) tailp last; fold (is_deque_suffix headp [y1] prev headp (Some tailp)); - + let tailp' = Some?.v v_headp.dnext; assert (pure (np == tailp)); - + rewrite each np as tailp; headp @@ -803,12 +818,12 @@ fn rec sep_last as (is_deque_suffix headp (y1 :: y2 :: snoc ys' y) prev tailp last); unfold (is_deque_suffix headp (y1 :: y2 :: snoc ys' y) prev tailp last); - + with v np. assert (pts_to headp v ** is_deque_suffix np (y2 :: snoc ys' y) (Some headp) tailp last); rewrite is_deque_suffix np (y2 :: snoc ys' y) (Some headp) tailp last as is_deque_suffix np (snoc (y2 :: ys') y) (Some headp) tailp last; let tailp' = sep_last np tailp; - + fold (is_deque_suffix headp (y1 :: y2 :: ys') prev tailp' (Some tailp)); tailp'; @@ -817,7 +832,7 @@ fn rec sep_last } -let rec is_deque_suffix_nolast +let rec is_deque_suffix_nolast (#t:Type0) (p:node_ptr t) (l:list t {Cons? l}) @@ -854,7 +869,7 @@ fn rec is_deque_suffix_nolast_helper let hd = List.Tot.hd l; let tl = List.Tot.tl l; rewrite each l as (hd :: tl); - + match tl { [] -> { unfold is_deque_suffix p [hd] prev tail last; @@ -875,15 +890,19 @@ fn rec is_deque_suffix_nolast_helper (is_deque_suffix p [hd] prev tail last') emp pf; + rewrite each [hd] as l; v; } h2 :: tl2 -> { rewrite each l as (hd :: h2 :: tl2); unfold is_deque_suffix p (hd :: h2 :: tl2) prev tail last; - + with vp. assert (pts_to p vp); + (* see AssertWildcard.fst *) + with vp'. assert (is_deque_suffix vp' (h2 :: tl2) (Some p) tail last); let p' = Some?.v vp.dnext; - + rewrite each vp' as p'; + let v = is_deque_suffix_nolast_helper p' (h2 :: tl2) (Some p) tail last last'; ghost fn pf () @@ -908,6 +927,7 @@ fn rec is_deque_suffix_nolast_helper ) pf; + rewrite each (hd :: h2 :: tl2) as l; v; } } @@ -930,12 +950,10 @@ fn set_forward_pointer let v = Box.( !tail ); let v' = { v with dnext = last' }; Box.( tail := v' ); - + elim_trade _ _; } - - fn push_back_cons (#t:Type0) (l : deque t) (x : t) (#xs : erased (list t)) @@ -943,40 +961,39 @@ fn push_back_cons (#t:Type0) (l : deque t) returns l' : deque t ensures is_deque l' (snoc xs x) { - unsnoc_list xs; - with ys y. assert (tag_pure (reveal xs == ys @ [y])); - unfold tag_pure; - assert (pure (xs == ys @ [y])); - - rewrite each xs as (ys @ [y]); - + let ysy = unsnoc_list xs; + let ys = Ghost.elift1 fst ysy; + let y = Ghost.elift1 snd ysy; + + rewrite each xs as (reveal ys @ [reveal y]); + is_deque_cons_not_none l; - unfold_is_deque_cons l; + let hptp = unfold_is_deque_cons l; let headp = Some?.v l.head; let tailp = Some?.v l.tail; - + let newnodev = { value = x; dprev = l.tail; dnext = None; }; let newnode = Box.alloc newnodev; - + + rewrite each hptp as (headp, tailp); + set_forward_pointer headp (Some newnode) tailp; - - join_last headp tailp newnode #x #(snoc ys y) #None #None; - + + join_last headp tailp newnode #x #_ #None #None; + let l' = { head = l.head; tail = Some newnode; }; - + fold_is_deque_cons l'; l' } - - fn push_back_nil (#t:Type0) (l : deque t) (x : t) (#xs : erased (list t)) @@ -1017,20 +1034,22 @@ fn pop_back_cons (#t:Type0) (l : deque t) ensures is_deque (fst l'x) xs ** pure (snd l'x == x) { is_deque_cons_not_none l; - unfold_is_deque_cons l; + let hptp = unfold_is_deque_cons l; let headp = Some?.v l.head; let tailp = Some?.v l.tail; + rewrite each hptp as (headp, tailp); + let g_tailp' = sep_last headp tailp #x #xs #None #None; - + let v_last = Box.( !tailp ); - + let tailp' = Some?.v v_last.dprev; let v = v_last.value; Box.free tailp; - + set_forward_pointer headp None tailp'; - + let l' = { head = l.head; tail = Some tailp' }; fold_is_deque_cons l'; @@ -1064,7 +1083,7 @@ fn is_singleton_snoc let t = hide (Cons?.tl (snoc xs (reveal x))); rewrite (is_deque p (snoc xs (reveal x))) as (is_deque p (reveal h :: reveal t)); - + (* This works quite nicely. The SMT is giving us that the LHS of the snoc is Nil iff `t` above is nil. *) is_singleton p; diff --git a/lib/pulse/lib/Pulse.Lib.Deque.fsti b/lib/pulse/lib/Pulse.Lib.Deque.fsti index 25bff9a45..e36113fda 100644 --- a/lib/pulse/lib/Pulse.Lib.Deque.fsti +++ b/lib/pulse/lib/Pulse.Lib.Deque.fsti @@ -7,7 +7,7 @@ open FStar.List.Tot new val deque (t:Type0) : Type0 -val is_deque #t (x:deque t) (l:list t) +val is_deque #t ([@@@mkey]x:deque t) (l:list t) : Tot slprop diff --git a/lib/pulse/lib/Pulse.Lib.DequeRef.fst b/lib/pulse/lib/Pulse.Lib.DequeRef.fst index 47ba1ce40..81f93ab72 100644 --- a/lib/pulse/lib/Pulse.Lib.DequeRef.fst +++ b/lib/pulse/lib/Pulse.Lib.DequeRef.fst @@ -7,7 +7,7 @@ open FStar.List.Tot let dq (t:Type0) = B.box (deque t) -let is_dq (#t:Type0) (x:dq t) (l:list t) +let is_dq (#t:Type0) ([@@@mkey]x:dq t) (l:list t) : slprop = exists* xx. B.pts_to x xx ** is_deque xx l @@ -29,7 +29,9 @@ ensures is_dq l (x::xs) { open Pulse.Lib.Box; unfold is_dq; + with xx0. assert (B.pts_to l xx0); let xx = !l; + rewrite each xx0 as xx; let yy = push_front xx x; l := yy; fold is_dq; @@ -43,7 +45,9 @@ ensures is_dq l xs ** pure (y == x) { open Pulse.Lib.Box; unfold is_dq; + with xx0. assert (B.pts_to l xx0); let xx = !l; + rewrite each xx0 as xx; let yy = pop_front xx; l := fst yy; fold is_dq; @@ -66,7 +70,9 @@ ensures is_dq l (xs @ [x]) { open Pulse.Lib.Box; unfold is_dq; + with xx0. assert (B.pts_to l xx0); let xx = !l; + rewrite each xx0 as xx; let yy = push_back xx x; l := yy; fold is_dq; @@ -80,7 +86,9 @@ ensures is_dq l xs ** pure (y == x) { open Pulse.Lib.Box; unfold is_dq; + with xx0. assert (B.pts_to l xx0); let xx = !l; + rewrite each xx0 as xx; let yy = pop_back xx; l := fst yy; fold is_dq; diff --git a/lib/pulse/lib/Pulse.Lib.FlippableInv.fst b/lib/pulse/lib/Pulse.Lib.FlippableInv.fst index c7d0d8747..44873d684 100644 --- a/lib/pulse/lib/Pulse.Lib.FlippableInv.fst +++ b/lib/pulse/lib/Pulse.Lib.FlippableInv.fst @@ -23,6 +23,14 @@ module GR = Pulse.Lib.GhostReference let finv_p (p:slprop) (r : GR.ref bool) : slprop = exists* (b:bool). pts_to r #0.5R b ** (if b then p else emp) +ghost +fn fold_finv_p (p:slprop) (r : GR.ref bool) (#b:bool) + requires pts_to r #0.5R b ** (if b then p else emp) + ensures finv_p p r +{ + fold finv_p; +} + noeq type finv (p:slprop) = { r : GR.ref bool; @@ -76,19 +84,18 @@ fn flip_on (#p:slprop) (fi:finv p) { later_elim _; unfold finv_p; + with b. + assert (pts_to fi.r #0.5R b ** pts_to fi.r #0.5R false); GR.gather2 fi.r; - rewrite (if false then p else emp) as emp; + rewrite each b as false; fi.r := true; GR.share2 fi.r; - rewrite p as (if true then p else emp); - fold (finv_p p fi.r); + fold_finv_p p fi.r; later_intro (finv_p p fi.r); }; - fold (on fi) + fold on fi; } - - atomic fn flip_off (#p:slprop) (fi : finv p) requires on fi ** later_credit 1 @@ -105,14 +112,14 @@ fn flip_off (#p:slprop) (fi : finv p) { later_elim _; unfold finv_p; + with b. + assert (pts_to fi.r #0.5R b ** pts_to fi.r #0.5R true); GR.gather2 fi.r; - rewrite (if true then p else emp) as p; + rewrite each b as true; fi.r := false; GR.share2 fi.r; - rewrite emp as (if false then p else emp); - fold (finv_p p fi.r); + fold_finv_p p fi.r; later_intro (finv_p p fi.r); }; - fold (off fi) + fold off fi; } - diff --git a/lib/pulse/lib/Pulse.Lib.Forall.Util.fst b/lib/pulse/lib/Pulse.Lib.Forall.Util.fst index 5d8ec6b91..901d8e179 100644 --- a/lib/pulse/lib/Pulse.Lib.Forall.Util.fst +++ b/lib/pulse/lib/Pulse.Lib.Forall.Util.fst @@ -56,7 +56,8 @@ fn trans (#a:Type0) (p q r: a -> slprop) requires (forall* x. p x @==> q x) ** (forall* x. q x @==> r x) ensures forall* x. p x @==> r x { - trans_compose p q r id id + admit(); /// GGG FIXME: rewrite under lambda + trans_compose p q r id id; } diff --git a/lib/pulse/lib/Pulse.Lib.Forall.fst b/lib/pulse/lib/Pulse.Lib.Forall.fst index 980ec39de..4ce74c2ad 100644 --- a/lib/pulse/lib/Pulse.Lib.Forall.fst +++ b/lib/pulse/lib/Pulse.Lib.Forall.fst @@ -117,4 +117,4 @@ let slprop_equiv_forall (_:squash (forall x. p x == q x)) : slprop_equiv (op_forall_Star p) (op_forall_Star q) = FStar.FunctionalExtensionality.extensionality _ _ p q; - slprop_equiv_refl (op_forall_Star p) \ No newline at end of file + slprop_equiv_refl (op_forall_Star p) diff --git a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst index 705a2b085..151d7d13f 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst @@ -31,7 +31,7 @@ let singleton #a (i:nat) (f:perm) (r:option a) then Some (r, f) else None) -let is_table #a (t:table a) (max:nat) +let is_table #a ([@@@mkey]t:table a) (max:nat) : slprop = GPR.pts_to t (full_table_above max) @@ -159,4 +159,4 @@ ensures (singleton i f0 (Some p) `FStar.PCM.op (a_map a)` singleton i f1 (Some q)) ); fold (pts_to t i #(f0 +. f1) p); -} \ No newline at end of file +} diff --git a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti index adc1141f1..902151e25 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti @@ -6,9 +6,9 @@ open Pulse.Lib.Pervasives val table (a:Type0) : Type0 instance val non_informative_table (a:Type): NonInformative.non_informative (table a) -val is_table #a (t:table a) (max:nat) : slprop +val is_table #a ([@@@mkey] t:table a) (max:nat) : slprop -val pts_to #a (t:table a) (i:nat) (#f:perm) (p:a) : slprop +val pts_to #a ([@@@mkey] t:table a) (i:nat) (#f:perm) (p:a) : slprop ghost fn create (#a:Type) diff --git a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti index 3194eb2fb..c41cad870 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti @@ -9,7 +9,7 @@ let gref (#a:Type0) (p:pcm a) val pts_to (#a:Type u#0) (#p:pcm a) - (r:gref p) + ([@@@mkey]r:gref p) (v:a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.GhostReference.fst b/lib/pulse/lib/Pulse.Lib.GhostReference.fst index 3d001e31c..7cdd8efc4 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostReference.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostReference.fst @@ -28,7 +28,7 @@ instance non_informative_gref (a:Type0) : NonInformative.non_informative (ref a) let pts_to (#a:Type u#0) - ([@@@equate_strict] r:ref a) + ([@@@mkey] r:ref a) (#[exact (`1.0R)] p:perm) (v:a) = H.pts_to r #p (U.raise_val v) diff --git a/lib/pulse/lib/Pulse.Lib.GhostReference.fsti b/lib/pulse/lib/Pulse.Lib.GhostReference.fsti index ad8dddf9e..448450bd0 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostReference.fsti @@ -28,7 +28,7 @@ instance val non_informative_gref (a:Type0) : NonInformative.non_informative (ref a) val pts_to (#a:Type) - ([@@@equate_strict] r:ref a) + ([@@@mkey] r:ref a) (#[exact (`1.0R)] p:perm) (n:a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.fst b/lib/pulse/lib/Pulse.Lib.HigherArray.fst index 7aa30bb9b..5adaf4011 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.fst +++ b/lib/pulse/lib/Pulse.Lib.HigherArray.fst @@ -496,28 +496,28 @@ ensures pure (i <= j /\ j <= length s) } -let token (x:'a) = emp +let token ([@@@mkey] k:'k) (x:'a) = emp let pts_to_range (#a:Type) - ([@@@equate_strict] x:array a) + ([@@@mkey] x:array a) (i j : nat) (#[exact (`1.0R)] p:perm) (s : Seq.seq a) : slprop -= exists* (q:in_bounds i j x). pts_to (array_slice x i j) #p s ** token q += exists* (q:in_bounds i j x). pts_to (array_slice x i j) #p s ** token x q let pts_to_range_timeless (#a:Type) (x:array a) (i j : nat) (p:perm) (s:Seq.seq a) : Lemma (timeless (pts_to_range x i j #p s)) [SMTPat (timeless (pts_to_range x i j #p s))] = let aux (q:in_bounds i j x) - : Lemma (timeless (pts_to (array_slice x i j) #p s ** token q)) + : Lemma (timeless (pts_to (array_slice x i j) #p s ** token x q)) = () in Classical.forall_intro aux; - assert_norm (pts_to_range x i j #p s == (exists* (q:in_bounds i j x). pts_to (array_slice x i j) #p s ** token q)); - timeless_exists (fun (q: in_bounds i j x) -> pts_to (array_slice x i j) #p s ** token q) + assert_norm (pts_to_range x i j #p s == (exists* (q:in_bounds i j x). pts_to (array_slice x i j) #p s ** token x q)); + timeless_exists (fun (q: in_bounds i j x) -> pts_to (array_slice x i j) #p s ** token x q) ghost @@ -533,7 +533,7 @@ ensures pts_to_range a i j #p s ** pure ( ) { unfold pts_to_range a i j #p s; - with q. assert (token #(in_bounds i j a) q); + with q. assert (token #(in_bounds i j a) a q); elim_in_bounds a q; pts_to_len (array_slice a i j); fold pts_to_range a i j #p s; @@ -553,7 +553,7 @@ ensures pts_to_range a 0 (length a) #p s { rewrite each a as (array_slice a 0 (length a)); let q : in_bounds 0 (length a) a = (); - fold (token #(in_bounds 0 (length a) a) q); + fold (token a q); fold (pts_to_range a 0 (length a) #p s); } @@ -571,7 +571,7 @@ requires pts_to_range a 0 (length a) #p s ensures pts_to a #p s { unfold (pts_to_range a 0 (length a) #p s); - unfold (token #(in_bounds 0 (length a) a) _); + unfold (token #(in_bounds 0 (length a) a) a _); rewrite each (array_slice a 0 (length a)) as a; } @@ -701,14 +701,14 @@ ensures { pts_to_range_prop a; unfold pts_to_range a i j #p s; - unfold (token #(in_bounds i j a) _); + unfold (token #(in_bounds i j a) a _); ghost_split (array_slice a i j) (m - i); split_r_slice a i m j #(Seq.slice s (m - i) (Seq.length s)) (); split_l_slice a i m j (); let q1 : in_bounds i m a = (); let q2 : in_bounds m j a = (); - fold (token #(in_bounds i m a) q1); - fold (token #(in_bounds m j a) q2); + fold (token #(in_bounds i m a) a q1); + fold (token #(in_bounds m j a) a q2); fold (pts_to_range a i m #p (Seq.slice s 0 (m - i))); fold (pts_to_range a m j #p (Seq.slice s (m - i) (Seq.length s))); assert pure (s `Seq.equal` Seq.append (Seq.slice s 0 (m - i)) (Seq.slice s (m - i) (Seq.length s))); @@ -789,7 +789,7 @@ requires pts_to (array_slice a i j) #p s ensures pts_to_range a i j #p s { let q : in_bounds i j a = (); - fold (token #(in_bounds i j a) q); + fold (token #(in_bounds i j a) a q); fold (pts_to_range a i j #p s); } @@ -814,8 +814,9 @@ ensures pts_to_range a i j #p (s1 `Seq.append` s2) rewrite each (merge (array_slice a i m) (array_slice a m j)) as (array_slice a i j); pts_to_range_intro_ij a _ _ i j (); - unfold (token #(in_bounds i m a) _); - unfold (token #(in_bounds m j a) _); + admit(); // fixme: ambig + unfold (token #(in_bounds i m a) a _); + unfold (token #(in_bounds m j a) a _); } let pts_to_range_join = pts_to_range_join' @@ -849,7 +850,7 @@ ensures pts_to_range_split a l (SZ.v i) r; with s1 s2. _; unfold pts_to_range a (SZ.v i) r #p s2; - unfold (token #(in_bounds (SZ.v i) r a) _); + unfold (token #(in_bounds (SZ.v i) r a) a _); let a' = array_slice_impl a i r (); rewrite each (array_slice a (SZ.v i) r) as a'; let res = read a' 0sz; @@ -882,7 +883,7 @@ ensures pts_to_range_split a l (SZ.v i) r; with s1 s2. _; unfold pts_to_range a (SZ.v i) r #1.0R s2; - unfold (token #(in_bounds (SZ.v i) r a) _); + unfold (token #(in_bounds (SZ.v i) r a) a _); let a' = array_slice_impl a i r (); rewrite each (array_slice a (SZ.v i) r) as a'; write a' 0sz v; @@ -907,7 +908,7 @@ fn pts_to_range_share { pts_to_range_prop arr; unfold (pts_to_range arr l r #p s); - unfold (token #(in_bounds l r arr) _); + unfold (token #(in_bounds l r arr) arr _); share (array_slice arr l r); pts_to_range_intro_ij arr (p /. 2.0R) s l r (); pts_to_range_intro_ij arr (p /. 2.0R) s l r (); @@ -925,7 +926,7 @@ fn pts_to_range_gather { pts_to_range_prop arr #l #r #p0; unfold (pts_to_range arr l r #p0 s0); - unfold (token #(in_bounds l r arr) _); + unfold (token #(in_bounds l r arr) arr _); unfold (pts_to_range arr l r #p1 s1); gather (array_slice arr l r); fold (pts_to_range arr l r #(p0 +. p1) s0) diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.fsti b/lib/pulse/lib/Pulse.Lib.HigherArray.fsti index d073c1891..27348cff3 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.fsti +++ b/lib/pulse/lib/Pulse.Lib.HigherArray.fsti @@ -33,7 +33,7 @@ type larray t (n:nat) = a:array t { length a == n } val is_full_array (#a:Type) (x:array a) : prop -val pts_to (#a:Type) (x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop +val pts_to (#a:Type) ([@@@mkey]x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop [@@pulse_unfold] instance has_pts_to_array (a:Type u#1) : has_pts_to (array a) (Seq.seq a) = { @@ -123,8 +123,8 @@ val gather val pts_to_range (#a:Type) - ([@@@equate_strict]x:array a) - (i j : nat) + ([@@@mkey]x:array a) + ([@@@mkey] i [@@@mkey] j : nat) (#[exact (`1.0R)] p:perm) (s : Seq.seq a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti b/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti index e4d042fbe..c4a47b0d8 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti @@ -28,7 +28,7 @@ instance val non_informative_gref (a:Type u#1) val pts_to (#a:Type) - ([@@@equate_strict] r:ref a) + ([@@@mkey] r:ref a) (#[exact (`1.0R)] p:perm) (n:a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.HigherReference.fsti b/lib/pulse/lib/Pulse.Lib.HigherReference.fsti index 2d127afd8..a50adaece 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.HigherReference.fsti @@ -22,7 +22,7 @@ open Pulse.Class.PtsTo module T = FStar.Tactics val ref ([@@@unused]a:Type u#1) : Type u#0 -val pts_to (#a:Type) (r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) : slprop +val pts_to (#a:Type) ([@@@mkey]r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) : slprop [@@pulse_unfold] instance has_pts_to_ref (a:Type) : has_pts_to (ref a) a = { diff --git a/lib/pulse/lib/Pulse.Lib.LinkedList.fst b/lib/pulse/lib/Pulse.Lib.LinkedList.fst index 4589eb718..ff605a48b 100644 --- a/lib/pulse/lib/Pulse.Lib.LinkedList.fst +++ b/lib/pulse/lib/Pulse.Lib.LinkedList.fst @@ -15,6 +15,7 @@ *) module Pulse.Lib.LinkedList + #lang-pulse open Pulse.Lib.Pervasives open Pulse.Lib.Stick.Util @@ -34,7 +35,7 @@ and node_ptr (t:Type0) = ref (node t) and llist (t:Type0) = option (node_ptr t) -let rec is_list #t (x:llist t) (l:list t) +let rec is_list #t ([@@@mkey]x:llist t) (l:list t) : Tot slprop (decreases l) = match l with | [] -> pure (x == None) @@ -43,11 +44,9 @@ let rec is_list #t (x:llist t) (l:list t) pure (x == Some v) ** pts_to v { head; tail } ** is_list tail tl - - -let is_list_cases #t (x:llist t) (l:list t) - : Tot slprop +let is_list_cases #t ([@@@mkey]x:llist t) (l:list t) + : Tot slprop = match x with | None -> pure (l == []) | Some v -> @@ -61,7 +60,7 @@ fn intro_is_list_cons (#t:Type0) (x:llist t) (v:node_ptr t) (#node:node t) (#tl: requires pts_to v node ** is_list node.tail tl ** pure (x == Some v) ensures is_list x (node.head::tl) { - fold (is_list x (node.head::tl)); + fold (is_list x (node.head::tl)); } ghost @@ -73,6 +72,7 @@ fn cases_of_is_list (#t:Type) (x:llist t) (l:list t) [] -> { unfold (is_list x []); fold (is_list_cases None l); + rewrite (is_list_cases None l) as (is_list_cases x l); } head :: tl -> { unfold (is_list x (head::tl)); @@ -98,7 +98,6 @@ fn is_list_of_cases (#t:Type) (x:llist t) (l:list t) fold (is_list x []); } Some vl -> { - rewrite (is_list_cases x l) as (is_list_cases (Some vl) l); unfold (is_list_cases (Some vl) l); intro_is_list_cons x vl; } @@ -109,14 +108,21 @@ fn is_list_of_cases (#t:Type) (x:llist t) (l:list t) ghost fn is_list_cases_none (#t:Type) (x:llist t) (#l:list t) requires is_list x l ** pure (x == None) - ensures is_list x l ** pure (l == []) + ensures is_list x l ** pure (l == []) { - cases_of_is_list x l; - rewrite (is_list_cases x l) as pure (l == []); - fold (is_list x []); + match l { + Nil -> { + (); + } + Cons _ _ -> { + unfold is_list; + admit(); + assert (pure False); // NEEDED, bug? couldn't minimize easily + unreachable (); + } + } } - ghost fn is_list_cases_some (#t:Type) (x:llist t) (v:node_ptr t) (#l:list t) requires is_list x l ** pure (x == Some v) @@ -133,27 +139,26 @@ fn is_list_cases_some (#t:Type) (x:llist t) (v:node_ptr t) (#l:list t) /////////////////////////////////////////////////////////////////////////////// - -fn is_empty (#t:Type) (x:llist t) +fn is_empty (#t:Type) (x:llist t) requires is_list x 'l returns b:bool ensures is_list x 'l ** pure (b <==> ('l == [])) { - match x { - None -> { - is_list_cases_none x; - true - } - Some vl -> { - is_list_cases_some x vl; - intro_is_list_cons x vl; - false - } + match x { + None -> { + is_list_cases_none None; + assert (pure ('l == [])); + rewrite (is_list None 'l) as (is_list x 'l); + true + } + Some vl -> { + is_list_cases_some (Some vl) vl; + intro_is_list_cons x vl; + false } + } } - - fn rec length (#t:Type0) (x:llist t) (#l:erased (list t)) requires is_list x l @@ -162,11 +167,12 @@ fn rec length (#t:Type0) (x:llist t) { match x { None -> { - is_list_cases_none x; + is_list_cases_none None; + rewrite (is_list None l) as (is_list x l); 0 } Some vl -> { - is_list_cases_some x vl; + is_list_cases_some (Some vl) vl; with _node _tl. _; let node = !vl; rewrite each _node as node; @@ -177,10 +183,8 @@ fn rec length (#t:Type0) (x:llist t) } } - let null_llist #t : llist t = None #(node_ptr t) - fn create (t:Type) requires emp returns x:llist t @@ -206,8 +210,8 @@ fn cons (#t:Type) (v:t) (x:llist t) fn rec append (#t:Type0) (x y:llist t) -requires is_list x 'l1 ** is_list y 'l2 ** pure (Some? x) -ensures is_list x ('l1 @ 'l2) + requires is_list x 'l1 ** is_list y 'l2 ** pure (Some? x) + ensures is_list x ('l1 @ 'l2) { let np = Some?.v x; is_list_cases_some x np; @@ -216,21 +220,21 @@ ensures is_list x ('l1 @ 'l2) rewrite each _node as node; match node.tail { None -> { - is_list_cases_none node.tail; - unfold (is_list node.tail []); + is_list_cases_none None; + unfold (is_list #t None []); np := { node with tail = y }; rewrite each y as ({ node with tail = y }).tail in (is_list y 'l2); intro_is_list_cons x np; } - Some _ -> { - append node.tail y; + Some p -> { + append (Some p) y; + rewrite each (Some p) as node.tail; intro_is_list_cons x np; } } } - ghost fn intro_yields_cons (#t:Type) (v:node_ptr t) @@ -259,7 +263,6 @@ ensures } - fn move_next (#t:Type) (x:llist t) requires is_list x 'l ** pure (Some? x) returns y:llist t @@ -274,6 +277,7 @@ fn move_next (#t:Type) (x:llist t) let node = !np; rewrite each _node as node; intro_yields_cons np; + rewrite each (Some np) as x; node.tail } @@ -330,12 +334,14 @@ fn is_last_cell (#t:Type) (x:llist t) let node = !np; rewrite each _node as node; match node.tail { - None -> { - is_list_cases_none node.tail; + None -> { + is_list_cases_none None; + rewrite is_list #t None _tl as is_list node.tail _tl; intro_is_list_cons x np; true } - Some vtl -> { + Some vtl -> { + rewrite each Some vtl as node.tail; is_list_cases_some node.tail vtl; intro_is_list_cons node.tail vtl; intro_is_list_cons x np; @@ -344,10 +350,6 @@ fn is_last_cell (#t:Type) (x:llist t) } } - - - - fn append_at_last_cell (#t:Type) (x y:llist t) requires is_list x 'l1 ** @@ -363,21 +365,19 @@ ensures rewrite each _node as node; match node.tail { None -> { - is_list_cases_none node.tail; - unfold (is_list node.tail []); + is_list_cases_none None; + unfold (is_list #t None []); np := { node with tail = y }; rewrite each y as ({node with tail = y}).tail in (is_list y 'l2); intro_is_list_cons x np; } Some vtl -> { - is_list_cases_some node.tail vtl; + is_list_cases_some (Some vtl) vtl; unreachable (); } } } - - ghost fn non_empty_list (#t:Type0) (x:llist t) requires is_list x 'l ** pure (Cons? 'l) @@ -523,8 +523,8 @@ ensures exists* hd tl. module U32 = FStar.UInt32 open Pulse.Lib.BoundedIntegers #push-options "--fuel 1 --ifuel 1" - - fn split (#t:Type0) (x:llist t) (n:U32.t) (#xl:erased (list t)) + +fn split (#t:Type0) (x:llist t) (n:U32.t) (#xl:erased (list t)) requires is_list x xl ** pure (Some? x /\ 0 < v n /\ v n <= List.Tot.length xl) returns y:llist t ensures exists* l1 l2. @@ -589,7 +589,6 @@ open Pulse.Lib.BoundedIntegers List.Tot.append_length pfx [hd]; y } - fn insert (#kk:Type0) (x:llist kk) (item:kk) (pos:U32.t) (#xl:erased (list kk)) diff --git a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst index a81410fac..b631f661e 100644 --- a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst +++ b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst @@ -132,4 +132,4 @@ ensures pts_to r #1.0R v with f h. assert (GR.pts_to r (f, h)); GR.write r _ _ (FP.mk_frame_preserving_upd p h v); fold pts_to; -} \ No newline at end of file +} diff --git a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti index 6977f251b..fac0adcdb 100644 --- a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti +++ b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti @@ -15,7 +15,7 @@ instance val non_informative_mref val pts_to (#t:Type) (#p:preorder t) - (r:mref p) + ([@@@mkey] r:mref p) (#f:perm) (v:t) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.OnRange.fst b/lib/pulse/lib/Pulse.Lib.OnRange.fst index 8818bb1f1..eabc7e95d 100644 --- a/lib/pulse/lib/Pulse.Lib.OnRange.fst +++ b/lib/pulse/lib/Pulse.Lib.OnRange.fst @@ -5,8 +5,8 @@ open Pulse.Lib.Pervasives open Pulse.Lib.Stick let rec on_range - (p: (nat -> slprop)) - (i j: nat) + ([@@@mkey]p: (nat -> slprop)) + ([@@@mkey]i j: nat) : Tot slprop (decreases (if j <= i then 0 else j - i)) = if j < i @@ -469,6 +469,7 @@ fn rec on_range_zip (p q:nat -> slprop) (i j:nat) rewrite (on_range p i j) as pure False; unreachable (); } else if (j = i) { + rewrite each j as i; on_range_empty_elim p i; on_range_empty_elim q i; on_range_empty (fun k -> p k ** q k) i; @@ -496,6 +497,7 @@ fn rec on_range_unzip (p q:nat -> slprop) (i j:nat) on_range_empty_elim (fun k -> p k ** q k) i; on_range_empty p i; on_range_empty q i; + (); } else { on_range_uncons () #(fun k -> p k ** q k); on_range_unzip p q (i + 1) j; diff --git a/lib/pulse/lib/Pulse.Lib.OnRange.fsti b/lib/pulse/lib/Pulse.Lib.OnRange.fsti index 52c26cbeb..3e47c64b9 100644 --- a/lib/pulse/lib/Pulse.Lib.OnRange.fsti +++ b/lib/pulse/lib/Pulse.Lib.OnRange.fsti @@ -18,7 +18,7 @@ module Pulse.Lib.OnRange open Pulse.Lib.Pervasives open Pulse.Lib.Stick -val on_range ([@@@equate_strict] p: (nat -> slprop)) +val on_range ([@@@mkey] p: (nat -> slprop)) (i:nat) (j:nat) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.Primitives.fsti b/lib/pulse/lib/Pulse.Lib.Primitives.fsti index b87971846..29bd8684b 100644 --- a/lib/pulse/lib/Pulse.Lib.Primitives.fsti +++ b/lib/pulse/lib/Pulse.Lib.Primitives.fsti @@ -19,7 +19,6 @@ module Pulse.Lib.Primitives open PulseCore.Observability open Pulse.Lib.Core open PulseCore.FractionalPermission -open Pulse.Main open Pulse.Lib.Reference open FStar.Ghost open Pulse.Class.PtsTo diff --git a/lib/pulse/lib/Pulse.Lib.Reference.fsti b/lib/pulse/lib/Pulse.Lib.Reference.fsti index 567ecd58a..cdd8c9672 100644 --- a/lib/pulse/lib/Pulse.Lib.Reference.fsti +++ b/lib/pulse/lib/Pulse.Lib.Reference.fsti @@ -28,7 +28,7 @@ val ref ([@@@unused] a:Type u#0) : Type u#0 val pts_to (#a:Type) - ([@@@equate_strict] r:ref a) + ([@@@mkey] r:ref a) (#[exact (`1.0R)] p:perm) (n:a) : slprop @@ -38,7 +38,7 @@ instance has_pts_to_ref (a:Type) : has_pts_to (ref a) a = { pts_to = (fun r #f v -> pts_to r #f v); } -val pts_to_timeless (#a:Type) (r:ref a) (p:perm) (x:a) +val pts_to_timeless (#a:Type) ([@@@mkey] r:ref a) (p:perm) (x:a) : Lemma (timeless (pts_to r #p x)) [SMTPat (timeless (pts_to r #p x))] diff --git a/lib/pulse/lib/Pulse.Lib.SLPropTable.fst b/lib/pulse/lib/Pulse.Lib.SLPropTable.fst index ab9f85cad..c271e25d9 100644 --- a/lib/pulse/lib/Pulse.Lib.SLPropTable.fst +++ b/lib/pulse/lib/Pulse.Lib.SLPropTable.fst @@ -13,7 +13,7 @@ let is_table (t:table) (max:nat) : slprop = GT.is_table t max -let pts_to (t:table) (i:nat) (#f:perm) (p:slprop) +let pts_to ([@@@mkey]t:table) ([@@@mkey]i:nat) (#f:perm) (p:slprop) : slprop = exists* r. slprop_ref_pts_to r p ** @@ -98,6 +98,7 @@ ensures unfold pts_to; with r1. assert (GT.pts_to t i #f1 r1); GT.gather t i #f0 #f1 #r0 #r1; + rewrite each r1 as r0; slprop_ref_gather r0 #p #q; fold (pts_to t i #(f0 +. f1) p); -} \ No newline at end of file +} diff --git a/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti b/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti index c4cf74d31..ae35f6949 100644 --- a/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti +++ b/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti @@ -6,9 +6,10 @@ open Pulse.Lib.Pervasives val table : Type0 instance val non_informative_table: NonInformative.non_informative table -val is_table (t:table) (max:nat) : slprop -val pts_to (t:table) (i:nat) (#f:perm) (p:slprop) : slprop +val is_table ([@@@mkey]t:table) (max:nat) : slprop + +val pts_to ([@@@mkey]t:table) ([@@@mkey]i:nat) (#f:perm) (p:slprop) : slprop ghost fn create () diff --git a/lib/pulse/lib/Pulse.Lib.SeqMatch.Util.fst b/lib/pulse/lib/Pulse.Lib.SeqMatch.Util.fst index a7946e6a2..c8845f52a 100644 --- a/lib/pulse/lib/Pulse.Lib.SeqMatch.Util.fst +++ b/lib/pulse/lib/Pulse.Lib.SeqMatch.Util.fst @@ -86,7 +86,9 @@ ensures (seq_list_match c v item_match) { Seq.cons_head_tail c; - seq_list_match_cons_intro (Seq.head c) (List.Tot.hd v) (Seq.tail c) (List.Tot.tl v) item_match + seq_list_match_cons_intro (Seq.head c) (List.Tot.hd v) (Seq.tail c) (List.Tot.tl v) item_match; + rewrite each (Seq.cons (Seq.head c) (Seq.tail c)) as c; + () }; Trade.intro _ _ _ aux; () diff --git a/lib/pulse/lib/Pulse.Lib.SeqMatch.fst b/lib/pulse/lib/Pulse.Lib.SeqMatch.fst index 94fa18ec4..27834b3c7 100644 --- a/lib/pulse/lib/Pulse.Lib.SeqMatch.fst +++ b/lib/pulse/lib/Pulse.Lib.SeqMatch.fst @@ -29,7 +29,7 @@ high-level values. *) let rec seq_list_match (#t #t': Type) - (c: Seq.seq t) + ([@@@mkey]c: Seq.seq t) (v: list t') (item_match: (t -> (v': t' { v' << v }) -> slprop)) : Tot slprop @@ -53,7 +53,9 @@ requires ensures seq_list_match c v item_match { - fold (seq_list_match c [] item_match) + fold (seq_list_match c [] item_match); + rewrite seq_list_match c [] item_match + as seq_list_match c v item_match; } ghost @@ -119,11 +121,13 @@ ensures unreachable() } else { let res : squash (Cons? v /\ Seq.length c > 0) = (); + rewrite each v as (List.Tot.hd v :: List.Tot.tl v); unfold (seq_list_match c (List.Tot.hd v :: List.Tot.tl v) item_match); with c1 . assert (item_match c1 (List.Tot.hd v)); with c2 . assert (seq_list_match c2 (List.Tot.tl v) item_match); assert (pure (c2 `Seq.equal` Seq.tail c)); rewrite (item_match c1 (List.Tot.hd v)) as (item_match (Seq.head c) (List.Tot.hd v)); + rewrite each c2 as Seq.tail c; res } } @@ -169,6 +173,8 @@ decreases v seq_list_match_weaken (Seq.tail c) (List.Tot.tl v) item_match1 item_match2 prf'; Seq.cons_head_tail c; seq_list_match_cons_intro (Seq.head c) (List.Tot.hd v) (Seq.tail c) (List.Tot.tl v) item_match2; + rewrite each Seq.cons (Seq.head c) (Seq.tail c) as c; + () } } @@ -329,12 +335,17 @@ requires ensures (seq_seq_match p s1 s2 i (i + 1)) { - fold (seq_seq_match_item p s1 s2 i); + rewrite p x1 x2 as seq_seq_match_item p s1 s2 i; on_range_singleton_intro (seq_seq_match_item p s1 s2) i; fold (seq_seq_match p s1 s2 i (i + 1)) } -ghost fn seq_seq_match_singleton_elim + +assume val foo : slprop +assume val bar : slprop + +ghost +fn seq_seq_match_singleton_elim (#t1 #t2: Type0) (p: t1 -> t2 -> slprop) (s1: Seq.seq t1) @@ -351,8 +362,17 @@ ensures seq_seq_match_length p s1 s2 i (i + 1); unfold (seq_seq_match p s1 s2 i (i + 1)); on_range_singleton_elim (); - unfold (seq_seq_match_item p s1 s2 i); - () + // unfold (seq_seq_match_item p s1 s2 i); + let b = StrongExcludedMiddle.strong_excluded_middle (i < Seq.length s1 && i < Seq.length s2); + if b { + assert (pure (i < Seq.length s1 && i < Seq.length s2)); + rewrite each x1 as Seq.index s1 i; + rewrite each x2 as Seq.index s2 i; + rewrite seq_seq_match_item p s1 s2 i as p (Seq.index s1 i) (Seq.index s2 i); + () + } else { + unreachable() + } } ghost fn seq_seq_match_enqueue_left @@ -370,7 +390,7 @@ ensures (seq_seq_match p s1 s2 (i - 1) j) { unfold (seq_seq_match p s1 s2 i j); - fold (seq_seq_match_item p s1 s2 (i - 1)); + rewrite p x1 x2 as seq_seq_match_item p s1 s2 (i - 1); on_range_cons (i - 1); fold (seq_seq_match p s1 s2 (i - 1) j) } @@ -390,7 +410,7 @@ ensures (seq_seq_match p s1 s2 i (j + 1)) { unfold (seq_seq_match p s1 s2 i j); - fold (seq_seq_match_item p s1 s2 j); + rewrite p x1 x2 as seq_seq_match_item p s1 s2 j; on_range_snoc (); fold (seq_seq_match p s1 s2 i (j + 1)) } @@ -412,7 +432,7 @@ ensures unfold (seq_seq_match p s1 s2 i j); on_range_uncons (); fold (seq_seq_match p s1 s2 (i + 1) j); - unfold (seq_seq_match_item p s1 s2 i) + rewrite (seq_seq_match_item p s1 s2 i) as (p (Seq.index s1 i) (Seq.index s2 i)); } ghost fn seq_seq_match_dequeue_right @@ -432,7 +452,7 @@ ensures unfold (seq_seq_match p s1 s2 i j); on_range_unsnoc (); fold (seq_seq_match p s1 s2 i (j - 1)); - unfold (seq_seq_match_item p s1 s2 (j - 1)) + rewrite (seq_seq_match_item p s1 s2 (j-1)) as (p (Seq.index s1 (j - 1)) (Seq.index s2 (j - 1))) } @@ -727,7 +747,8 @@ decreases l (seq_seq_match p (Seq.tail c) (Seq.seq_of_list (List.Tot.tl l)) 0 (List.Tot.length (List.Tot.tl l))); seq_seq_match_seq_list_match p _ (List.Tot.tl l); Seq.cons_head_tail c; - seq_list_match_cons_intro (Seq.head c) (List.Tot.hd l) (Seq.tail c) (List.Tot.tl l) p + seq_list_match_cons_intro (Seq.head c) (List.Tot.hd l) (Seq.tail c) (List.Tot.tl l) p; + rewrite each (Seq.cons (Seq.head c) (Seq.tail c)) as c; } } } @@ -1145,3 +1166,29 @@ ensures fold (seq_seq_match (item_match_option p) s1 (Seq.upd s2 j None) i k); res } + +ghost +fn seq_seq_match_item_match_option_upd_some + (#t1 #t2: Type0) + (p: t1 -> t2 -> slprop) + (s1: Seq.seq t1) + (s2: Seq.seq (option t2)) + (i j: nat) + (k: nat { + i <= j /\ j < k /\ + (j < Seq.length s2 ==> Some? (Seq.index s2 j)) + }) + (x1: t1) + (x2: t2) + requires + seq_seq_match (item_match_option p) s1 s2 i k ** p x1 x2 + returns res: squash (j < Seq.length s1 /\ j < Seq.length s2 /\ Some? (Seq.index s2 j)) + ensures + seq_seq_match (item_match_option p) (Seq.upd s1 j x1) (Seq.upd s2 j (Some x2)) i k ** + p (Seq.index s1 j) (Some?.v (Seq.index s2 j)) +{ + seq_seq_match_item_match_option_index p s1 s2 i j k; + seq_seq_match_item_match_option_upd_none p s1 (Seq.upd s2 j None) i j k x1 x2; + assert (pure (Seq.upd (Seq.upd s2 j None) j (Some x2) `Seq.equal` Seq.upd s2 j (Some x2))); + () +} diff --git a/lib/pulse/lib/Pulse.Lib.SeqMatch.fsti b/lib/pulse/lib/Pulse.Lib.SeqMatch.fsti index 69d2837f2..2ad18a312 100644 --- a/lib/pulse/lib/Pulse.Lib.SeqMatch.fsti +++ b/lib/pulse/lib/Pulse.Lib.SeqMatch.fsti @@ -29,7 +29,7 @@ high-level values. *) val seq_list_match (#t #t': Type) - (c: Seq.seq t) + ([@@@mkey] c: Seq.seq t) (v: list t') (item_match: (t -> (v': t' { v' << v }) -> slprop)) : Tot slprop @@ -117,8 +117,8 @@ high-level values, because no lemma ensures that `Seq.index s i << s` *) val seq_seq_match (#t1 #t2: Type) (p: t1 -> t2 -> slprop) - (c: Seq.seq t1) - (l: Seq.seq t2) + ([@@@mkey] c : Seq.seq t1) + (l : Seq.seq t2) (i j: nat) : Tot slprop @@ -584,7 +584,8 @@ val seq_seq_match_item_match_option_index p (Seq.index s1 j) (Some?.v (Seq.index s2 j)) ) -ghost fn seq_seq_match_item_match_option_upd_some +ghost +fn seq_seq_match_item_match_option_upd_some (#t1 #t2: Type0) (p: t1 -> t2 -> slprop) (s1: Seq.seq t1) @@ -596,17 +597,9 @@ ghost fn seq_seq_match_item_match_option_upd_some }) (x1: t1) (x2: t2) -requires - (seq_seq_match (item_match_option p) s1 s2 i k ** p x1 x2) -returns res: squash (j < Seq.length s1 /\ j < Seq.length s2 /\ Some? (Seq.index s2 j)) -ensures - ( - seq_seq_match (item_match_option p) (Seq.upd s1 j x1) (Seq.upd s2 j (Some x2)) i k ** - p (Seq.index s1 j) (Some?.v (Seq.index s2 j)) - ) -{ - seq_seq_match_item_match_option_index p s1 s2 i j k; - seq_seq_match_item_match_option_upd_none p s1 (Seq.upd s2 j None) i j k x1 x2; - assert (pure (Seq.upd (Seq.upd s2 j None) j (Some x2) `Seq.equal` Seq.upd s2 j (Some x2))); - () -} + requires + seq_seq_match (item_match_option p) s1 s2 i k ** p x1 x2 + returns res: squash (j < Seq.length s1 /\ j < Seq.length s2 /\ Some? (Seq.index s2 j)) + ensures + seq_seq_match (item_match_option p) (Seq.upd s1 j x1) (Seq.upd s2 j (Some x2)) i k ** + p (Seq.index s1 j) (Some?.v (Seq.index s2 j)) diff --git a/lib/pulse/lib/Pulse.Lib.Slice.Util.fst b/lib/pulse/lib/Pulse.Lib.Slice.Util.fst index 76cb8f9f6..14e97a8b0 100644 --- a/lib/pulse/lib/Pulse.Lib.Slice.Util.fst +++ b/lib/pulse/lib/Pulse.Lib.Slice.Util.fst @@ -38,7 +38,9 @@ fn append_split (#t: Type) (s: S.slice t) (#p: perm) (i: SZ.t) { assert pure (v1 `Seq.equal` Seq.slice (Seq.append v1 v2) 0 (SZ.v i)); assert pure (v2 `Seq.equal` Seq.slice (Seq.append v1 v2) (SZ.v i) (Seq.length v1 + Seq.length v2)); - S.split s i + let r = S.split s i; + rewrite each r as (fst r, snd r); + (fst r, snd r) } inline_for_extraction diff --git a/lib/pulse/lib/Pulse.Lib.Slice.fst b/lib/pulse/lib/Pulse.Lib.Slice.fst index 50b1a58da..cb070da7c 100644 --- a/lib/pulse/lib/Pulse.Lib.Slice.fst +++ b/lib/pulse/lib/Pulse.Lib.Slice.fst @@ -16,7 +16,7 @@ module Pulse.Lib.Slice #lang-pulse - +#set-options "--ext pulse:new" module AP = Pulse.Lib.ArrayPtr noeq @@ -31,26 +31,6 @@ let pts_to (#t:Type) (s:slice t) (#p:perm) (v : Seq.seq t) = pts_to s.elt #p v ** pure (Seq.length v == SZ.v s.len) -ghost fn unfold_pts_to #t (s: slice t) #p v - requires pts_to s #p v - ensures AP.pts_to s.elt #p v ** - pure (Seq.length v == SZ.v s.len) -{ - rewrite pts_to s #p v as - AP.pts_to s.elt #p v ** - pure (Seq.length v == SZ.v s.len) -} - -ghost fn fold_pts_to #t (s: slice t) #p v - requires AP.pts_to s.elt #p v ** - pure (Seq.length v == SZ.v s.len) - ensures pts_to s #p v -{ - rewrite AP.pts_to s.elt #p v ** - pure (Seq.length v == SZ.v s.len) - as pts_to s #p v; -} - let pts_to_timeless x p v = () ghost @@ -58,8 +38,8 @@ fn pts_to_len (#t: Type) (s: slice t) (#p: perm) (#v: Seq.seq t) requires pts_to s #p v ensures pts_to s #p v ** pure (Seq.length v == SZ.v (len s)) { - unfold_pts_to s #p v; - fold_pts_to s #p v + unfold pts_to s #p v; + fold pts_to s #p v } let is_from_array a s = @@ -79,7 +59,8 @@ fn from_array (#t: Type) (a: array t) (#p: perm) (alen: SZ.t) elt = ptr; len = alen; }; - fold_pts_to res #p v; + rewrite each ptr as res.elt; + fold pts_to res #p v; fold is_from_array a res; res } @@ -90,7 +71,7 @@ fn to_array requires (pts_to s #p v ** is_from_array a s) ensures (A.pts_to a #p v) { - unfold_pts_to s #p v; + unfold pts_to s #p v; unfold is_from_array a s; AP.to_array s.elt a } @@ -111,7 +92,8 @@ fn arrayptr_to_slice_intro elt = a; len = alen; }; - fold_pts_to s #p v; + rewrite each a as s.elt; + fold pts_to s #p v; fold arrayptr_to_slice a s; s } @@ -120,12 +102,14 @@ ghost fn arrayptr_to_slice_elim (#t: Type) (s: slice t) (#p: perm) (#v: Seq.seq t) (#a: AP.ptr t) requires - (pts_to s #p v ** arrayptr_to_slice a s) + pts_to s #p v ** arrayptr_to_slice a s ensures (AP.pts_to a #p v) { unfold (arrayptr_to_slice a s); - unfold_pts_to s #p v; + unfold pts_to s #p v; + rewrite each s.elt as a; + () } let slice_to_arrayptr @@ -140,7 +124,7 @@ returns a: AP.ptr t ensures (AP.pts_to a #p v ** slice_to_arrayptr s a) { - unfold_pts_to s #p v; + unfold pts_to s #p v; fold (slice_to_arrayptr s s.elt); s.elt } @@ -151,10 +135,11 @@ fn slice_to_arrayptr_elim requires (AP.pts_to a #p v ** slice_to_arrayptr s a ** pure (Seq.length v == SZ.v (len s))) ensures - (pts_to s #p v) + pts_to s #p v { unfold (slice_to_arrayptr s a); - fold_pts_to s #p v + rewrite each a as s.elt; + fold pts_to s #p v; } fn op_Array_Access @@ -170,9 +155,9 @@ ensures pts_to a #p s ** pure (res == Seq.index s (SZ.v i)) { - unfold_pts_to a #p s; + unfold pts_to a #p s; let res = AP.op_Array_Access a.elt i; - fold_pts_to a #p s; + fold pts_to a #p s; res } @@ -187,9 +172,10 @@ fn op_Array_Assignment ensures pts_to a (Seq.upd s (SZ.v i) v) { - unfold_pts_to a s; + unfold pts_to a s; AP.op_Array_Assignment a.elt i v; - fold_pts_to a (Seq.upd s (SZ.v i) v) + fold pts_to a (Seq.upd s (SZ.v i) v); + () } ghost @@ -202,10 +188,10 @@ requires pts_to arr #p s ensures pts_to arr #(p /. 2.0R) s ** pts_to arr #(p /. 2.0R) s { - unfold_pts_to arr #p s; + unfold pts_to arr #p s; AP.share arr.elt; - fold_pts_to arr #(p /. 2.0R) s; - fold_pts_to arr #(p /. 2.0R) s + fold pts_to arr #(p /. 2.0R) s; + fold pts_to arr #(p /. 2.0R) s } ghost @@ -217,10 +203,10 @@ fn gather requires pts_to arr #p0 s0 ** pts_to arr #p1 s1 ensures pts_to arr #(p0 +. p1) s0 ** pure (s0 == s1) { - unfold_pts_to arr #p0 s0; - unfold_pts_to arr #p1 s1; + unfold pts_to arr #p0 s0; + unfold pts_to arr #p1 s1; AP.gather arr.elt; - fold_pts_to arr #(p0 +. p1) s0 + fold pts_to arr #(p0 +. p1) s0 } let is_split #t s s1 s2 = @@ -242,19 +228,21 @@ fn split (#t: Type) (s: slice t) (#p: perm) (i: SZ.t) pts_to s2 #p (Seq.slice v (SZ.v i) (Seq.length v)) ** is_split s s1 s2) { - unfold_pts_to s #p v; + unfold pts_to s #p v; Seq.lemma_split v (SZ.v i); let elt' = AP.split s.elt #p i; let s1 = { elt = s.elt; len = i; }; - fold_pts_to s1 #p (Seq.slice v 0 (SZ.v i)); + rewrite each s.elt as s1.elt; + fold pts_to s1 #p (Seq.slice v 0 (SZ.v i)); let s2 = { elt = elt'; len = s.len `SZ.sub` i; }; - fold_pts_to s2 #p (Seq.slice v (SZ.v i) (Seq.length v)); + rewrite each elt' as s2.elt; + fold pts_to s2 #p (Seq.slice v (SZ.v i) (Seq.length v)); fold (is_split s s1 s2); (s1, s2) } @@ -271,21 +259,26 @@ fn ghost_split (#t: Type) (s: slice t) (#p: perm) (i: SZ.t) is_split s (fst res) (snd res) ) { - unfold_pts_to s #p v; + unfold pts_to s #p v; Seq.lemma_split v (SZ.v i); let elt' = AP.ghost_split s.elt #p i; let s1 = { elt = s.elt; len = i; }; - fold_pts_to s1 #p (Seq.slice v 0 (SZ.v i)); + rewrite each s.elt as s1.elt; + fold pts_to s1 #p (Seq.slice v 0 (SZ.v i)); let s2 = { elt = elt'; len = s.len `SZ.sub` i; }; - fold_pts_to s2 #p (Seq.slice v (SZ.v i) (Seq.length v)); + rewrite each elt' as s2.elt; + fold pts_to s2 #p (Seq.slice v (SZ.v i) (Seq.length v)); fold (is_split s s1 s2); - (s1, s2) + let res = (s1, s2); + rewrite each s1 as (fst res); + rewrite each s2 as (snd res); + res } ghost @@ -294,10 +287,12 @@ fn join (#t: Type) (s1: slice t) (#p: perm) (#v1: Seq.seq t) (s2: slice t) (#v2: ensures pts_to s #p (Seq.append v1 v2) { unfold (is_split s s1 s2); - unfold_pts_to s1 #p v1; - unfold_pts_to s2 #p v2; + unfold pts_to s1 #p v1; + unfold pts_to s2 #p v2; AP.join s1.elt s2.elt; - fold_pts_to s #p (Seq.append v1 v2) + rewrite each s1.elt as s.elt; + fold pts_to s #p (Seq.append v1 v2); + () } fn subslice #t (s: slice t) #p (i j: SZ.t) (#v: erased (Seq.seq t) { SZ.v i <= SZ.v j /\ SZ.v j <= Seq.length v }) @@ -305,20 +300,23 @@ fn subslice #t (s: slice t) #p (i j: SZ.t) (#v: erased (Seq.seq t) { SZ.v i <= S returns res: slice t ensures pts_to res #p (Seq.slice v (SZ.v i) (SZ.v j)) ** subslice_rest res s p i j v { - unfold_pts_to s #p v; + unfold pts_to s #p v; let elt' = AP.split s.elt i; let elt'' = AP.ghost_split elt' (SZ.sub j i); let s1 = hide { elt = s.elt; len = i }; let s2 = hide { elt = elt'; len = SZ.sub s.len i }; fold is_split s s1 s2; - let res = hide { elt = elt'; len = SZ.sub j i }; + rewrite each s.elt as s1.elt; + let res = { elt = elt'; len = SZ.sub j i }; let s3 = hide { elt = elt''; len = SZ.sub s.len j }; fold is_split s2 res s3; - fold_pts_to s1 #p (Seq.slice v 0 (SZ.v i)); - fold_pts_to res #p (Seq.slice v (SZ.v i) (SZ.v j)); - fold_pts_to s3 #p (Seq.slice v (SZ.v j) (Seq.length v)); + rewrite each elt' as res.elt; + rewrite each elt'' as s3.elt; + fold pts_to s1 #p (Seq.slice v 0 (SZ.v i)); + fold pts_to res #p (Seq.slice v (SZ.v i) (SZ.v j)); + fold pts_to s3 #p (Seq.slice v (SZ.v j) (Seq.length v)); fold subslice_rest; - ({ elt = elt'; len = SZ.sub j i }) + res } fn copy @@ -329,12 +327,12 @@ ensures (pts_to dst v ** pts_to src #p v) { with v_dst . assert (pts_to dst v_dst); - unfold_pts_to dst v_dst; - unfold_pts_to src #p v; + unfold pts_to dst v_dst; + unfold pts_to src #p v; AP.memcpy src.elt 0sz dst.elt 0sz src.len; - fold_pts_to src #p v; + fold pts_to src #p v; assert pure (v `Seq.equal` Seq.append (Seq.slice v 0 (SZ.v src.len)) (Seq.slice v_dst (SZ.v src.len) (Seq.length v_dst))); - fold_pts_to dst v + fold pts_to dst v } diff --git a/lib/pulse/lib/Pulse.Lib.Slice.fsti b/lib/pulse/lib/Pulse.Lib.Slice.fsti index e674ca4b2..d4350b404 100644 --- a/lib/pulse/lib/Pulse.Lib.Slice.fsti +++ b/lib/pulse/lib/Pulse.Lib.Slice.fsti @@ -24,7 +24,12 @@ val slice ([@@@strictly_positive] elt: Type0) : Type0 val len (#t: Type) : slice t -> SZ.t -val pts_to (#t:Type) (s:slice t) (#[exact (`1.0R)] p:perm) (v : Seq.seq t) : slprop +val pts_to + (#t:Type) + ([@@@mkey]s:slice t) + (#[exact (`1.0R)] p:perm) + (v : Seq.seq t) + : slprop [@@pulse_unfold] instance has_pts_to_slice (t: Type u#0) : has_pts_to (slice t) (Seq.seq t) = { diff --git a/lib/pulse/lib/Pulse.Lib.SpinLock.fst b/lib/pulse/lib/Pulse.Lib.SpinLock.fst index 13b4b6457..c5bf5c6b0 100644 --- a/lib/pulse/lib/Pulse.Lib.SpinLock.fst +++ b/lib/pulse/lib/Pulse.Lib.SpinLock.fst @@ -149,7 +149,8 @@ fn release (#v:slprop) (#p:perm) (l:lock) unfold (lock_inv_aux l.r l.gr v); GR.pts_to_injective_eq l.gr; GR.gather2 l.gr; - rewrite (if (1ul = 0ul) then v else emp) as emp; + with i. assert (pts_to l.gr i); + rewrite (if (i = 0ul) then v else emp) as emp; write_atomic_box l.r 0ul; GR.(l.gr := 0ul); fold (lock_inv_aux l.r l.gr v); @@ -194,7 +195,6 @@ fn gather (#v:slprop) (#p1 #p2 :perm) (l:lock) let gather2 #v l = gather #v #0.5R #0.5R l - fn free (#v:slprop) (l:lock) requires lock_alive l #1.0R v ** lock_acquired l ensures emp @@ -208,7 +208,9 @@ fn free (#v:slprop) (l:lock) B.free l.r; GR.gather l.gr; GR.free l.gr; - rewrite (if (1ul = 0ul) then v else emp) as emp + with i. assert (if (i = 0ul) then v else emp); // awkward + rewrite (if (i = 0ul) then v else emp) as emp; + () } diff --git a/lib/pulse/lib/Pulse.Lib.SpinLock.fsti b/lib/pulse/lib/Pulse.Lib.SpinLock.fsti index b1b395a95..e62a1db18 100644 --- a/lib/pulse/lib/Pulse.Lib.SpinLock.fsti +++ b/lib/pulse/lib/Pulse.Lib.SpinLock.fsti @@ -23,7 +23,7 @@ module T = FStar.Tactics.V2 val lock : Type0 val lock_alive - ([@@@equate_strict] l:lock) + ([@@@mkey] l:lock) (#[T.exact (`1.0R)] p:perm) (v:slprop) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.Stick.fsti b/lib/pulse/lib/Pulse.Lib.Stick.fsti index 5e6e64a25..88ff6759a 100644 --- a/lib/pulse/lib/Pulse.Lib.Stick.fsti +++ b/lib/pulse/lib/Pulse.Lib.Stick.fsti @@ -16,33 +16,31 @@ module Pulse.Lib.Stick -open Pulse.Lib.Core - -val stick : - (hyp : slprop) -> - (concl : slprop) -> - slprop - -let ( @==> ) : - (hyp : slprop) -> - (concl : slprop) -> - slprop - = stick - -val elim_stick - (hyp concl: slprop) -: stt_ghost unit emp_inames - ((hyp @==> concl) ** hyp) - (fun _ -> concl) - -val intro_stick - (hyp concl: slprop) +#lang-pulse +open Pulse + +val stick + ([@@@mkey] hyp : slprop) + ([@@@mkey] concl : slprop) + : slprop + +unfold +let ( @==> ) = stick + +ghost +fn elim_stick + (hyp concl : slprop) + requires (hyp @==> concl) ** hyp + ensures concl + +ghost +fn intro_stick + (hyp concl : slprop) (v: slprop) (f_elim: unit -> ( stt_ghost unit emp_inames (v ** hyp) (fun _ -> concl) )) -: stt_ghost unit emp_inames - v - (fun _ -> hyp @==> concl) + requires v + ensures hyp @==> concl diff --git a/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst b/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst index 429c1734c..4abbf35a2 100644 --- a/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst +++ b/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst @@ -22,7 +22,7 @@ open Pulse.Lib.Swap.Common #restart-solver #push-options "--z3rlimit_factor 6" - +#set-options "--print_full_names" #restart-solver inline_for_extraction noextract [@@noextract_to "krml"] @@ -87,7 +87,6 @@ fn slice_swap_aux(#t: Type0) (a: S.slice t) (mb: (mb: SZ.t {0 < SZ.v mb /\ SZ.v pi := i'; () }; - () } #pop-options diff --git a/lib/pulse/lib/Pulse.Lib.Task.fst b/lib/pulse/lib/Pulse.Lib.Task.fst index f476dac5d..3db742a1a 100644 --- a/lib/pulse/lib/Pulse.Lib.Task.fst +++ b/lib/pulse/lib/Pulse.Lib.Task.fst @@ -49,7 +49,7 @@ let v (s : task_state) : int = | Running -> 1 | Done -> 2 | Claimed -> 3 - + let p_st : preorder task_state = fun x y -> b2t (v x <= v y) let anchor_rel : FRAP.anchor_rel p_st = @@ -69,7 +69,7 @@ let anchor_rel_refl (x:task_state) : let state_res (pre : slprop) (post : slprop) - (g_state : AR.ref task_state p_st anchor_rel) + ([@@@mkey] g_state : AR.ref task_state p_st anchor_rel) (st : task_state) = match st with @@ -101,7 +101,7 @@ type task_t : Type0 = { let state_pred (pre : slprop_ref) (post : slprop_ref) - (h : handle) + ([@@@mkey] h : handle) : slprop = exists* (v_state : task_state). pts_to @@ -140,6 +140,7 @@ ghost fn task_thunk_typing_dup t instance task_thunk_typing_duplicable t : duplicable (task_thunk_typing t) = { dup_f = fun _ -> task_thunk_typing_dup t } +[@@no_mkeys] (* usually there's only a single instance *) let rec all_state_pred ( v_runnable : list task_t) : slprop @@ -395,9 +396,10 @@ fn rec extract_state_pred { add_one_state_pred t' ts'; }; - intro_trade (state_pred t.pre t.post t.h) (all_state_pred ts) - (pure (ts == t'::ts') ** task_thunk_typing t' ** all_state_pred ts') aux; - + intro_trade + (state_pred t.pre t.post t.h) (all_state_pred ts) + (pure (ts == t::ts') ** task_thunk_typing t ** all_state_pred ts') + aux; () } } @@ -511,8 +513,10 @@ fn spawn (p:pool) post = post_ref; thunk = Dyn.mkdyn f; }; - dup (slprop_ref_pts_to post_ref post) (); - dup (slprop_ref_pts_to pre_ref pre) (); + rewrite each pre_ref as task.pre; + rewrite each post_ref as task.post; + dup (slprop_ref_pts_to task.pre pre) (); + dup (slprop_ref_pts_to task.post post) (); fold task_thunk_typing_core task pre post; fold task_thunk_typing task; @@ -611,7 +615,7 @@ fn try_await AR.drop_anchor p.g_runnable; recall_task_spotted p t #v_runnable; AR.lift_anchor p.g_runnable _; - + extract_state_pred p t #v_runnable; let v_state = elim_state_pred t.pre t.post t.h; @@ -619,7 +623,7 @@ fn try_await rewrite (pts_to t.h.state #(if Running? v_state then 0.5R else 1.0R) (unclaimed (reveal v_state))) as (pts_to h.state #(if Running? v_state then 0.5R else 1.0R) (unclaimed (reveal v_state))); let task_st = !h.state; - + match task_st { Ready -> { (* NOOP *) @@ -650,25 +654,16 @@ fn try_await Done -> { (* First prove that ghost state cannot be Claimed, due to the anchor *) - rewrite (AR.pts_to t.h.g_state v_state) - as (AR.pts_to h.g_state v_state); - assert (AR.pts_to h.g_state v_state); - assert (AR.anchored h.g_state Ready); - AR.recall_anchor h.g_state Ready; + rewrite each h as t.h; + AR.recall_anchor t.h.g_state Ready; assert (pure (v_state =!= Claimed)); assert (pure (v_state == Done)); - rewrite (AR.pts_to h.g_state v_state) - as (AR.pts_to t.h.g_state v_state); (* Now claim it *) claim_done_task #p #(up t.pre) #(up t.post) t.h; gtrade_elim (up t.post ** later_credit 1) post; - rewrite (post) - as (if true then post else joinable p post h); - - rewrite (pts_to h.state Done) - as (pts_to t.h.state (unclaimed Claimed)); + intro_state_pred t.pre t.post t.h Claimed; elim_trade _ _; // undo extract_state_pred fold (lock_inv p.runnable p.g_runnable); @@ -692,6 +687,7 @@ let handle_done (h:handle) : slprop = let task_done (t : task_t) : slprop = handle_done t.h +[@@no_mkeys] (* usually there's only a single instance *) let rec all_tasks_done (ts : list task_t) = match ts with | [] -> emp @@ -818,6 +814,7 @@ fn disown_aux match st { Done -> { + rewrite each h as t.h; rewrite (state_res (up t.pre) (up t.post) t.h.g_state Done) as up t.post; @@ -843,6 +840,7 @@ fn disown_aux } Claimed -> { assert (AR.anchored h.g_state Ready); + rewrite each h as t.h; AR.recall_anchor t.h.g_state Ready; unreachable(); } @@ -904,9 +902,14 @@ fn await (#p:pool) (if v_done then post else joinable p post h) ** pure (b == not v_done) { + with v_done. assert (pts_to done v_done); + rewrite each v_done as false; let b = try_await #p #post h #f; done := b; }; + with v_done. assert (pts_to done v_done); + rewrite each v_done as true; + () } ghost @@ -1022,15 +1025,14 @@ fn weaken_vopt (#a:Type0) (o : option a) { match o { None -> { - unfold (vopt None p1); - fold (vopt None p2); + rewrite vopt None p1 as vopt o p2; drop_ extra; () } Some v -> { - rewrite (vopt o p1) as p1 v; + unfold vopt (Some v) p1; f v; - fold (vopt o p2); + rewrite p2 v as vopt o p2; } } } @@ -1109,7 +1111,9 @@ fn rec grab_work' (p:pool) up t.pre ** pts_to t.h.state #0.5R Running ** task_spotted p t ** task_thunk_typing t) { unfold (lock_inv p.runnable p.g_runnable); + with v_runnable0. assert (pts_to p.runnable v_runnable0); let v_runnable = !p.runnable; + rewrite each v_runnable0 as v_runnable; let topt = grab_work'' p v_runnable; AR.take_snapshot_full p.g_runnable; @@ -1212,11 +1216,9 @@ fn do_work_once (#f:perm) (p : pool) let topt = grab_work p; match topt { None -> { - rewrite (if Some? topt then up (Some?.v topt).pre else emp) - as emp; + unfold (vopt #task_t); } Some t -> { - rewrite each topt as Some t; get_vopt #task_t #t (); perf_work t; put_back_result p t @@ -1251,12 +1253,18 @@ fn await_help (if v_done then post else joinable p post h) ** pure (b == not v_done) { + with v_done. assert (pts_to done v_done); + rewrite each v_done as false; let b = try_await #p #post h #f; done := b; if (not b) { do_work_once #f p; } }; + with v_done. + assert (pts_to done v_done); + rewrite each v_done as true; + (); } let ite (b:bool) (p q : slprop) : slprop = @@ -1282,7 +1290,7 @@ fn rec check_if_all_done Done -> { let bb = check_if_all_done ts'; if bb { - rewrite (ite bb (all_tasks_done ts') emp) as (all_tasks_done ts'); + rewrite ite true (all_tasks_done ts') emp as (all_tasks_done ts'); with g_st. assert (AR.pts_to t.h.g_state g_st); assert (pure (g_st == Done \/ g_st == Claimed)); AR.take_snapshot t.h.g_state; @@ -1293,7 +1301,7 @@ fn rec check_if_all_done add_one_state_pred t ts'; true; } else { - drop_ (ite bb (all_tasks_done ts') emp); + drop_ (ite false (all_tasks_done ts') emp); fold (state_pred t.pre t.post t.h); add_one_state_pred t ts'; rewrite emp as ite false (all_tasks_done ts) emp; @@ -1411,9 +1419,8 @@ fn rec teardown_pool let runnable = !p.runnable; let b = check_if_all_done runnable; + unfold ite; if b { - rewrite ite b (all_tasks_done runnable) emp - as all_tasks_done runnable; AR.drop_anchor p.g_runnable; AR.share p.g_runnable; fold (pool_done p); @@ -1427,8 +1434,6 @@ fn rec teardown_pool drop_ (lock_alive _ #0.5R _); drop_ (lock_acquired p.lk); } else { - rewrite ite b (all_tasks_done runnable) emp - as emp; (* Spin *) fold (lock_inv p.runnable p.g_runnable); release p.lk; diff --git a/lib/pulse/lib/Pulse.Lib.Vec.fsti b/lib/pulse/lib/Pulse.Lib.Vec.fsti index 5319c548e..efb7c18a6 100644 --- a/lib/pulse/lib/Pulse.Lib.Vec.fsti +++ b/lib/pulse/lib/Pulse.Lib.Vec.fsti @@ -39,7 +39,7 @@ val is_full_vec (#a:Type0) (v:vec a) : prop val pts_to (#a:Type0) - ([@@@equate_strict] v:vec a) + ([@@@mkey] v:vec a) (#[T.exact (`1.0R)] p:perm) (s:Seq.seq a) : slprop diff --git a/lib/pulse/lib/class/Pulse.Class.PtsTo.fst b/lib/pulse/lib/class/Pulse.Class.PtsTo.fst index b992d396d..f0b86be63 100644 --- a/lib/pulse/lib/class/Pulse.Class.PtsTo.fst +++ b/lib/pulse/lib/class/Pulse.Class.PtsTo.fst @@ -21,4 +21,4 @@ let ( |-> ) #p #r {| has_pts_to p r |} = pts_to #p #r [@@pulse_unfold] instance pts_to_erased (p r : Type) (_ : has_pts_to p r) : has_pts_to p (erased r) = { pts_to = (fun r #f v -> pts_to r #f (reveal v)); -} \ No newline at end of file +} diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fst b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fst index 67aa760af..c9a9ab884 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fst +++ b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fst @@ -21,7 +21,7 @@ open Pulse.Lib.Pervasives module P = Pulse.Lib.Pledge -let pledge (f:slprop) (v:slprop) : slprop = +let pledge ([@@@mkey] f:slprop) ([@@@mkey] v:slprop) : slprop = exists* is. P.pledge is f v (* Anything that holds now holds in the future too. *) diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fsti b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fsti index 754de7e8a..b886f9d0f 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fsti +++ b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.Simple.fsti @@ -23,7 +23,7 @@ are not indexed by invariants. The actual invariants are existentially quantified inside the Simple.pledge slprop, and we provide effectful operations to manipulate them. *) -val pledge (f:slprop) (v:slprop) : slprop +val pledge ([@@@mkey] f:slprop) ([@@@mkey] v:slprop) : slprop (* An unobservable step to rewrite the context. *) // let ustep (is:invlist) (p q : slprop) diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst index 3861aa0eb..f341bccee 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst +++ b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst @@ -285,19 +285,22 @@ fn squash_pledge' (* A big chunk follows for split_pledge *) +[@@no_mkeys] +let split_switch (is : inames) (b1 b2 : bool) (f v1 v2 : slprop) : slprop = + match b1, b2 with + | false, false -> pledge is f (v1 ** v2) + | false, true -> v1 + | true, false -> v2 + | true, true -> emp + let inv_p' (is:inames) (f v1 v2 : slprop) (r1 r2 : GR.ref bool) (b1 b2 : bool) = GR.pts_to r1 #0.5R b1 ** GR.pts_to r2 #0.5R b2 - ** (match b1, b2 with - | false, false -> pledge is f (v1 ** v2) - | false, true -> v1 - | true, false -> v2 - | true, true -> emp) + ** split_switch is b1 b2 f v1 v2 let inv_p (is:inames) (f v1 v2 : slprop) (r1 r2 : GR.ref bool) : slprop = exists* b1 b2. inv_p' is f v1 v2 r1 r2 b1 b2 - ghost fn do_elim_body_l (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) (r1 r2 : GR.ref bool) @@ -323,16 +326,8 @@ fn do_elim_body_l by the other subpledge, so we just extract our resource. *) assert (pts_to r1 false); r1 := true; - rewrite emp ** (match false, true with - | false, false -> pledge is f (v1 ** v2) - | false, true -> v1 - | true, false -> v2 - | true, true -> emp) - as (match true, true with - | false, false -> pledge is f (v1 ** v2) - | false, true -> v1 - | true, false -> v2 - | true, true -> emp) ** v1; + rewrite emp ** split_switch is false true f v1 v2 + as split_switch is true true f v1 v2 ** v1; (* This should just disappear when we start normalizing the context. *) @@ -353,16 +348,13 @@ fn do_elim_body_l Claim it, split it, and store the leftover in the invariant. *) assert (pts_to r1 false); - rewrite (match false, false with - | false, false -> pledge is f (v1 ** v2) - | false, true -> v1 - | true, false -> v2 - | true, true -> emp) - as pledge is f (v1 ** v2); + rewrite split_switch is false false f v1 v2 + as pledge is f (v1 ** v2); redeem_pledge is f (v1 ** v2); r1 := true; + fold (split_switch is true false f v1 v2); share2 r1; @@ -424,18 +416,8 @@ fn flip_invp let _ = elim_slprop_equiv (slprop_equiv_comm v1 v2); assert (pure (v1 ** v2 == v2 ** v1)); - rewrite - (match b1, b2 with - | false, false -> pledge is f (v1 ** v2) - | false, true -> v1 - | true, false -> v2 - | true, true -> emp) - as - (match b2, b1 with - | false, false -> pledge is f (v2 ** v1) - | false, true -> v2 - | true, false -> v1 - | true, true -> emp) + rewrite split_switch is b1 b2 f v1 v2 + as split_switch is b2 b1 f v2 v1 by __tac (); fold (inv_p' is f v2 v1 r2 r1 b2 b1); @@ -503,7 +485,7 @@ fn ghost_split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) let r2 = GR.alloc false; GR.share2 r1; GR.share2 r2; - + fold split_switch is false false f v1 v2; fold (inv_p' is f v1 v2 r1 r2 false false); fold inv_p; let i = fresh_invariant is (inv_p is f v1 v2 r1 r2); diff --git a/lib/pulse/lib/pledge/Pulse.Lib.SmallTrade.fst b/lib/pulse/lib/pledge/Pulse.Lib.SmallTrade.fst index 3825d9919..ebea55656 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.SmallTrade.fst +++ b/lib/pulse/lib/pledge/Pulse.Lib.SmallTrade.fst @@ -33,7 +33,11 @@ let trade_elim_exists (is:inames) (hyp:slprop) (extra:small_slprop) (concl:slpro let __trade (#is:inames) (hyp concl:slprop) : small_slprop = exists* (extra:small_slprop). extra ** trade_elim_exists is hyp extra concl -let trade #is hyp concl : slprop = __trade #is hyp concl +let trade (#is : inames) + ([@@@mkey] hyp : slprop) + ([@@@mkey] concl : slprop) + : slprop + = __trade #is hyp concl let trade_is_timeless (#is:inames) (hyp concl:slprop) : Lemma (timeless (trade #is hyp concl)) = () diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst index fd23d5728..dd724977e 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst +++ b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst @@ -102,6 +102,7 @@ fn elim_trade_aux { let res = deconstruct_trade is hyp concl; let f = dsnd res; + rewrite dfst res as res._1; f () } @@ -126,6 +127,7 @@ fn trade_sub_inv_aux opens is2 { let f = dsnd res; + rewrite dfst res as res._1; f () }; From a4a31bea67a1a4241be9d8ea28bb5f01e1a9ba7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 14 Feb 2025 21:24:34 -0800 Subject: [PATCH 05/32] Update tests --- test/ArrayTests.fst | 2 + test/Example.Hashtable.fst | 9 +- test/MatchRW.fst | 2 +- test/Matches.fst | 11 ++- test/Test.Basic1.fst | 2 + test/Test.ReflikeClass.fst | 1 - test/bug-reports/RecordWithRefs.fst | 4 +- test/nolib/NewMatch.fst | 123 ++++++++++++++++++++++++++++ test/nolib/NoRewrite.fst | 4 +- test/nolib/Test.Matcher.fst | 40 +-------- test/nolib/TupleFun.fst | 4 +- 11 files changed, 148 insertions(+), 54 deletions(-) create mode 100644 test/nolib/NewMatch.fst diff --git a/test/ArrayTests.fst b/test/ArrayTests.fst index f6265437c..e5445bcd1 100644 --- a/test/ArrayTests.fst +++ b/test/ArrayTests.fst @@ -409,7 +409,9 @@ fn test_local_array0 () let v2 = V.alloc 0 2sz; let a2 = V.vec_to_array v2; V.to_array_pts_to v2; + rewrite each V.vec_to_array v2 as a2; // BAD let b = compare 2sz a1 a2; + rewrite each a2 as V.vec_to_array v2; // BAD V.to_vec_pts_to v2; V.free v2; b diff --git a/test/Example.Hashtable.fst b/test/Example.Hashtable.fst index c248ab7c1..144956078 100644 --- a/test/Example.Hashtable.fst +++ b/test/Example.Hashtable.fst @@ -12,12 +12,11 @@ fn insert_lookup_and_replace () ensures emp { let h = alloc #SizeT.t #data hash 100sz; - let r = insert h 1sz { left = true; right = false }; let h = r._1; - let r = lookup h 1sz; let h = r._1; - match r._2 { + let h, _ = insert h 1sz { left = true; right = false }; + let h, found = lookup h 1sz; + match found { Some i -> { - let r = replace h i 1sz { left = false; right = true } (magic ()); - let h = r._1; + let h, _ = replace h i 1sz { left = false; right = true } (magic ()); dealloc h } None -> { diff --git a/test/MatchRW.fst b/test/MatchRW.fst index bc767cd0f..f224631bf 100644 --- a/test/MatchRW.fst +++ b/test/MatchRW.fst @@ -4,7 +4,7 @@ module MatchRW open Pulse.Lib.Pervasives assume -val p ([@@@equate_strict] b : bool) : slprop +val p ([@@@mkey] b : bool) : slprop assume val q : slprop diff --git a/test/Matches.fst b/test/Matches.fst index 7abb2e934..e604d4d57 100644 --- a/test/Matches.fst +++ b/test/Matches.fst @@ -43,7 +43,9 @@ fn test1 (#t:_) (x:t) (l:list t) unfold (is_deque_suffix_factored_next (x::l)); match l { y :: ys -> { - fold (is_deque_suffix_factored_next (x::l)); + // fold (is_deque_suffix_factored_next (x::l)); + rewrite emp + as (is_deque_suffix_factored_next (x::l)); } } } @@ -58,10 +60,13 @@ fn test2 (#t:_) (x:t) (l:list t) unfold (is_deque_suffix_factored_next (x::l)); match l { y :: ys -> { - fold (is_deque_suffix_factored_next (x::l)); + // fold (is_deque_suffix_factored_next (x::l)); + rewrite emp + as (is_deque_suffix_factored_next (x::l)); } [] -> { - fold (is_deque_suffix_factored_next (x::l)); + rewrite emp + as is_deque_suffix_factored_next (x::l); } } } diff --git a/test/Test.Basic1.fst b/test/Test.Basic1.fst index 6b80ecc3f..68eb17388 100644 --- a/test/Test.Basic1.fst +++ b/test/Test.Basic1.fst @@ -33,12 +33,14 @@ assume val foo9 : slprop assume val foo10 : slprop +#push-options "--no_smt" fn test_synt () requires foo1 ** foo2 ** foo3 ** foo4 ** foo5 ** foo6 ** foo7 ** foo8 ** foo9 ** foo10 ensures foo10 ** foo9 ** foo8 ** foo7 ** foo6 ** foo5 ** foo4 ** foo3 ** foo2 ** foo1 { (); } +#pop-options (* Similar example, but all the heads match so we would attempt to use SMT if we didn't diff --git a/test/Test.ReflikeClass.fst b/test/Test.ReflikeClass.fst index e2f7d8df9..bf4485ff9 100644 --- a/test/Test.ReflikeClass.fst +++ b/test/Test.ReflikeClass.fst @@ -13,7 +13,6 @@ class reflike (vt:Type) (rt:Type) = { (:=) : r:rt -> v:vt -> #v0:erased vt -> stt unit (r |-> v0) (fun _ -> r |-> v); } -// [@@pulse_unfold] instance reflike_ref (a:Type) : reflike a (ref a) = { ( |-> ) = (fun r v -> Pulse.Lib.Reference.pts_to r v); alloc = Pulse.Lib.Reference.alloc; diff --git a/test/bug-reports/RecordWithRefs.fst b/test/bug-reports/RecordWithRefs.fst index 853230b18..a9d0f969d 100644 --- a/test/bug-reports/RecordWithRefs.fst +++ b/test/bug-reports/RecordWithRefs.fst @@ -33,7 +33,7 @@ let fst (p:u8_pair_repr) : U8.t = let snd (p:u8_pair_repr) : U8.t = let (_, x) = p in x -let u8_pair_pred (p:u8_pair) (v:u8_pair_repr) : slprop = +let u8_pair_pred ([@@@mkey]p:u8_pair) (v:u8_pair_repr) : slprop = R.pts_to p.a (fst v) ** R.pts_to p.b (snd v) @@ -131,6 +131,6 @@ fn swap_pair_alt3 (p: u8_pair) (#v: erased u8_pair_repr) p.a := y; p.b := x; - fold_u8_pair_pred p + fold_u8_pair_pred p; } diff --git a/test/nolib/NewMatch.fst b/test/nolib/NewMatch.fst new file mode 100644 index 000000000..ffb030a4f --- /dev/null +++ b/test/nolib/NewMatch.fst @@ -0,0 +1,123 @@ +module NewMatch + +#lang-pulse + +open Pulse.Nolib + +assume +val foo : [@@@mkey]_:int -> slprop + +[@@no_mkeys] +assume +val foo2_nokey + (k : int) + (v : int) + : slprop + +assume +val foo2 + ([@@@mkey] k : int) + (v : int) + : slprop + +fn h () + requires foo 3 + ensures foo 103 +{ + admit(); +} + +fn test0 (x y z : int) + requires foo x ** pure (x == 3) + ensures foo 103 +{ + rewrite each x as 3; + h (); +} + +[@@expect_failure] // we won't try to ask the SMT if x==3 +fn test1 (x y z : int) + requires foo x ** pure (x == 3) + ensures foo 103 +{ + h (); +} + +// reduction still works, of course +fn test2 (x y z : int) + requires foo (1+2) + ensures foo 103 +{ + h (); +} + +// No keys on foo2_nokey means we try to match occurrences of this predicate, +// and discharge a query. +fn test3 (x y z : int) + requires foo2_nokey x y ** pure (y == z) + ensures foo2_nokey x z +{ + () +} + +// But if there are several, then it's ambiguous +[@@expect_failure] +fn test3' (x y z : int) + requires foo2_nokey 1 z ** foo2_nokey x y ** pure (y == z) + ensures foo2_nokey 1 y ** foo2_nokey x z +{ + () +} +// unless... x has been marked as a key, in which +// case the expectation is that there cannot be two distinct y,z +// such that `foo2 x y` and `foo2 x z` are both true, so we +// commit to proving that `y == z` (i.e. log that as a guard ) and carry on +// checking. +fn test4 (x y z : int) + requires foo2 x y ** pure (y == z) + ensures foo2 x z +{ + () +} + +// two key matches is ambiguous, should reject +[@@expect_failure] +fn test5 (x y z w u : int) + requires foo2 x w ** foo2 x y ** pure (y == z) ** pure (u == w) + ensures foo2 x z ** foo2 x u +{ + // rewrite foo2 x w as foo2 x u; + () +} + +// This works since, after rewriting, foo2 x u gets syntactically +// matched and we are left with only foo2 x y |- foo2 x z +fn test6 (x y z w u : int) + requires foo2 x w ** foo2 x y ** pure (y == z) ** pure (u == w) + ensures foo2 x z ** foo2 x u +{ + rewrite foo2 x w as foo2 x u; + () +} + +fn flip2 () (#x #y : int) + requires foo2 x y + ensures foo2 y x +{ admit() } + +fn test7 (x y z w u : int) + requires foo2 x y + ensures foo2 y x +{ + flip2 (); + () +} + +[@@expect_failure] +fn test8 (x y z w u : int) + requires foo2 x y ** foo2 w z + ensures foo2 y x ** foo2 w z +{ + flip2 (); + () +} diff --git a/test/nolib/NoRewrite.fst b/test/nolib/NoRewrite.fst index b4310ce39..1da2533d4 100644 --- a/test/nolib/NoRewrite.fst +++ b/test/nolib/NoRewrite.fst @@ -3,7 +3,7 @@ module NoRewrite #lang-pulse open Pulse.Nolib -assume val foo : [@@@equate_strict]_:int -> slprop +assume val foo : [@@@mkey]_:int -> slprop fn test1 (x : int) requires foo x @@ -29,7 +29,7 @@ fn test2 (x : int) } } -assume val bar : [@@@equate_strict]_:option int -> slprop +assume val bar : [@@@mkey]_:option int -> slprop fn test3 (x : option int{Some? x}) requires bar x diff --git a/test/nolib/Test.Matcher.fst b/test/nolib/Test.Matcher.fst index d4f89d6bd..24d8346b6 100644 --- a/test/nolib/Test.Matcher.fst +++ b/test/nolib/Test.Matcher.fst @@ -12,7 +12,7 @@ open FStar.Tactics.V2 assume val dref (a : Type0) : Type0 assume val dpts_to (#a:Type0) - (r:dref a) + ([@@@mkey] r:dref a) (#[exact (`1.0R)] p : perm) (v : erased a) : slprop @@ -43,7 +43,7 @@ assume val fref (a : Type0) : Type0 assume val fpts_to (#a:Type0) (r:fref a) - (#[exact (`1.0R)][@@@equate_strict] p : perm) + (#[exact (`1.0R)][@@@mkey] p : perm) (v : erased a) : slprop @@ -62,43 +62,7 @@ fn f_basic_id (r:fref int) [@@expect_failure] // fastunif will not commute nor generate guards - fn f_basic_perm_comm (r:fref int) (p:perm) requires fpts_to r #(p +. 0.1R) 1 ensures fpts_to r #(0.1R +. p) 1 { (); } - - - -(******* Syntactic matchin on the permission. *) -(* What's a concrete difference with _strict, since both sides -are already in normal form? *) -assume val sref (a : Type0) : Type0 -assume val spts_to - (#a:Type0) - (r:sref a) - (#[exact (`1.0R)][@@@equate_syntactic] p : perm) - (v : erased a) - : slprop - - -fn s_basic_self (r:sref int) - requires spts_to r 1 - ensures spts_to r 1 -{ (); } - - - -fn s_basic_id (r:sref int) - requires spts_to (id r) 1 - ensures spts_to r 1 -{ (); } - - -[@@expect_failure] // fastunif will not commute nor generate guards - -fn s_basic_perm_comm (r:sref int) (p:perm) - requires spts_to r #(p +. 0.1R) 1 - ensures spts_to r #(p +. 0.10R) 1 -{ (); } - diff --git a/test/nolib/TupleFun.fst b/test/nolib/TupleFun.fst index 45f970944..b6acb96a5 100644 --- a/test/nolib/TupleFun.fst +++ b/test/nolib/TupleFun.fst @@ -3,8 +3,8 @@ module TupleFun #lang-pulse open Pulse.Nolib -assume val foo : [@@@equate_strict]_:int -> slprop -assume val bar : [@@@equate_strict] int -> slprop +assume val foo : int -> slprop +assume val bar : int -> slprop fn usefoo (x:int) requires foo x From adc7417951a5f362c762947828ec1b08630e8e17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 14 Feb 2025 21:24:43 -0800 Subject: [PATCH 06/32] Update examples --- share/pulse/examples/MSort.Base.fst | 5 ++- .../pulse/examples/PulseCorePaper.S2.Lock.fst | 5 +++ share/pulse/examples/Quicksort.Task.fst | 42 ++++++++++--------- share/pulse/examples/ZetaHashAccumulator.fst | 4 +- .../by-example/PulseTutorial.LinkedList.fst | 4 +- .../PulseTutorial.PCMParallelIncrement.fst | 2 +- .../PulseTutorial.ParallelIncrement.fst | 5 +-- .../PulseTutorial.UserDefinedPredicates.fst | 5 +-- .../examples/dice/cbor/CBOR.Pulse.Extern.fsti | 2 +- share/pulse/examples/dice/cbor/CBOR.Pulse.fst | 9 +++- share/pulse/examples/dice/cbor/CDDL.Pulse.fst | 18 ++++++-- .../examples/dice/dpe/DPE.Messages.Parse.fst | 4 ++ share/pulse/examples/parallel/ParallelFor.fst | 3 ++ .../examples/parallel/Promises.Examples3.fst | 10 +++-- .../examples/parallel/TaskPool.Examples.fst | 4 ++ 15 files changed, 81 insertions(+), 41 deletions(-) diff --git a/share/pulse/examples/MSort.Base.fst b/share/pulse/examples/MSort.Base.fst index 8b4ec1dd5..bf751b35c 100644 --- a/share/pulse/examples/MSort.Base.fst +++ b/share/pulse/examples/MSort.Base.fst @@ -74,7 +74,6 @@ copy_array } - fn merge_impl (a : array int) (lo mid hi : SZ.t) @@ -97,9 +96,11 @@ merge_impl let sw1_v = V.alloc 0 (mid `SZ.sub` lo); let sw1 = V.vec_to_array sw1_v; V.to_array_pts_to sw1_v; + rewrite each V.vec_to_array sw1_v as sw1; let sw2_v = V.alloc 0 (hi `SZ.sub` mid); let sw2 = V.vec_to_array sw2_v; V.to_array_pts_to sw2_v; + rewrite each V.vec_to_array sw2_v as sw2; pts_to_range_intro sw1 1.0R (S.create (SZ.v l1) 0); copy_array a sw1 lo 0sz (mid `SZ.sub` lo); @@ -194,8 +195,10 @@ merge_impl } }; + rewrite each sw1 as V.vec_to_array sw1_v; V.to_vec_pts_to sw1_v; V.free sw1_v; + rewrite each sw2 as V.vec_to_array sw2_v; V.to_vec_pts_to sw2_v; V.free sw2_v; } diff --git a/share/pulse/examples/PulseCorePaper.S2.Lock.fst b/share/pulse/examples/PulseCorePaper.S2.Lock.fst index 832715b54..16c4edf02 100644 --- a/share/pulse/examples/PulseCorePaper.S2.Lock.fst +++ b/share/pulse/examples/PulseCorePaper.S2.Lock.fst @@ -82,8 +82,13 @@ ensures protects l p ** p ensures later (lock_inv l.r p) ** (if retry then emp else p) { later_elim _; + with v. assert (pts_to l.r v); let b = cas_box_alt l.r 0ul 1ul; if b { + assert (pure True); + // ^ Should not be needed! Looks like we're not eliminating + // pure slprops into the ctx before a rewrite. + rewrite each v as 0ul; assert p; later_intro (lock_inv l.r p); false diff --git a/share/pulse/examples/Quicksort.Task.fst b/share/pulse/examples/Quicksort.Task.fst index 5ec3ac250..b8b9cb79c 100644 --- a/share/pulse/examples/Quicksort.Task.fst +++ b/share/pulse/examples/Quicksort.Task.fst @@ -27,10 +27,6 @@ open Pulse.Lib.Pledge let quicksort_post a lo hi s0 lb rb : slprop = exists* s. (A.pts_to_range a lo hi s ** pure (pure_post_quicksort a lo hi lb rb s0 s)) -let p31 (x,y,z) = x -let p32 (x,y,z) = y -let p33 (x,y,z) = z - fn rec t_quicksort (p : T.pool) (#f : perm) @@ -51,21 +47,26 @@ fn rec t_quicksort if (lo < hi - 1) { let r = partition_wrapper a lo hi lb rb; - let pivot = p33 r; - with s1. assert (A.pts_to_range a lo r._1 s1); - with s2. assert (A.pts_to_range a r._1 r._2 s2); - with s3. assert (A.pts_to_range a r._2 hi s3); + let Mktuple3 p31 p32 pivot = r; + rewrite each r._1 as p31; + rewrite each r._2 as p32; + rewrite each r._3 as pivot; + // ^FIXME: would be nicer to rewrite r as (p31, p32, pivot) but projectors don't unfold + with s1. assert (A.pts_to_range a lo p31 s1); + with s2. assert (A.pts_to_range a p31 p32 s2); + with s3. assert (A.pts_to_range a p32 hi s3); T.share_alive p f; - T.spawn_ p #(f /. 2.0R) (fun () -> t_quicksort p #(f /. 2.0R) a lo (p31 r) #lb #pivot); - t_quicksort p #(f /. 2.0R) a (p32 r) hi #pivot #rb; - - return_pledge (T.pool_done p) (A.pts_to_range a r._1 r._2 s2); + T.spawn_ p #(f /. 2.0R) (fun () -> t_quicksort p #(f /. 2.0R) a lo p31 #lb #pivot); + rewrite each iname_list [] as emp_inames; // FIXME + t_quicksort p #(f /. 2.0R) a p32 hi #pivot #rb; + + return_pledge (T.pool_done p) (A.pts_to_range a p31 p32 s2); squash_pledge _ _ _; (* disambiguating makes this pretty inconvenient now, but it is robust at least... *) - join_pledge (T.pool_alive #(f /. 2.0R) p ** quicksort_post a lo r._1 s1 lb pivot) (A.pts_to_range a r._1 r._2 s2); - join_pledge _ (T.pool_alive #(f /. 2.0R) p ** quicksort_post a r._2 hi s3 pivot rb); + join_pledge (T.pool_alive #(f /. 2.0R) p ** quicksort_post a lo p31 s1 lb pivot) (A.pts_to_range a p31 p32 s2); + join_pledge _ (T.pool_alive #(f /. 2.0R) p ** quicksort_post a p32 hi s3 pivot rb); ghost fn rewrite_pf () // NB: These two slprops have to be in exactly this shape, as the Pulse checker @@ -73,17 +74,17 @@ fn rec t_quicksort // above must also be in this exact shape. To obtain the shape, I just manually looked // at the context. Automation should likely help here. requires - (T.pool_alive #(f /. 2.0R) p ** quicksort_post a lo r._1 s1 lb pivot) ** - A.pts_to_range a r._1 r._2 s2 ** - (T.pool_alive #(f /. 2.0R) p ** quicksort_post a r._2 hi s3 pivot rb) + (T.pool_alive #(f /. 2.0R) p ** quicksort_post a lo p31 s1 lb pivot) ** + A.pts_to_range a p31 p32 s2 ** + (T.pool_alive #(f /. 2.0R) p ** quicksort_post a p32 hi s3 pivot rb) ensures T.pool_alive #f p ** quicksort_post a lo hi s0 lb rb { (* Functional correctness *) - unfold (quicksort_post a lo r._1 s1 lb pivot); + unfold (quicksort_post a lo p31 s1 lb pivot); unfold quicksort_post; - quicksort_proof a lo r._1 r._2 hi lb rb pivot #s0 s1 s2 s3; + quicksort_proof a lo p31 p32 hi lb rb pivot #s0 s1 s2 s3; fold (quicksort_post a lo hi s0 lb rb); (* Permission accounting *) @@ -93,9 +94,10 @@ fn rec t_quicksort () } else { + fold (quicksort_post a lo hi s0 lb rb); return_pledge (T.pool_done p) ( T.pool_alive #f p ** - (exists* s. A.pts_to_range a lo hi s ** pure (pure_post_quicksort a lo hi lb rb s0 s)) + quicksort_post a lo hi s0 lb rb ); } } diff --git a/share/pulse/examples/ZetaHashAccumulator.fst b/share/pulse/examples/ZetaHashAccumulator.fst index 3a7c08f0e..396afed8d 100644 --- a/share/pulse/examples/ZetaHashAccumulator.fst +++ b/share/pulse/examples/ZetaHashAccumulator.fst @@ -169,7 +169,7 @@ type ha_core = { // and the code has to take care of potential overflow. So, at the spec // level we connect the nat and the concrete counter, indicating that // the counter hasn't overflowed yet. -let ha_val_core (core:ha_core) (h:hash_value_t) +let ha_val_core ([@@@mkey] core:ha_core) (h:hash_value_t) : slprop = A.pts_to core.acc (fst h) ** (exists* (n:U32.t). @@ -225,7 +225,7 @@ type ha = { // Again, we play the same game as with ha_core // A representation predicate for ha, encapsulating an ha_val_core -let ha_val (h:ha) (s:hash_value_t) = +let ha_val ([@@@mkey] h : ha) (s:hash_value_t) = ha_val_core h.core s ** (exists* (s:Seq.seq U8.t). A.pts_to h.tmp s ** pure (Seq.length s == 32)) ** A.pts_to h.dummy (Seq.create 1 0uy) diff --git a/share/pulse/examples/by-example/PulseTutorial.LinkedList.fst b/share/pulse/examples/by-example/PulseTutorial.LinkedList.fst index 66b88f7d0..3f314b438 100644 --- a/share/pulse/examples/by-example/PulseTutorial.LinkedList.fst +++ b/share/pulse/examples/by-example/PulseTutorial.LinkedList.fst @@ -314,8 +314,8 @@ ensures is_list x ('l1 @ 'l2) rewrite each _node as node; match node.tail { None -> { - is_list_case_none node.tail; - elim_is_list_nil node.tail; + is_list_case_none None; + elim_is_list_nil None; np := { node with tail = y }; rewrite each y as ({ node with tail = y }).tail in (is_list y 'l2); intro_is_list_cons x np; diff --git a/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst b/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst index 42e5d416d..2793333e3 100644 --- a/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst +++ b/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst @@ -81,7 +81,7 @@ let pcm_of (n:nat) = MS.pcm_of MS.nat_plus_cm n let tank (n:nat) = GPR.gref (pcm_of n) // A predicate asserting ownership of `i` units of the tank -let owns_tank_units #n (g:tank n) (i:nat) +let owns_tank_units #n ([@@@mkey] g : tank n) (i:nat) : timeless_slprop = GPR.pts_to #_ #(pcm_of n) g i diff --git a/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst b/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst index ddcb96cd4..e8776aec9 100644 --- a/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst +++ b/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst @@ -603,7 +603,7 @@ fn incr_pcm_t (r:ref int) (ghost_r:ghost_pcm_ref pcm) (l:L.lock) (t1:bool) (#n:i fold lock_inv_ghost; fold lock_inv_pcm; L.release l; - fold (t1_perm ghost_r (add_one n) t1) + fold (t1_perm ghost_r (add_one n) true); } else { rewrite (t1_perm ghost_r n t1) as (ghost_pcm_pts_to ghost_r (None, half n)); @@ -621,7 +621,7 @@ fn incr_pcm_t (r:ref int) (ghost_r:ghost_pcm_ref pcm) (l:L.lock) (t1:bool) (#n:i fold lock_inv_ghost; fold lock_inv_pcm; L.release l; - fold (t1_perm ghost_r (add_one n) t1) + fold (t1_perm ghost_r (add_one n) false) } } @@ -776,4 +776,3 @@ fn incr_pcm_abstract (r:ref int) L.free l; drop_ (ghost_pcm_pts_to ghost_r _) } - diff --git a/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst b/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst index bb4649ebf..c1bc5e798 100644 --- a/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst +++ b/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst @@ -144,12 +144,12 @@ ensures emp } +// FIXME, need to explain -let is_point_curry (p:point) ([@@@equate_by_smt] x:int) ([@@@equate_by_smt] y:int) = +let is_point_curry ([@@@mkey] p:point) (x y : int) = pts_to p.x x ** pts_to p.y y - fn move_curry (p:point) (dx:int) (dy:int) requires is_point_curry p 'x 'y ensures is_point_curry p ('x + dx) ('y + dy) @@ -162,4 +162,3 @@ ensures is_point_curry p ('x + dx) ('y + dy) fold is_point_curry; } - diff --git a/share/pulse/examples/dice/cbor/CBOR.Pulse.Extern.fsti b/share/pulse/examples/dice/cbor/CBOR.Pulse.Extern.fsti index a6f1d7053..1761b3fa5 100644 --- a/share/pulse/examples/dice/cbor/CBOR.Pulse.Extern.fsti +++ b/share/pulse/examples/dice/cbor/CBOR.Pulse.Extern.fsti @@ -370,7 +370,7 @@ val cbor_dummy_array_iterator: cbor_array_iterator_t val cbor_array_iterator_match (p: perm) - (i: cbor_array_iterator_t) + ([@@@mkey]i: cbor_array_iterator_t) (l: list Cbor.raw_data_item) : Tot slprop diff --git a/share/pulse/examples/dice/cbor/CBOR.Pulse.fst b/share/pulse/examples/dice/cbor/CBOR.Pulse.fst index 63e3da693..49bd32786 100644 --- a/share/pulse/examples/dice/cbor/CBOR.Pulse.fst +++ b/share/pulse/examples/dice/cbor/CBOR.Pulse.fst @@ -527,14 +527,19 @@ ensures unfold (cbor_map_get_invariant pmap vkey vmap map NotFound i l); elim_stick0 (); fold (cbor_map_get_post_not_found pmap vkey vmap map); - fold (cbor_map_get_post pmap vkey vmap map NotFound) + fold (cbor_map_get_post pmap vkey vmap map NotFound); + rewrite cbor_map_get_post pmap vkey vmap map NotFound + as cbor_map_get_post pmap vkey vmap map res; + () } Found value -> { rewrite (cbor_map_get_invariant pmap vkey vmap map gres i l) // FIXME: WHY WHY WHY? as (cbor_map_get_invariant pmap vkey vmap map (Found value) i l); unfold (cbor_map_get_invariant pmap vkey vmap map (Found value) i l); - fold (cbor_map_get_post pmap vkey vmap map (Found value)) + fold (cbor_map_get_post pmap vkey vmap map (Found value)); + rewrite cbor_map_get_post pmap vkey vmap map (Found value) + as cbor_map_get_post pmap vkey vmap map res; } } } diff --git a/share/pulse/examples/dice/cbor/CDDL.Pulse.fst b/share/pulse/examples/dice/cbor/CDDL.Pulse.fst index 521d2f754..59583fe21 100644 --- a/share/pulse/examples/dice/cbor/CDDL.Pulse.fst +++ b/share/pulse/examples/dice/cbor/CDDL.Pulse.fst @@ -332,6 +332,7 @@ fn impl_array_group3_item inline_for_extraction noextract [@@noextract_to "krml"] +#set-options "--print_full_names" fn impl_t_array (#b: Ghost.erased (option raw_data_item)) (#g: (array_group3 b)) @@ -350,10 +351,12 @@ fn impl_t_array let mut pi = i; let b_success = ig pi; with gi' l' . assert (cbor_array_iterator_match p gi' l'); + with i'0. assert (pi |-> i'0); let i' = ! pi; rewrite (cbor_array_iterator_match p gi' l') as (cbor_array_iterator_match p i' l'); let b_end = cbor_array_iterator_is_done i'; rewrite (cbor_array_iterator_match p i' l') as (cbor_array_iterator_match p gi' l'); + rewrite each i'0 as i'; // FIXME, should not be needed elim_stick0 () #(cbor_array_iterator_match p i' l'); rewrite (cbor_array_iterator_match p (Ghost.reveal (Ghost.hide i)) l) as (cbor_array_iterator_match p i l); elim_stick0 (); @@ -588,7 +591,10 @@ ensures cbor_read_deterministically_encoded_with_typ_post t a p va res let test = ft res.cbor_read_payload; if (test) { fold (cbor_read_deterministically_encoded_with_typ_success_post t a p va res); - fold (cbor_read_deterministically_encoded_with_typ_post t a p va res); + rewrite (cbor_read_deterministically_encoded_with_typ_success_post t a p va res) + as (cbor_read_deterministically_encoded_with_typ_post t a p va res); + // fold (cbor_read_deterministically_encoded_with_typ_post t a p va res); + // FIXME: This fold won't work without SMT, it needs to equate a match with a named slprop. res } else { with v . assert (raw_data_item_match 1.0R res.cbor_read_payload v); @@ -598,14 +604,20 @@ ensures cbor_read_deterministically_encoded_with_typ_post t a p va res #(raw_data_item_match 1.0R res.cbor_read_payload v ** pts_to res.cbor_read_remainder #p vrem); let res = mk_cbor_read_error res; fold (cbor_read_deterministically_encoded_with_typ_error_post t a p va); - fold (cbor_read_deterministically_encoded_with_typ_post t a p va res); + rewrite (cbor_read_deterministically_encoded_with_typ_error_post t a p va) + as (cbor_read_deterministically_encoded_with_typ_post t a p va res); + // fold (cbor_read_deterministically_encoded_with_typ_post t a p va res); + // idem res } } else { rewrite (cbor_read_deterministically_encoded_post a p va res) as (cbor_read_deterministically_encoded_error_post a p va); unfold (cbor_read_deterministically_encoded_error_post a p va); fold (cbor_read_deterministically_encoded_with_typ_error_post t a p va); - fold (cbor_read_deterministically_encoded_with_typ_post t a p va res); + rewrite (cbor_read_deterministically_encoded_with_typ_error_post t a p va) + as (cbor_read_deterministically_encoded_with_typ_post t a p va res); + // fold (cbor_read_deterministically_encoded_with_typ_post t a p va res); + // idem res } } diff --git a/share/pulse/examples/dice/dpe/DPE.Messages.Parse.fst b/share/pulse/examples/dice/dpe/DPE.Messages.Parse.fst index 57d241d61..a463c518f 100644 --- a/share/pulse/examples/dice/dpe/DPE.Messages.Parse.fst +++ b/share/pulse/examples/dice/dpe/DPE.Messages.Parse.fst @@ -230,11 +230,13 @@ fn parse_dpe_cmd (#s:erased (Seq.seq U8.t)) let c = cbor_read_deterministically_encoded_with_typ impl_session_message input len; if (not c.cbor_read_is_success) { unfold (cbor_read_deterministically_encoded_with_typ_post Spec.session_message input p s c); + rewrite each c.cbor_read_is_success as false; unfold (cbor_read_deterministically_encoded_with_typ_error_post Spec.session_message input p s); fold (parse_dpe_cmd_post len input s p None); None #dpe_cmd } else { unfold (cbor_read_deterministically_encoded_with_typ_post Spec.session_message input p s c); + rewrite each c.cbor_read_is_success as true; unfold (cbor_read_deterministically_encoded_with_typ_success_post Spec.session_message input p s c); with vc . assert (raw_data_item_match 1.0R c.cbor_read_payload vc); with vrem1 . assert (pts_to c.cbor_read_remainder #p vrem1); @@ -255,6 +257,7 @@ fn parse_dpe_cmd (#s:erased (Seq.seq U8.t)) let msg = cbor_read_deterministically_encoded_with_typ impl_command_message cbor_str.cbor_string_payload (SZ.of_u64 cbor_str.cbor_string_length); if (not msg.cbor_read_is_success) { unfold (cbor_read_deterministically_encoded_with_typ_post Spec.command_message cbor_str.cbor_string_payload ps cs msg); + rewrite each msg.cbor_read_is_success as false; unfold (cbor_read_deterministically_encoded_with_typ_error_post Spec.command_message cbor_str.cbor_string_payload ps cs); elim_implies (); serialize_cbor_inj' vc vrem1; @@ -262,6 +265,7 @@ fn parse_dpe_cmd (#s:erased (Seq.seq U8.t)) None #dpe_cmd } else { unfold (cbor_read_deterministically_encoded_with_typ_post Spec.command_message cbor_str.cbor_string_payload ps cs msg); + rewrite each msg.cbor_read_is_success as true; unfold (cbor_read_deterministically_encoded_with_typ_success_post Spec.command_message cbor_str.cbor_string_payload ps cs msg); with vmsg . assert (raw_data_item_match 1.0R msg.cbor_read_payload vmsg); with vrem2 . assert (pts_to msg.cbor_read_remainder #ps vrem2); diff --git a/share/pulse/examples/parallel/ParallelFor.fst b/share/pulse/examples/parallel/ParallelFor.fst index 51554f769..b7f7fbac8 100644 --- a/share/pulse/examples/parallel/ParallelFor.fst +++ b/share/pulse/examples/parallel/ParallelFor.fst @@ -484,6 +484,9 @@ fn rec h_for_task #(pledge emp_inames (pool_done p) (on_range post mid hi)) (h_for_task p ((e /. 2.0R) /. 2.0R) pre post f mid hi); + rewrite each iname_list [] as emp_inames; + // ^FIXME should be automatic + (* We get this complicated pledge emp_inames from the spawns above. We can massage it before even waiting. *) assert (pledge emp_inames (pool_done p) (pledge emp_inames (pool_done p) (on_range post lo mid))); diff --git a/share/pulse/examples/parallel/Promises.Examples3.fst b/share/pulse/examples/parallel/Promises.Examples3.fst index 5bda52a0f..5308ac1f5 100644 --- a/share/pulse/examples/parallel/Promises.Examples3.fst +++ b/share/pulse/examples/parallel/Promises.Examples3.fst @@ -48,6 +48,10 @@ fn intro_inv_p (v_done:bool) (v_res:option int) (v_claimed:bool) ** pure (v_done ==> Some? v_res) ensures inv_p { + (* Unfortunate... does not happen automatically since we don't unfold + under a match. *) + rewrite (if not v_claimed then pts_to res #0.5R v_res else emp) + as (if not v_claimed then R.pts_to res #0.5R v_res else emp); fold inv_p; } @@ -72,7 +76,7 @@ fn proof ** pts_to done #0.5R true ** pts_to res #0.5R v_res ** pts_to claimed #0.5R v_claimed - ** (if not v_claimed then pts_to res #0.5R v_res else emp) + ** (if not v_claimed then R.pts_to res #0.5R v_res else emp) ** pure (v_claimed ==> v_done) ** pure (v_done ==> Some? v_res)); @@ -85,8 +89,8 @@ fn proof assert (pure (v_claimed == false)); // NB: this step is very sensitive to ordering - rewrite ((if not v_claimed then pts_to res #0.5R v_res else emp) ** emp) - as (pts_to res #0.5R v_res ** (if not true then pts_to res #0.5R v_res else emp)); + rewrite ((if not v_claimed then R.pts_to res #0.5R v_res else emp) ** emp) + as (R.pts_to res #0.5R v_res ** (if not true then pts_to res #0.5R v_res else emp)); GR.op_Colon_Equals claimed true; diff --git a/share/pulse/examples/parallel/TaskPool.Examples.fst b/share/pulse/examples/parallel/TaskPool.Examples.fst index 52500effa..5c0af4e9d 100644 --- a/share/pulse/examples/parallel/TaskPool.Examples.fst +++ b/share/pulse/examples/parallel/TaskPool.Examples.fst @@ -38,6 +38,7 @@ fn qs (n:nat) spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); teardown_pool p; + rewrite each iname_list [] as emp_inames; // fixme should be automatic redeem_pledge emp_inames (pool_done p) (qsv 1); redeem_pledge emp_inames (pool_done p) (qsv 2); redeem_pledge emp_inames (pool_done p) (qsv 3); @@ -57,6 +58,7 @@ fn qs_joinpromises (n:nat) spawn_ p (fun () -> qsc 2); spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); + rewrite each iname_list [] as emp_inames; // fixme should be automatic join_pledge #emp_inames #(pool_done p) (qsv 1) (qsv 2); join_pledge #emp_inames #(pool_done p) (qsv 3) (qsv 4); teardown_pool p; @@ -89,6 +91,7 @@ fn qsh (n:nat) // also qs12 could spawn and join its tasks, it would clearly work spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); + rewrite each iname_list [] as emp_inames; // fixme should be automatic teardown_pool p; redeem_pledge emp_inames (pool_done p) (qsv 1 ** qsv 2); redeem_pledge emp_inames (pool_done p) (qsv 3); @@ -106,6 +109,7 @@ fn qs12_par (#e:perm) (p:pool) { spawn_ p (fun () -> qsc 1); spawn_ p (fun () -> qsc 2); + rewrite each iname_list [] as emp_inames; // fixme should be automatic () } From c32c78f96199a05995f2fa3f1aeebca808413a67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Mon, 17 Feb 2025 18:10:26 -0800 Subject: [PATCH 07/32] Update expected output --- test/Example_Hashtable.c.expected | 19 +++--- test/bug-reports/Bug274.fst.output.expected | 63 ++++++++++++++++--- .../IntroGhost.fst.output.expected | 10 ++- test/nolib/Test.Matcher.fst.output.expected | 16 +---- 4 files changed, 72 insertions(+), 36 deletions(-) diff --git a/test/Example_Hashtable.c.expected b/test/Example_Hashtable.c.expected index 97ed85dec..72119e73c 100644 --- a/test/Example_Hashtable.c.expected +++ b/test/Example_Hashtable.c.expected @@ -437,27 +437,28 @@ void Example_Hashtable_insert_lookup_and_replace(void) ht_t__size_t_Example_Hashtable_data h = alloc__size_t_Example_Hashtable_data(Example_Hashtable_hash, (size_t)100U); __Pulse_Lib_HashTable_Type_ht_t_size_t_Example_Hashtable_data_bool - r = + _letpattern = insert__size_t_Example_Hashtable_data(h, (size_t)1U, ((Example_Hashtable_data){ .left = true, .right = false })); - ht_t__size_t_Example_Hashtable_data h1 = r.fst; + ht_t__size_t_Example_Hashtable_data h1 = _letpattern.fst; __Pulse_Lib_HashTable_Type_ht_t_size_t_Example_Hashtable_data_FStar_Pervasives_Native_option_size_t - r1 = lookup__size_t_Example_Hashtable_data(h1, (size_t)1U); - ht_t__size_t_Example_Hashtable_data h2 = r1.fst; - if (r1.snd.tag == Some) + _letpattern1 = lookup__size_t_Example_Hashtable_data(h1, (size_t)1U); + ht_t__size_t_Example_Hashtable_data h2 = _letpattern1.fst; + option__size_t found = _letpattern1.snd; + if (found.tag == Some) { - size_t i = r1.snd.v; + size_t i = found.v; __Pulse_Lib_HashTable_Type_ht_t_size_t_Example_Hashtable_data_Example_Hashtable_data - r2 = + _letpattern2 = replace__size_t_Example_Hashtable_data(h2, i, (size_t)1U, ((Example_Hashtable_data){ .left = false, .right = true })); - ht_t__size_t_Example_Hashtable_data h3 = r2.fst; + ht_t__size_t_Example_Hashtable_data h3 = _letpattern2.fst; dealloc__size_t_Example_Hashtable_data(h3); } - else if (r1.snd.tag == None) + else if (found.tag == None) dealloc__size_t_Example_Hashtable_data(h2); else { diff --git a/test/bug-reports/Bug274.fst.output.expected b/test/bug-reports/Bug274.fst.output.expected index 2851ccd67..a206e2dfe 100644 --- a/test/bug-reports/Bug274.fst.output.expected +++ b/test/bug-reports/Bug274.fst.output.expected @@ -1,24 +1,69 @@ >> Got issues: [ * Error 228 at Bug274.fst(31,4-31,15): - - Cannot prove: - _ @==> _ ** _ @==> _ + - Cannot prove any of: + Pulse.Lib.Stick.stick _ _ ** Pulse.Lib.Stick.stick _ _ - In the context: - p @==> q ** q @==> r + Pulse.Lib.Stick.stick p q ** Pulse.Lib.Stick.stick q r + - Some hints: + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick p q + and: + Pulse.Lib.Stick.stick q r + in the context. + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick p q + and: + Pulse.Lib.Stick.stick q r + in the context. >>] >> Got issues: [ * Error 228 at Bug274.fst(43,4-43,15): - - Cannot prove: - _ @==> _ ** _ @==> _ + - Cannot prove any of: + Pulse.Lib.Stick.stick _ _ ** Pulse.Lib.Stick.stick _ _ - In the context: - p @==> q ** q @==> r + Pulse.Lib.Stick.stick p q ** Pulse.Lib.Stick.stick q r + - Some hints: + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick q r + and: + Pulse.Lib.Stick.stick p q + in the context. + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick q r + and: + Pulse.Lib.Stick.stick p q + in the context. >>] >> Got issues: [ * Error 228 at Bug274.fst(77,4-77,12): - - Cannot prove: - _ ** _ @==> _ + - Cannot prove any of: + _ ** Pulse.Lib.Stick.stick _ _ - In the context: - p ** p @==> q ** r @==> r + p ** Pulse.Lib.Stick.stick p q ** Pulse.Lib.Stick.stick r r + - Some hints: + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick r r + and: + Pulse.Lib.Stick.stick p q + in the context. + - Ambiguous match for resource: + _ + - It can be matched by both: + Pulse.Lib.Stick.stick r r + and: + p + in the context. >>] diff --git a/test/bug-reports/IntroGhost.fst.output.expected b/test/bug-reports/IntroGhost.fst.output.expected index 05d5213d8..0c88e0e86 100644 --- a/test/bug-reports/IntroGhost.fst.output.expected +++ b/test/bug-reports/IntroGhost.fst.output.expected @@ -15,10 +15,14 @@ >>] >> Got issues: [ -* Error 228 at IntroGhost.fst(89,46-92,24): - - Cannot prove: +* Error 19 at IntroGhost.fst(89,46-92,24): + - Failed to discharge match guard for goal: IntroGhost.my_inv true r - - In the context: + with resource from context: IntroGhost.my_inv b r + - Assertion failed + - The SMT solver could not prove the query. Use --query_stats for more + details. + - Also see: IntroGhost.fst(92,17-92,21) >>] diff --git a/test/nolib/Test.Matcher.fst.output.expected b/test/nolib/Test.Matcher.fst.output.expected index 54f8313f6..fa0626878 100644 --- a/test/nolib/Test.Matcher.fst.output.expected +++ b/test/nolib/Test.Matcher.fst.output.expected @@ -1,5 +1,5 @@ >> Got issues: [ -* Error 228 at Test.Matcher.fst(69,2-69,4): +* Error 228 at Test.Matcher.fst(68,2-68,4): - Cannot prove: Test.Matcher.fpts_to #Prims.int r @@ -12,17 +12,3 @@ (FStar.Ghost.hide #Prims.int 1) >>] ->> Got issues: [ -* Error 228 at Test.Matcher.fst(103,2-103,4): - - Cannot prove: - Test.Matcher.spts_to #Prims.int - r - #(p +. 0.10R) - (FStar.Ghost.hide #Prims.int 1) - - In the context: - Test.Matcher.spts_to #Prims.int - r - #(p +. 0.1R) - (FStar.Ghost.hide #Prims.int 1) - ->>] From ff7c90d7ac64cdc007fc12dea4f96cb7d925fd1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 11:51:35 -0800 Subject: [PATCH 08/32] AVLTree: remove leftover admits --- lib/pulse/lib/Pulse.Lib.AVLTree.fst | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.AVLTree.fst b/lib/pulse/lib/Pulse.Lib.AVLTree.fst index 9bb98430a..0fdeadb4a 100644 --- a/lib/pulse/lib/Pulse.Lib.AVLTree.fst +++ b/lib/pulse/lib/Pulse.Lib.AVLTree.fst @@ -750,18 +750,22 @@ ensures (is_tree y (T.insert_avl cmp 'l key)) if (delta >= 0) { let new_left = insert_avl cmp n.left key; - vl := {data = n.data; left = new_left; right = n.right}; - admit(); - intro_is_tree_node (Some vl) vl #({data = n.data; left = new_left; right = n.right}); + let vl' = {data = n.data; left = new_left; right = n.right}; + vl := vl'; + rewrite each new_left as vl'.left; + rewrite each n.right as vl'.right; + intro_is_tree_node (Some vl) vl #vl'; let new_tree = rebalance_avl (Some vl); new_tree } else { let new_right = insert_avl cmp n.right key; - vl := {data = n.data; left = n.left; right = new_right}; - admit(); - intro_is_tree_node (Some vl) vl #({data = n.data; left = n.left; right = new_right}); + let vl' = {data = n.data; left = n.left; right = new_right }; + vl := vl'; + rewrite each new_right as vl'.right; + rewrite each n.left as vl'.left; + intro_is_tree_node (Some vl) vl #vl'; let new_tree = rebalance_avl (Some vl); new_tree } From 9e9db1f8a00b203c71cc6e3791b2b0bb4c66facd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 11:51:44 -0800 Subject: [PATCH 09/32] AVLTree: remove no-ops --- lib/pulse/lib/Pulse.Lib.AVLTree.fst | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.AVLTree.fst b/lib/pulse/lib/Pulse.Lib.AVLTree.fst index 0fdeadb4a..2cb8ad067 100644 --- a/lib/pulse/lib/Pulse.Lib.AVLTree.fst +++ b/lib/pulse/lib/Pulse.Lib.AVLTree.fst @@ -783,9 +783,7 @@ ensures is_tree x ft ** pure (T.Node? ft) cases_of_is_tree (Some v) ft; unfold is_tree_cases; intro_is_tree_node (Some v) v; - rewrite each Some v as x; with 't. rewrite is_tree (Some v) 't as is_tree x 't; - () } fn rec tree_max_c (#t:Type0) (tree:tree_t t) (#l:G.erased(T.tree t){T.Node? l}) From f06ceaf56ee0bdd23685f8e62d4120003f89870a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 11:51:58 -0800 Subject: [PATCH 10/32] all: remove leftover debugging options --- lib/pulse/lib/Pulse.Lib.ArrayPtr.fst | 2 -- lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst | 2 -- lib/pulse/lib/Pulse.Lib.ConditionVar.fst | 2 -- lib/pulse/lib/Pulse.Lib.Slice.fst | 1 - lib/pulse/lib/Pulse.Lib.Swap.Slice.fst | 1 - share/pulse/examples/dice/cbor/CDDL.Pulse.fst | 1 - src/checker/Pulse.VC.fst | 2 -- 7 files changed, 11 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst index b780c389f..b38337594 100644 --- a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst +++ b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst @@ -104,8 +104,6 @@ fn op_Array_Access res } -#set-options "--print_implicits" - fn op_Array_Assignment (#t: Type) (a: ptr t) diff --git a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst index c6f3d676c..689230cb1 100644 --- a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst +++ b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst @@ -64,8 +64,6 @@ fn new_cancellable_invariant (v:slprop) let unpacked c _v = pts_to c.r #0.5R true -#set-options "--print_implicits" - ghost fn unpack_cinv_vp (#p:perm) (#v:slprop) (c:cinv) requires cinv_vp c v ** active c p diff --git a/lib/pulse/lib/Pulse.Lib.ConditionVar.fst b/lib/pulse/lib/Pulse.Lib.ConditionVar.fst index 48b8efefb..219182305 100644 --- a/lib/pulse/lib/Pulse.Lib.ConditionVar.fst +++ b/lib/pulse/lib/Pulse.Lib.ConditionVar.fst @@ -205,8 +205,6 @@ ensures OR.on_range_put i j k #g } -#set-options "--print_full_names --print_implicits" - ghost fn get_predicate_at_i (t:SLT.table) diff --git a/lib/pulse/lib/Pulse.Lib.Slice.fst b/lib/pulse/lib/Pulse.Lib.Slice.fst index cb070da7c..dbd7e7304 100644 --- a/lib/pulse/lib/Pulse.Lib.Slice.fst +++ b/lib/pulse/lib/Pulse.Lib.Slice.fst @@ -16,7 +16,6 @@ module Pulse.Lib.Slice #lang-pulse -#set-options "--ext pulse:new" module AP = Pulse.Lib.ArrayPtr noeq diff --git a/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst b/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst index 4abbf35a2..1ef55510b 100644 --- a/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst +++ b/lib/pulse/lib/Pulse.Lib.Swap.Slice.fst @@ -22,7 +22,6 @@ open Pulse.Lib.Swap.Common #restart-solver #push-options "--z3rlimit_factor 6" -#set-options "--print_full_names" #restart-solver inline_for_extraction noextract [@@noextract_to "krml"] diff --git a/share/pulse/examples/dice/cbor/CDDL.Pulse.fst b/share/pulse/examples/dice/cbor/CDDL.Pulse.fst index 59583fe21..2bac2dd5b 100644 --- a/share/pulse/examples/dice/cbor/CDDL.Pulse.fst +++ b/share/pulse/examples/dice/cbor/CDDL.Pulse.fst @@ -332,7 +332,6 @@ fn impl_array_group3_item inline_for_extraction noextract [@@noextract_to "krml"] -#set-options "--print_full_names" fn impl_t_array (#b: Ghost.erased (option raw_data_item)) (#g: (array_group3 b)) diff --git a/src/checker/Pulse.VC.fst b/src/checker/Pulse.VC.fst index 54b7d0276..45961afea 100644 --- a/src/checker/Pulse.VC.fst +++ b/src/checker/Pulse.VC.fst @@ -17,8 +17,6 @@ let resolve #a #vc (w : with_vc vc a) : T.Tac (either (list issue) a) = | Inl iss -> Inl iss | Inr d -> Inr (w d) -#set-options "--print_implicits --print_universes" - let map_guarded (#a : Type u#aa) (#b : Type u#bb) From 531b3a611ca4edeea95c16835a08e5744c75a8b9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 11:57:20 -0800 Subject: [PATCH 11/32] Array.Core: fix mkey to match fsti --- lib/pulse/lib/Pulse.Lib.Array.Core.fst | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fst b/lib/pulse/lib/Pulse.Lib.Array.Core.fst index f1519c758..2cc3c8630 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.fst @@ -180,7 +180,8 @@ ensures pts_to arr #(p0 +. p1) s0 ** pure (s0 == s1) let pts_to_range (#a:Type) ([@@@mkey] x:array a) - ([@@@mkey] i [@@@mkey] j : nat) + ([@@@mkey] i : nat) + (j : nat) (#[exact (`1.0R)] p:perm) (s : Seq.seq a) : slprop From d633d092c70d99e21106502a28b0cd49c13d66b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 11:58:21 -0800 Subject: [PATCH 12/32] ArrayPtr: remove specialized fold/unfold, no longer needed --- lib/pulse/lib/Pulse.Lib.ArrayPtr.fst | 33 +++++++--------------------- 1 file changed, 8 insertions(+), 25 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst index b38337594..0e14592a9 100644 --- a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst +++ b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst @@ -29,23 +29,6 @@ let offset a = SZ.v a.offset let pts_to s #p v = A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length v) #p v -ghost fn unfold_pts_to #t (s: ptr t) #p v - requires pts_to s #p v - ensures A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length v) #p v -{ - rewrite pts_to s #p v as - A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length v) #p v -} - -ghost fn fold_pts_to #t (s: ptr t) #p v - requires A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length v) #p v - ensures pts_to s #p v -{ - rewrite - A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length v) #p v - as pts_to s #p v -} - let pts_to_timeless x p s = () let is_from_array s sz a = @@ -169,7 +152,7 @@ fn split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) pts_to s' #p (Seq.slice v (SZ.v i) (Seq.length v)) ** pure (adjacent s (SZ.v i) s') { - unfold_pts_to s #p v; + unfold pts_to s #p v; A.pts_to_range_prop s.base; let s' = { base = s.base; @@ -185,7 +168,7 @@ fn split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) rewrite (A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2) as (A.pts_to_range s'.base (SZ.v s'.offset) (SZ.v s'.offset + Seq.length s2) #p s2); - fold_pts_to s' #p s2; + fold pts_to s' #p s2; s' } @@ -198,7 +181,7 @@ ghost fn ghost_split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) pts_to (reveal s') #p (Seq.slice v (SZ.v i) (Seq.length v)) ** pure (adjacent s (SZ.v i) s') { - unfold_pts_to s #p v; + unfold pts_to s #p v; A.pts_to_range_prop s.base; let s' = { base = s.base; @@ -209,12 +192,12 @@ ghost fn ghost_split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) rewrite (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s'.offset) #p s1) as (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + SZ.v i) #p s1); - fold_pts_to s #p s1; + fold pts_to s #p s1; with s2. assert A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2; rewrite (A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2) as (A.pts_to_range s'.base (SZ.v s'.offset) (SZ.v s'.offset + Seq.length s2) #p s2); - fold_pts_to s' #p s2; + fold pts_to s' #p s2; s' } @@ -224,12 +207,12 @@ fn join (#t: Type) (s1: ptr t) (#p: perm) (#v1: Seq.seq t) (s2: ptr t) (#v2: Seq requires pts_to s1 #p v1 ** pts_to s2 #p v2 ** pure (adjacent s1 (Seq.length v1) s2) ensures pts_to s1 #p (Seq.append v1 v2) { - unfold_pts_to s1 #p v1; - unfold_pts_to s2 #p v2; + unfold pts_to s1 #p v1; + unfold pts_to s2 #p v2; rewrite (A.pts_to_range s2.base (SZ.v s2.offset) (SZ.v s2.offset + Seq.length v2) #p v2) as (A.pts_to_range s1.base (SZ.v s1.offset + Seq.length v1) (SZ.v s1.offset + Seq.length v1 + Seq.length v2) #p v2); A.pts_to_range_join s1.base (SZ.v s1.offset) (SZ.v s1.offset + Seq.length v1) (SZ.v s1.offset + Seq.length v1 + Seq.length v2); - fold_pts_to s1 #p (Seq.append v1 v2) + fold pts_to s1 #p (Seq.append v1 v2) } module R = Pulse.Lib.Reference From b7f925e6a14edfbc9be98a003a79f6b508ef0c6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 11:59:12 -0800 Subject: [PATCH 13/32] LinkedList: remove stray admit --- lib/pulse/lib/Pulse.Lib.LinkedList.fst | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/pulse/lib/Pulse.Lib.LinkedList.fst b/lib/pulse/lib/Pulse.Lib.LinkedList.fst index ff605a48b..a79a141f3 100644 --- a/lib/pulse/lib/Pulse.Lib.LinkedList.fst +++ b/lib/pulse/lib/Pulse.Lib.LinkedList.fst @@ -116,7 +116,6 @@ fn is_list_cases_none (#t:Type) (x:llist t) (#l:list t) } Cons _ _ -> { unfold is_list; - admit(); assert (pure False); // NEEDED, bug? couldn't minimize easily unreachable (); } From d799d564098c26c5b0cbe16537a0b63d258bfb04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 12:18:26 -0800 Subject: [PATCH 14/32] Quicksort.Task: remove now-needless rewrite --- share/pulse/examples/Quicksort.Task.fst | 1 - 1 file changed, 1 deletion(-) diff --git a/share/pulse/examples/Quicksort.Task.fst b/share/pulse/examples/Quicksort.Task.fst index b8b9cb79c..787549c67 100644 --- a/share/pulse/examples/Quicksort.Task.fst +++ b/share/pulse/examples/Quicksort.Task.fst @@ -59,7 +59,6 @@ fn rec t_quicksort T.share_alive p f; T.spawn_ p #(f /. 2.0R) (fun () -> t_quicksort p #(f /. 2.0R) a lo p31 #lb #pivot); - rewrite each iname_list [] as emp_inames; // FIXME t_quicksort p #(f /. 2.0R) a p32 hi #pivot #rb; return_pledge (T.pool_done p) (A.pts_to_range a p31 p32 s2); From c4089932269b03004b5c7f74bd0fa1f58260e95f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 12:35:37 -0800 Subject: [PATCH 15/32] Matcher: allow delta when matching arguments in full matcher --- src/checker/Pulse.Checker.Prover.Match.MKeys.fst | 2 +- src/checker/Pulse.Typing.Util.fst | 11 ++++++----- src/checker/Pulse.Typing.Util.fsti | 4 ++++ 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst index 581944efd..812db157b 100644 --- a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst +++ b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst @@ -143,7 +143,7 @@ let rec eligible_for_smt_equality (g:env) (t0 t1 : term) eligible_for_smt_equality g a0 a1 else try - Some? (fst (PTU.check_equiv_now_nosmt (elab_env g) a0 a1)) + Some? (fst (PTU.check_equiv_now_nosmt_unfold (elab_env g) a0 a1)) with | _ -> false in (true, eq && eq') diff --git a/src/checker/Pulse.Typing.Util.fst b/src/checker/Pulse.Typing.Util.fst index bdea334f4..53135b570 100644 --- a/src/checker/Pulse.Typing.Util.fst +++ b/src/checker/Pulse.Typing.Util.fst @@ -25,12 +25,13 @@ let check_equiv_now tcenv t0 t1 = (* Call check_equiv without allowing it to generate guards nor unfold. It's a very -simple use of the core checker + unifier. -The Force guard_policy is probably unneeded, as no -guards should appear. *) +simple use of the core checker + unifier. *) let check_equiv_now_nosmt tcenv t0 t1 = - // T.with_policy ForceSMT (fun () -> - T.check_equiv_nosmt tcenv t0 t1 + T.t_check_equiv false false tcenv t0 t1 + +(* Like above, but allows unfolding. *) +let check_equiv_now_nosmt_unfold tcenv t0 t1 = + T.t_check_equiv false true tcenv t0 t1 let universe_of_now g e = T.with_policy ForceSMT (fun () -> diff --git a/src/checker/Pulse.Typing.Util.fsti b/src/checker/Pulse.Typing.Util.fsti index 9bbdd3961..04cb9ced0 100644 --- a/src/checker/Pulse.Typing.Util.fsti +++ b/src/checker/Pulse.Typing.Util.fsti @@ -27,6 +27,10 @@ to be a rather fast, unification-only check. *) val check_equiv_now_nosmt (g:env) (t1 t2 : term) : Tac (option (equiv_token g t1 t2) & issues) +(* As above, but allowing unfolding. *) +val check_equiv_now_nosmt_unfold (g:env) (t1 t2 : term) + : Tac (option (equiv_token g t1 t2) & issues) + (* Like T.universe_of, but will make sure to not delay any VC. *) val universe_of_now : g:env -> e:term -> Tac (option (u:universe{typing_token g e (E_Total, pack_ln (Reflection.V2.Tv_Type u))}) & issues) From c90af6ffaff7d926db2a5370b896f1752af5d47a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 12:39:20 -0800 Subject: [PATCH 16/32] Quicksort.Task: simplify now that matcher will unfold args --- share/pulse/examples/Quicksort.Task.fst | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/share/pulse/examples/Quicksort.Task.fst b/share/pulse/examples/Quicksort.Task.fst index 787549c67..1e8352d5f 100644 --- a/share/pulse/examples/Quicksort.Task.fst +++ b/share/pulse/examples/Quicksort.Task.fst @@ -46,12 +46,7 @@ fn rec t_quicksort { if (lo < hi - 1) { - let r = partition_wrapper a lo hi lb rb; - let Mktuple3 p31 p32 pivot = r; - rewrite each r._1 as p31; - rewrite each r._2 as p32; - rewrite each r._3 as pivot; - // ^FIXME: would be nicer to rewrite r as (p31, p32, pivot) but projectors don't unfold + let p31, p32, pivot = partition_wrapper a lo hi lb rb; with s1. assert (A.pts_to_range a lo p31 s1); with s2. assert (A.pts_to_range a p31 p32 s2); with s3. assert (A.pts_to_range a p32 hi s3); From 5e6e2cf7739c2247964c4f8012895f562c0b2ca0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 12:58:22 -0800 Subject: [PATCH 17/32] Add repros for #347 --- test/bug-reports/Bug347.fst | 56 ++++++++++++++++++++++++++++++++++++ test/bug-reports/Bug347b.fst | 15 ++++++++++ 2 files changed, 71 insertions(+) create mode 100644 test/bug-reports/Bug347.fst create mode 100644 test/bug-reports/Bug347b.fst diff --git a/test/bug-reports/Bug347.fst b/test/bug-reports/Bug347.fst new file mode 100644 index 000000000..9776d38dc --- /dev/null +++ b/test/bug-reports/Bug347.fst @@ -0,0 +1,56 @@ +module Bug347 +#lang-pulse +open Pulse + +let limb_t = unit +open FStar.UInt32 { v } +let carry (t: limb_t) = x:UInt32.t { v x <= 1 } +let limb (t: limb_t) = UInt32.t +let uint_v (x: UInt32.t) = v x +let bits (t: limb_t) = 32 +let inttype = unit +type secrecy_level = | SEC | PUB +let uint_t (t: inttype) (sec: secrecy_level) = UInt32.t + +assume val subborrow: #t:limb_t -> c:carry t -> a:limb t -> b:limb t -> + Pure (carry t & limb t) + (requires True) + (ensures fun (c', r) -> + uint_v r - uint_v c' * pow2 (bits t) == uint_v a - uint_v b - uint_v c) + +inline_for_extraction +let sub_borrow_st (t:inttype) = + cin:uint_t t SEC + -> x:uint_t t SEC + -> y:uint_t t SEC + -> r:ref (uint_t t SEC) -> + stt (uint_t t SEC) + (requires exists* s. pts_to r s ** pure (v cin <= 1)) + (ensures fun c -> + exists* vr. + pure (v c <= 1) ** + pts_to r vr ** + pure (v vr - v c * pow2 (bits t) == v x - v y - v cin)) + +assume val sub_borrow (#t:inttype) : sub_borrow_st t + +inline_for_extraction noextract +fn subborrow_st (#t:limb_t) (c_in:carry t) (a:limb t) (b:limb t) (out:ref (limb t)) + requires exists* s. pts_to out s + returns c_out: carry t + ensures exists* c0. pts_to out c0 ** pure ((c_out, c0) == subborrow c_in a b) +{ + // The temporary `c_out` is necessary here; simply writing `sub_borrow #t c_in a b out` does not work. + let c_out = sub_borrow #t c_in a b out; + c_out +} + +[@@expect_failure] // should work +inline_for_extraction noextract +fn subborrow_st2 (#t:limb_t) (c_in:carry t) (a:limb t) (b:limb t) (out:ref (limb t)) + requires exists* s. pts_to out s + returns c_out: carry t + ensures exists* c0. pts_to out c0 ** pure ((c_out, c0) == subborrow c_in a b) +{ + sub_borrow #t c_in a b out; +} diff --git a/test/bug-reports/Bug347b.fst b/test/bug-reports/Bug347b.fst new file mode 100644 index 000000000..e9774abda --- /dev/null +++ b/test/bug-reports/Bug347b.fst @@ -0,0 +1,15 @@ +module Bug347b +#lang-pulse +open Pulse + +assume +val foo : unit -> stt int (requires emp) (ensures fun x -> pure (x == 1)) + +[@@expect_failure] // should work +fn test () + requires emp + returns x : (x:int{x == 1}) + ensures emp +{ + foo (); +} From 5ede64534d8aa0d2410bfcd5cb9302531f6f4021 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 13:04:36 -0800 Subject: [PATCH 18/32] Removing debug options in test/examples --- lib/pulse/lib/Pulse.Lib.Task.fst | 1 - share/pulse/examples/Example.ImplicitBinders.fst | 3 +-- share/pulse/examples/Invariant.fst | 12 ++---------- .../pulse/examples/by-example/ParallelIncrement.fst | 2 -- .../pulse/examples/by-example/PulseTutorial.Ref.fst | 2 -- share/pulse/examples/c/PulsePointStruct.fst | 2 -- share/pulse/examples/parallel/TaskPool.Examples.fst | 1 - test/Test.Basic2.fst | 7 +------ test/bug-reports/DependentTuples.fst | 3 --- test/nolib/Test.Matcher.fst | 1 + test/nolib/Test.Matcher.fst.output.expected | 2 +- 11 files changed, 6 insertions(+), 30 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.Task.fst b/lib/pulse/lib/Pulse.Lib.Task.fst index 3db742a1a..a2a321c88 100644 --- a/lib/pulse/lib/Pulse.Lib.Task.fst +++ b/lib/pulse/lib/Pulse.Lib.Task.fst @@ -1328,7 +1328,6 @@ fn rec check_if_all_done } } -#push-options "--print_implicits" fn try_await_pool (p:pool) #is (#f:perm) diff --git a/share/pulse/examples/Example.ImplicitBinders.fst b/share/pulse/examples/Example.ImplicitBinders.fst index d198fc3af..6c1a51097 100644 --- a/share/pulse/examples/Example.ImplicitBinders.fst +++ b/share/pulse/examples/Example.ImplicitBinders.fst @@ -16,9 +16,8 @@ module Example.ImplicitBinders #lang-pulse -open Pulse.Lib.Pervasives +open Pulse module U32 = FStar.UInt32 -#push-options "--print_implicits" // diff --git a/share/pulse/examples/Invariant.fst b/share/pulse/examples/Invariant.fst index 97d25bb98..8ce11a3a2 100644 --- a/share/pulse/examples/Invariant.fst +++ b/share/pulse/examples/Invariant.fst @@ -15,17 +15,9 @@ *) module Invariant -#lang-pulse - -// #set-options "--error_contexts true" -// #set-options "--print_implicits --print_universes" -// #set-options "--ext pulse:guard_policy=SMTSync" -// #set-options "--debug Invariant --debug_level SMTQuery" -// #set-options "--trace_error" -open Pulse.Lib.Pervasives -open Pulse.Lib.Reference -open Pulse.Lib +#lang-pulse +open Pulse assume val p : slprop assume val q : slprop diff --git a/share/pulse/examples/by-example/ParallelIncrement.fst b/share/pulse/examples/by-example/ParallelIncrement.fst index 79236b73f..c598c5324 100644 --- a/share/pulse/examples/by-example/ParallelIncrement.fst +++ b/share/pulse/examples/by-example/ParallelIncrement.fst @@ -41,8 +41,6 @@ ensures (L.lock_alive l #p (exists* v. pts_to x #0.5R v)) ** R.pts_to x #0.5R ( } -#push-options "--print_implicits --ext 'pulse:env_on_err' --print_full_names" - fn increment_f (x: ref nat) (#p:perm) (#pred #qpred: nat -> slprop) diff --git a/share/pulse/examples/by-example/PulseTutorial.Ref.fst b/share/pulse/examples/by-example/PulseTutorial.Ref.fst index 17cd77c10..bc3989eab 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Ref.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Ref.fst @@ -168,7 +168,6 @@ ensures pts_to r #p 'v ** pure (v == 'v) //assign_perm FAIL$ -#push-options "--print_implicits" [@@expect_failure] fn assign_perm #a #p (r:ref a) (v:a) (#w:erased a) @@ -178,7 +177,6 @@ ensures pts_to r #p w r := v; } -#pop-options //end assign_perm FAIL$ diff --git a/share/pulse/examples/c/PulsePointStruct.fst b/share/pulse/examples/c/PulsePointStruct.fst index fbac58b8e..8f3418c36 100644 --- a/share/pulse/examples/c/PulsePointStruct.fst +++ b/share/pulse/examples/c/PulsePointStruct.fst @@ -37,8 +37,6 @@ ensures } -#set-options "--print_implicits" - inline_for_extraction noextract let _x = norm Pulse.C.Typestring.norm_typestring (Pulse.C.Typestring.mk_string_t "x") diff --git a/share/pulse/examples/parallel/TaskPool.Examples.fst b/share/pulse/examples/parallel/TaskPool.Examples.fst index 5c0af4e9d..48b13ccb7 100644 --- a/share/pulse/examples/parallel/TaskPool.Examples.fst +++ b/share/pulse/examples/parallel/TaskPool.Examples.fst @@ -101,7 +101,6 @@ fn qsh (n:nat) -#set-options "--print_implicits" fn qs12_par (#e:perm) (p:pool) requires pool_alive #e p returns _:unit diff --git a/test/Test.Basic2.fst b/test/Test.Basic2.fst index 3ae881e19..1b1e07d30 100644 --- a/test/Test.Basic2.fst +++ b/test/Test.Basic2.fst @@ -17,14 +17,9 @@ module Test.Basic2 #lang-pulse -open Pulse.Lib.Pervasives - -// #set-options "--debug ggg" -// #set-options "--debug pulse,prover,ggg --print_full_names --print_implicits" - +open Pulse open Pulse.Lib.Stick.Util - ghost fn test_trans (p q r:slprop) requires (p @==> q) ** (q @==> r) diff --git a/test/bug-reports/DependentTuples.fst b/test/bug-reports/DependentTuples.fst index 183ae232d..c18750c44 100644 --- a/test/bug-reports/DependentTuples.fst +++ b/test/bug-reports/DependentTuples.fst @@ -36,9 +36,6 @@ val global_tup : tup_t assume val get_v #v (l:t v) : stt unit emp (fun _ -> v) -#set-options "--print_implicits" - - fn tuple () requires emp ensures emp diff --git a/test/nolib/Test.Matcher.fst b/test/nolib/Test.Matcher.fst index 24d8346b6..abc329042 100644 --- a/test/nolib/Test.Matcher.fst +++ b/test/nolib/Test.Matcher.fst @@ -4,6 +4,7 @@ module Test.Matcher open Pulse.Nolib open FStar.Tactics.V2 +(* So the permissions show up in the output. *) #set-options "--print_implicits" (* Testing different matching modes. *) diff --git a/test/nolib/Test.Matcher.fst.output.expected b/test/nolib/Test.Matcher.fst.output.expected index fa0626878..ef2101831 100644 --- a/test/nolib/Test.Matcher.fst.output.expected +++ b/test/nolib/Test.Matcher.fst.output.expected @@ -1,5 +1,5 @@ >> Got issues: [ -* Error 228 at Test.Matcher.fst(68,2-68,4): +* Error 228 at Test.Matcher.fst(69,2-69,4): - Cannot prove: Test.Matcher.fpts_to #Prims.int r From 786d3615d966711b8aba8fa44b3c095897f9c00e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 13:28:01 -0800 Subject: [PATCH 19/32] lib: remove leftover admits --- lib/pulse/lib/Pulse.Lib.Forall.Util.fst | 1 - lib/pulse/lib/Pulse.Lib.HigherArray.fst | 5 ++--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.Forall.Util.fst b/lib/pulse/lib/Pulse.Lib.Forall.Util.fst index 901d8e179..1f996529b 100644 --- a/lib/pulse/lib/Pulse.Lib.Forall.Util.fst +++ b/lib/pulse/lib/Pulse.Lib.Forall.Util.fst @@ -56,7 +56,6 @@ fn trans (#a:Type0) (p q r: a -> slprop) requires (forall* x. p x @==> q x) ** (forall* x. q x @==> r x) ensures forall* x. p x @==> r x { - admit(); /// GGG FIXME: rewrite under lambda trans_compose p q r id id; } diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.fst b/lib/pulse/lib/Pulse.Lib.HigherArray.fst index 5adaf4011..1c11b2cb0 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.fst +++ b/lib/pulse/lib/Pulse.Lib.HigherArray.fst @@ -809,14 +809,13 @@ ensures pts_to_range a i j #p (s1 `Seq.append` s2) pts_to_range_prop a #i #m; pts_to_range_prop a #m #j; unfold pts_to_range a i m #p s1; + unfold token #(in_bounds i m a) a _; unfold pts_to_range a m j #p s2; + unfold token #(in_bounds m j a) a _; ghost_join (array_slice a i m) (array_slice a m j) (); rewrite each (merge (array_slice a i m) (array_slice a m j)) as (array_slice a i j); pts_to_range_intro_ij a _ _ i j (); - admit(); // fixme: ambig - unfold (token #(in_bounds i m a) a _); - unfold (token #(in_bounds m j a) a _); } let pts_to_range_join = pts_to_range_join' From 74c9f812d5aee7d66f6e41cde88f78a17a7acda3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 13:29:34 -0800 Subject: [PATCH 20/32] remove more now-superfluous rewrites --- share/pulse/examples/parallel/ParallelFor.fst | 3 --- share/pulse/examples/parallel/TaskPool.Examples.fst | 4 ---- 2 files changed, 7 deletions(-) diff --git a/share/pulse/examples/parallel/ParallelFor.fst b/share/pulse/examples/parallel/ParallelFor.fst index b7f7fbac8..51554f769 100644 --- a/share/pulse/examples/parallel/ParallelFor.fst +++ b/share/pulse/examples/parallel/ParallelFor.fst @@ -484,9 +484,6 @@ fn rec h_for_task #(pledge emp_inames (pool_done p) (on_range post mid hi)) (h_for_task p ((e /. 2.0R) /. 2.0R) pre post f mid hi); - rewrite each iname_list [] as emp_inames; - // ^FIXME should be automatic - (* We get this complicated pledge emp_inames from the spawns above. We can massage it before even waiting. *) assert (pledge emp_inames (pool_done p) (pledge emp_inames (pool_done p) (on_range post lo mid))); diff --git a/share/pulse/examples/parallel/TaskPool.Examples.fst b/share/pulse/examples/parallel/TaskPool.Examples.fst index 48b13ccb7..70eb06310 100644 --- a/share/pulse/examples/parallel/TaskPool.Examples.fst +++ b/share/pulse/examples/parallel/TaskPool.Examples.fst @@ -38,7 +38,6 @@ fn qs (n:nat) spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); teardown_pool p; - rewrite each iname_list [] as emp_inames; // fixme should be automatic redeem_pledge emp_inames (pool_done p) (qsv 1); redeem_pledge emp_inames (pool_done p) (qsv 2); redeem_pledge emp_inames (pool_done p) (qsv 3); @@ -58,7 +57,6 @@ fn qs_joinpromises (n:nat) spawn_ p (fun () -> qsc 2); spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); - rewrite each iname_list [] as emp_inames; // fixme should be automatic join_pledge #emp_inames #(pool_done p) (qsv 1) (qsv 2); join_pledge #emp_inames #(pool_done p) (qsv 3) (qsv 4); teardown_pool p; @@ -91,7 +89,6 @@ fn qsh (n:nat) // also qs12 could spawn and join its tasks, it would clearly work spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); - rewrite each iname_list [] as emp_inames; // fixme should be automatic teardown_pool p; redeem_pledge emp_inames (pool_done p) (qsv 1 ** qsv 2); redeem_pledge emp_inames (pool_done p) (qsv 3); @@ -108,7 +105,6 @@ fn qs12_par (#e:perm) (p:pool) { spawn_ p (fun () -> qsc 1); spawn_ p (fun () -> qsc 2); - rewrite each iname_list [] as emp_inames; // fixme should be automatic () } From 5329695d5cf7b9cc3750c6c8dfa68135e5a9271a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Tue, 18 Feb 2025 13:35:48 -0800 Subject: [PATCH 21/32] pulse.opam: can now set ADMIT=1 in build --- pulse.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pulse.opam b/pulse.opam index 26411cae2..6b9820a11 100644 --- a/pulse.opam +++ b/pulse.opam @@ -9,7 +9,7 @@ depends: [ "fstar" {>= "2023.04.15~dev"} ] build: [ - [make "-j" jobs] + [make "-j" jobs "ADMIT=1"] ] install: [ [make "PREFIX=%{prefix}%" "install"] From 918d2a37e0c586a2c2d5a76d84b4d94f866d114d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Wed, 19 Feb 2025 14:42:45 -0800 Subject: [PATCH 22/32] remove debug output --- src/checker/Pulse.Checker.Prover.Match.MKeys.fst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst index 812db157b..29253c84a 100644 --- a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst +++ b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst @@ -69,7 +69,7 @@ let binder_is_mkey (b:R.binder) : bool = let binder_is_slprop (b:R.binder) : T.Tac bool = let r = TermEq.term_eq tm_slprop (R.inspect_binder b).sort in - T.print <| "is_slprop " ^ show (R.inspect_binder b).sort ^ " = " ^ show r; + (* T.print <| "is_slprop " ^ show (R.inspect_binder b).sort ^ " = " ^ show r; *) r let rec zip3 (l1:list 'a) (l2:list 'b) (l3:list 'c) : T.Tac (list ('a & 'b & 'c)) = From a819dad3f090ca99e64d60f12ca8e5bf302d64d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Wed, 19 Feb 2025 14:42:50 -0800 Subject: [PATCH 23/32] Trade: mark components as mkeys, allows deep matching --- lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti index 524796be1..de75788c9 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti +++ b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti @@ -22,10 +22,11 @@ module T = FStar.Tactics val trade : (#[T.exact (`emp_inames)] is:inames) -> - (hyp:slprop) -> - (concl:slprop) -> + ([@@@mkey] hyp:slprop) -> + ([@@@mkey] concl:slprop) -> slprop +unfold let ( ==>* ) : (#[T.exact (`emp_inames)] is:inames) -> (hyp:slprop) -> From 8fc67400a36b6f5aee0d01905a1c80c1709b9bfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 21 Feb 2025 08:17:29 -0800 Subject: [PATCH 24/32] lib: No need for GTot on prop/Type0 --- lib/pulse/c/Pulse.C.Types.Array.fsti | 16 ++++++++-------- lib/pulse/c/Pulse.C.Types.Base.fsti | 4 ++-- lib/pulse/lib/Pulse.Lib.HashTable.fsti | 4 ++-- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/lib/pulse/c/Pulse.C.Types.Array.fsti b/lib/pulse/c/Pulse.C.Types.Array.fsti index a402f1f26..30182059d 100644 --- a/lib/pulse/c/Pulse.C.Types.Array.fsti +++ b/lib/pulse/c/Pulse.C.Types.Array.fsti @@ -179,12 +179,12 @@ inline_for_extraction [@@noextract_to "krml"] let array_ref (#t: Type) (td: typedef t) = (a: array_ptr td { g_array_ptr_is_null a == false }) (* -val array_ref_base_size_type (#t: Type) (#td: typedef t) (a: array_ref td) : GTot Type0 +val array_ref_base_size_type (#t: Type) (#td: typedef t) (a: array_ref td) : Type0 *) val array_ref_base_size (#t: Type) (#td: typedef t) (a: array_ptr td) : Ghost SZ.t (requires True) (ensures (fun y -> SZ.v y == 0 <==> a == null_array_ptr td)) -val has_array_ref_base (#t: Type) (#td: typedef t) (a: array_ref td) (#ty: Type) (r: ref (base_array0 ty td (array_ref_base_size a))) : GTot prop +val has_array_ref_base (#t: Type) (#td: typedef t) (a: array_ref td) (#ty: Type) (r: ref (base_array0 ty td (array_ref_base_size a))) : prop val has_array_ref_base_inj (#t: Type) (#td: typedef t) (a: array_ref td) (#ty: Type) (r1 r2: ref (base_array0 ty td (array_ref_base_size a))) : Lemma (requires (has_array_ref_base a r1 /\ has_array_ref_base a r2)) (ensures (r1 == r2)) @@ -323,7 +323,7 @@ let has_array_of_base (#td: typedef t) (r: ref (base_array0 tn td n)) (a: array td) -: GTot prop +: prop = let (| al, len |) = a in array_ref_base_size al == n /\ has_array_ref_base al #tn r /\ @@ -390,7 +390,7 @@ let array_ref_of_base_post (r: ref (base_array0 tn td n)) (a: array_ref td) (ar: array td) -: GTot prop +: prop = array_ptr_of ar == a /\ array_ref_base_size a == Ghost.reveal n /\ @@ -521,7 +521,7 @@ ensures } -let full_seq (#t: Type) (td: typedef t) (v: Seq.seq t) : GTot prop = +let full_seq (#t: Type) (td: typedef t) (v: Seq.seq t) : prop = forall (i: nat { i < Seq.length v }) . {:pattern (Seq.index v i)} full td (Seq.index v i) let full_seq_seq_of_base_array @@ -907,7 +907,7 @@ let array_ref_split_post (a: array td) (i: SZ.t) (sl sr: Ghost.erased (Seq.seq t)) -: GTot prop +: prop = SZ.v i <= array_length a /\ Seq.length s == array_length a /\ Ghost.reveal sl == Seq.slice s 0 (SZ.v i) /\ Ghost.reveal sr == Seq.slice s (SZ.v i) (Seq.length s) @@ -983,7 +983,7 @@ val array_join )) (fun _ -> array_pts_to a (sl `Seq.append` sr)) -let fractionable_seq (#t: Type) (td: typedef t) (s: Seq.seq t) : GTot prop = +let fractionable_seq (#t: Type) (td: typedef t) (s: Seq.seq t) : prop = forall (i: nat). i < Seq.length s ==> fractionable td (Seq.index s i) let mk_fraction_seq (#t: Type) (td: typedef t) (s: Seq.seq t) (p: perm) : Ghost (Seq.seq t) @@ -1055,7 +1055,7 @@ let array_blit_post (idx_dst: SZ.t) (len: SZ.t) (s1' : Ghost.erased (Seq.seq t)) -: GTot prop +: prop = SZ.v idx_src + SZ.v len <= array_length src /\ SZ.v idx_dst + SZ.v len <= array_length dst /\ diff --git a/lib/pulse/c/Pulse.C.Types.Base.fsti b/lib/pulse/c/Pulse.C.Types.Base.fsti index 5fe72b209..7fbba8c75 100644 --- a/lib/pulse/c/Pulse.C.Types.Base.fsti +++ b/lib/pulse/c/Pulse.C.Types.Base.fsti @@ -33,7 +33,7 @@ val typedef (t: Type0) : Type0 inline_for_extraction [@@noextract_to "krml"] let typeof (#t: Type0) (td: typedef t) : Tot Type0 = t -val fractionable (#t: Type0) (td: typedef t) (x: t) : GTot prop +val fractionable (#t: Type0) (td: typedef t) (x: t) : prop val mk_fraction (#t: Type0) (td: typedef t) (x: t) (p: perm) : Ghost t (requires (fractionable td x)) @@ -48,7 +48,7 @@ val mk_fraction_compose (#t: Type0) (td: typedef t) (x: t) (p1 p2: perm) : Lemma (requires (fractionable td x /\ p1 <=. 1.0R /\ p2 <=. 1.0R)) (ensures (mk_fraction td (mk_fraction td x p1) p2 == mk_fraction td x (p1 `prod_perm` p2))) -val full (#t: Type0) (td: typedef t) (v: t) : GTot prop +val full (#t: Type0) (td: typedef t) (v: t) : prop val uninitialized (#t: Type0) (td: typedef t) : Ghost t (requires True) diff --git a/lib/pulse/lib/Pulse.Lib.HashTable.fsti b/lib/pulse/lib/Pulse.Lib.HashTable.fsti index aa7eb00b3..b7123c5cd 100644 --- a/lib/pulse/lib/Pulse.Lib.HashTable.fsti +++ b/lib/pulse/lib/Pulse.Lib.HashTable.fsti @@ -39,7 +39,7 @@ let mk_init_pht (#k:eqtype) #v (hashf:k -> SZ.t) (sz:pos_us) } noextract -let related #kt #vt (ht:ht_t kt vt) (pht:pht_t kt vt) : GTot prop = +let related #kt #vt (ht:ht_t kt vt) (pht:pht_t kt vt) : prop = SZ.v ht.sz == pht.repr.sz /\ pht.repr.hashf == lift_hash_fun ht.hashf @@ -76,7 +76,7 @@ val dealloc (ensures fun _ -> emp) noextract -let same_sz_and_hashf (#kt:eqtype) (#vt:Type) (ht1 ht2:ht_t kt vt) : GTot prop = +let same_sz_and_hashf (#kt:eqtype) (#vt:Type) (ht1 ht2:ht_t kt vt) : prop = ht1.sz == ht2.sz /\ ht1.hashf == ht2.hashf From 12d5e6e7766e387884282409c8e8ec65cd3a0d08 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 21 Feb 2025 09:55:24 -0800 Subject: [PATCH 25/32] Matcher: allow unification for slprops too --- .../Pulse.Checker.Prover.Match.MKeys.fst | 20 ++++++-- test/nolib/MicroQueries.fst | 25 +++++++++ test/nolib/UnfoldArgs.fst | 51 +++++++++++++++++++ 3 files changed, 92 insertions(+), 4 deletions(-) create mode 100644 test/nolib/MicroQueries.fst create mode 100644 test/nolib/UnfoldArgs.fst diff --git a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst index 29253c84a..54034e6f7 100644 --- a/src/checker/Pulse.Checker.Prover.Match.MKeys.fst +++ b/src/checker/Pulse.Checker.Prover.Match.MKeys.fst @@ -91,6 +91,14 @@ let same_head (t0 t1:term) exception GFalse exception GTrue +(* quick unification *) +let qunif (g:env) (t0 t1 : term) : T.Tac bool = + let res = + Some? (fst (PTU.check_equiv_now_nosmt_unfold (elab_env g) t0 t1)) + in + // T.print <| "qunif " ^ show t0 ^ " " ^ show t1 ^ " = " ^ show res; + res + let rec eligible_for_smt_equality (g:env) (t0 t1 : term) : T.Tac bool = try @@ -140,11 +148,15 @@ let rec eligible_for_smt_equality (g:env) (t0 t1 : term) if binder_is_mkey b then let eq' = if binder_is_slprop b then - eligible_for_smt_equality g a0 a1 + (* For slprops, we recurse on the arguments + following the same mkey logic, but also we attempt + unification if that fails. (will this be too slow?) *) + if eligible_for_smt_equality g a0 a1 then + true + else + qunif g a0 a1 else - try - Some? (fst (PTU.check_equiv_now_nosmt_unfold (elab_env g) a0 a1)) - with | _ -> false + qunif g a0 a1 in (true, eq && eq') else diff --git a/test/nolib/MicroQueries.fst b/test/nolib/MicroQueries.fst new file mode 100644 index 000000000..e26271c7b --- /dev/null +++ b/test/nolib/MicroQueries.fst @@ -0,0 +1,25 @@ +module MicroQueries +#lang-pulse +open Pulse.Nolib + +// #set-options "--ext context_pruning=false" + +fn foo (x:int) + requires pure (x > 0) +{ (); } + +fn test (x:nat) + requires pure (x > 0) + ensures emp +{ + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; + foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; foo x; +} diff --git a/test/nolib/UnfoldArgs.fst b/test/nolib/UnfoldArgs.fst new file mode 100644 index 000000000..8c5b03ac6 --- /dev/null +++ b/test/nolib/UnfoldArgs.fst @@ -0,0 +1,51 @@ +module UnfoldArgs + +#lang-pulse +open Pulse.Nolib + +assume +val trade + ([@@@mkey] p : slprop) + ([@@@mkey] q : slprop) + : slprop + +assume val rel : int -> slprop +assume val f : int -> int +assume val g : int -> int + +type box a = + | Box of a + +[@@pulse_unfold] +let unbox (Box x) = x + +let rel2 (Box x) = rel x + +fn test1 (x : _) + requires trade (rel x) emp + ensures trade (rel2 (Box x)) emp +{ + (); +} + +fn test2 (x : _) + requires trade (rel2 (Box x)) emp + ensures trade (rel x) emp +{ + (); +} + +(* +fn test3 (x : _) + requires (rel (unbox x)) + ensures (rel2 x) +{ + (); +} + +fn test4 (x : _) + requires trade (rel (unbox x)) emp + ensures trade (rel2 x) emp +{ + (); +} From 7233c9f43437db9efea16dfff37e501b304a16e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 21 Feb 2025 11:05:29 -0800 Subject: [PATCH 26/32] Add test for krml admit --- test/nolib/AdmitKrml.fst | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 test/nolib/AdmitKrml.fst diff --git a/test/nolib/AdmitKrml.fst b/test/nolib/AdmitKrml.fst new file mode 100644 index 000000000..d2a9457b2 --- /dev/null +++ b/test/nolib/AdmitKrml.fst @@ -0,0 +1,15 @@ +module AdmitKrml + +#lang-pulse +open Pulse.Nolib + +fn test (b : bool) + returns x : UInt32.t +{ + if (b) { + 111ul; + } else { + admit(); + 222ul; + } +} From 8d0019c07d1b41c903fd0495b3aa8e7d6081c2a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 21 Feb 2025 11:26:21 -0800 Subject: [PATCH 27/32] Update expected putput (not great) --- test/bug-reports/Bug274.fst | 8 +--- test/bug-reports/Bug274.fst.output.expected | 48 +++++++++++++++++++-- 2 files changed, 47 insertions(+), 9 deletions(-) diff --git a/test/bug-reports/Bug274.fst b/test/bug-reports/Bug274.fst index aa68a6121..e9979b2e9 100644 --- a/test/bug-reports/Bug274.fst +++ b/test/bug-reports/Bug274.fst @@ -19,10 +19,8 @@ module Bug274 open Pulse.Lib.Pervasives open Pulse.Lib.Stick.Util -//works, lucky, because it appears in the right order in the precondition -// Not anymore: rejected due to ambiguity (there is no backtracking) +// Ambiguous (we don't do backtracking) [@@expect_failure] - ghost fn test_trans (p q r:slprop) requires (p @==> q) ** (q @==> r) @@ -65,10 +63,8 @@ ensures q } -// fails since unification doesn't backtrack, and unifies the first -// precondition of elim with r @==> r and then gets stuck +// Fails since this is ambiguous [@@expect_failure] - ghost fn test_elim_fails (p q r:slprop) requires (r @==> r) ** p ** (p @==> q) diff --git a/test/bug-reports/Bug274.fst.output.expected b/test/bug-reports/Bug274.fst.output.expected index a206e2dfe..dd9f335cf 100644 --- a/test/bug-reports/Bug274.fst.output.expected +++ b/test/bug-reports/Bug274.fst.output.expected @@ -1,5 +1,5 @@ >> Got issues: [ -* Error 228 at Bug274.fst(31,4-31,15): +* Error 228 at Bug274.fst(29,4-29,15): - Cannot prove any of: Pulse.Lib.Stick.stick _ _ ** Pulse.Lib.Stick.stick _ _ - In the context: @@ -19,10 +19,24 @@ and: Pulse.Lib.Stick.stick q r in the context. + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick p q + and: + Pulse.Lib.Stick.stick q r + in the context. + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick p q + and: + Pulse.Lib.Stick.stick q r + in the context. >>] >> Got issues: [ -* Error 228 at Bug274.fst(43,4-43,15): +* Error 228 at Bug274.fst(41,4-41,15): - Cannot prove any of: Pulse.Lib.Stick.stick _ _ ** Pulse.Lib.Stick.stick _ _ - In the context: @@ -42,15 +56,43 @@ and: Pulse.Lib.Stick.stick p q in the context. + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick q r + and: + Pulse.Lib.Stick.stick p q + in the context. + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick q r + and: + Pulse.Lib.Stick.stick p q + in the context. >>] >> Got issues: [ -* Error 228 at Bug274.fst(77,4-77,12): +* Error 228 at Bug274.fst(73,4-73,12): - Cannot prove any of: _ ** Pulse.Lib.Stick.stick _ _ - In the context: p ** Pulse.Lib.Stick.stick p q ** Pulse.Lib.Stick.stick r r - Some hints: + - Ambiguous match for resource: + Pulse.Lib.Stick.stick _ _ + - It can be matched by both: + Pulse.Lib.Stick.stick r r + and: + Pulse.Lib.Stick.stick p q + in the context. + - Ambiguous match for resource: + _ + - It can be matched by both: + Pulse.Lib.Stick.stick r r + and: + Pulse.Lib.Stick.stick p q + in the context. - Ambiguous match for resource: Pulse.Lib.Stick.stick _ _ - It can be matched by both: From 060bad37231a3f590de5ee8d4c56974e118e94ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 21 Feb 2025 11:17:50 -0800 Subject: [PATCH 28/32] pulse2rust/DICE/DPE: make tests slightly more incremental --- .gitignore | 3 +++ pulse2rust/tests/Makefile | 13 +++++++++++-- share/pulse/examples/dice/c.Makefile | 8 ++++++-- share/pulse/examples/dice/cbor/test/Makefile | 5 ++++- 4 files changed, 24 insertions(+), 5 deletions(-) diff --git a/.gitignore b/.gitignore index 983dbcc81..36aafc70f 100644 --- a/.gitignore +++ b/.gitignore @@ -26,3 +26,6 @@ _cache FStar _pak pulse.tar.gz + +# make touchfiles +.*.touch diff --git a/pulse2rust/tests/Makefile b/pulse2rust/tests/Makefile index 04e8b59e9..74e68d4c8 100644 --- a/pulse2rust/tests/Makefile +++ b/pulse2rust/tests/Makefile @@ -119,16 +119,25 @@ dpe.rs: $(DPE_FILES) all-rs: $(addprefix $(RUST_SRC_DIR)/, pulsetutorial_loops.rlib pulsetutorial_algorithms.rs pulsetutorial_array.rs example_slice.rlib) .PHONY: test -test: all-rs +test: .test.touch + +.test.touch: all-rs cargo test + touch $@ .PHONY: external external: + +.external.touch: ../dpe/gen-rust-bindings.sh + touch $@ .PHONY: dpe -dpe: dpe.rs external +dpe: .dpe.touch + +.dpe.touch: dpe.rs external cd ../dpe && cargo build && cd - $(MAKE) -C ../dpe -f c.Makefile + touch $@ .PHONY: test dpe diff --git a/share/pulse/examples/dice/c.Makefile b/share/pulse/examples/dice/c.Makefile index 304277d8d..5e938a026 100644 --- a/share/pulse/examples/dice/c.Makefile +++ b/share/pulse/examples/dice/c.Makefile @@ -21,9 +21,12 @@ KRML ?= $(KRML_HOME)/krml myall: verify test -extract: $(ALL_KRML_FILES) +extract: .extract.touch + +.extract.touch: $(ALL_KRML_FILES) $(call msg, "KRML") $(KRML) -skip-compilation -ccopt -Wno-unused-variable -bundle 'HACL=EverCrypt.\*,Spec.Hash.Definitions' -bundle 'DPE=*' -library Pulse.Lib.Primitives,Pulse.Lib.SpinLock,L0Core -add-include '"Pulse_Lib_SpinLock.h"' -add-include '"EverCrypt_Base.h"' -warn-error @4+9 -tmpdir $(OUTPUT_DIR) $^ + touch $@ # Note: the Karamel-generated makefiles require running with # default rules enabled, but they are disabled here (from common.mk). @@ -32,7 +35,8 @@ extract: $(ALL_KRML_FILES) # flag from the relevant component in MAKEFLAGS. test: MAKEFLAGS= test: extract - cp $(CURDIR)/external/c/hacl/* $(OUTPUT_DIR) + # Preserve timestamps for incrementality + cp -p $(CURDIR)/external/c/hacl/* $(OUTPUT_DIR) +$(MAKE) -C $(OUTPUT_DIR) -f Makefile.basic Pulse_Lib_SpinLock.o DPE.o HACL.o ifneq (,$(HACL_HOME)) ifneq (,$(wildcard $(HACL_HOME)/dist/gcc-compatible/Makefile.basic)) diff --git a/share/pulse/examples/dice/cbor/test/Makefile b/share/pulse/examples/dice/cbor/test/Makefile index 0b1e086f6..810e688e4 100644 --- a/share/pulse/examples/dice/cbor/test/Makefile +++ b/share/pulse/examples/dice/cbor/test/Makefile @@ -4,8 +4,11 @@ all: CBORTest .PHONY: CBORTest -CBORTest: CBORTest.exe +CBORTest: .CBORTest.touch + +.CBORTest.touch: CBORTest.exe ./CBORTest.exe + touch $@ CBORTest.o: CBORTest.c $(CC) -Werror -I $(KRML_HOME)/include -I $(KRML_HOME)/krmllib/dist/generic -I ../_output/ -c -o $@ $< From 3f617976eeed6b4df022db3fe175d2916e9a6687 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Fri, 21 Feb 2025 16:57:04 -0800 Subject: [PATCH 29/32] Simplify: hd (h :: t) ~> h, tl (h :: t) ~> t --- src/checker/Pulse.Simplify.fst | 73 +++++++++++++++++++++++++++++----- 1 file changed, 64 insertions(+), 9 deletions(-) diff --git a/src/checker/Pulse.Simplify.fst b/src/checker/Pulse.Simplify.fst index 62fc66242..ff12eed26 100644 --- a/src/checker/Pulse.Simplify.fst +++ b/src/checker/Pulse.Simplify.fst @@ -2,7 +2,61 @@ module Pulse.Simplify open Pulse.Show open FStar.Reflection.V2 -module T = FStar.Tactics.V2 +module T = FStar.Tactics.V2 + +let is_Cons (t:term) : T.Tac (option (term & term)) = + match T.hua t with + | Some (h, us, args) -> + if implode_qn (T.inspect_fv h) = `%Prims.Cons + then + match args with + | [(_, Q_Implicit); (h, Q_Explicit); (t, Q_Explicit)] -> Some (h,t) + | _ -> None + else + None + | _ -> None + +let is_List_Tot_hd (t:term) : T.Tac (option term) = + match T.hua t with + | Some (h, us, args) -> + if implode_qn (T.inspect_fv h) = `%List.Tot.hd + || implode_qn (T.inspect_fv h) = `%Cons?.hd + then + match args with + | [(_, Q_Implicit); (t, Q_Explicit)] -> Some t + | _ -> None + else + None + | _ -> None + +let is_List_Tot_tl (t:term) : T.Tac (option term) = + match T.hua t with + | Some (h, us, args) -> + if implode_qn (T.inspect_fv h) = `%List.Tot.tl + || implode_qn (T.inspect_fv h) = `%Cons?.tl + then + match args with + | [(_, Q_Implicit); (t, Q_Explicit)] -> Some t + | _ -> None + else + None + | _ -> None + +let simpl_list (t:term) : T.Tac term = + match is_List_Tot_hd t with + | Some x -> + begin match is_Cons x with + | Some (h, t) -> h + | None -> t + end + | None -> + match is_List_Tot_tl t with + | Some x -> + begin match is_Cons x with + | Some (_, t) -> t + | None -> t + end + | None -> t let is_Some (t:term) : T.Tac (option term) = match T.hua t with @@ -28,6 +82,14 @@ let is_Some_v (t:term) : T.Tac (option term) = None | _ -> None +let simpl_option (t:term) : T.Tac term = + match is_Some_v t with + | Some o -> + (match is_Some o with + | Some x -> x + | None -> t) + | None -> t + let is_tuple2__1 (t:term) : T.Tac (option term) = match T.hua t with | Some (h, us, args) -> @@ -135,18 +197,11 @@ let simpl_hide_reveal (t:term) : T.Tac term = end | None -> t -let simpl_option (t:term) : T.Tac term = - match is_Some_v t with - | Some o -> - (match is_Some o with - | Some x -> x - | None -> t) - | None -> t - let rec simplify (t0:term) : T.Tac term = let t = t0 in let t = simpl_proj t in let t = simpl_option t in + let t = simpl_list t in let t = simpl_hide_reveal t in let t = simpl_reveal_hide t in let t = From b9a487407d762cf70a4af4b2694b719dc3a3e08e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Mon, 24 Feb 2025 13:05:34 -0800 Subject: [PATCH 30/32] Defend against empty issues from typing reflection --- src/checker/Pulse.Typing.Env.fst | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/checker/Pulse.Typing.Env.fst b/src/checker/Pulse.Typing.Env.fst index 3f71d2bd8..ae42db3c9 100644 --- a/src/checker/Pulse.Typing.Env.fst +++ b/src/checker/Pulse.Typing.Env.fst @@ -421,6 +421,19 @@ let fail_doc_with_subissues #a (g:env) (ro : option range) = (* If for whatever reason `sub` is empty, F* will handle it well and a generic error message will be displayed *) + if Nil? sub then ( + let issue = + FStar.Issue.mk_issue_doc + "Error" + (msg @ [doc_of_string "F* did not provide any extra information on why this failed."]) + None + None + [] + in + T.log_issues [issue]; + T.raise T.Stop + ) + ; let issues = sub |> T.map (fun is -> FStar.Issue.mk_issue_doc (Issue.level_of_issue is) From 6273aaefc2c811b0d30d18012482f60c6fab2ca5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Guido=20Mart=C3=ADnez?= Date: Mon, 24 Feb 2025 13:05:56 -0800 Subject: [PATCH 31/32] Update some tests --- test/nolib/Match.fst | 59 +++++++++++++++++++++++++++++++++++++++ test/nolib/UnfoldArgs.fst | 33 ++++++++++------------ 2 files changed, 73 insertions(+), 19 deletions(-) create mode 100644 test/nolib/Match.fst diff --git a/test/nolib/Match.fst b/test/nolib/Match.fst new file mode 100644 index 000000000..aefd29b28 --- /dev/null +++ b/test/nolib/Match.fst @@ -0,0 +1,59 @@ +module Match + +#lang-pulse +open Pulse.Nolib + +type t1 = | A | B +type t2 = + | C : x:int -> y:int{x > y} -> t2 + | D + +assume val foo : int -> slprop + +let rel (x: t1) (y: t2) : slprop = + match x, y with + | A, C _ _ -> foo 1 + | B, D -> foo 2 + | _ -> pure False + +let rel_cases_pred (x:t1) (y:t2) : bool = + match x, y with + | A, C _ _ -> true + | B, D -> true + | _ -> false + +ghost +fn rel_cases (x:t1) (y:t2) + requires rel x y + ensures rel x y ** pure (rel_cases_pred x y) +{ + if (rel_cases_pred x y) { + () + } else { + rewrite rel x y as pure False; + unreachable (); + } +} + +fn test (x : t1) (y z : t2) + requires rel x y ** rel x z + ensures rel x y ** rel x z ** pure (C? y == C? z) +{ + rel_cases x y; + rel_cases x z; + match x { + A -> { + let C y1 y2 = y; + let C z1 z2 = z; + rewrite each C z1 z2 as z; + rewrite each C y1 y2 as y; + rewrite each A as x; + () + } + B -> { + let D = y; + let D = z; + (); + } + } +} \ No newline at end of file diff --git a/test/nolib/UnfoldArgs.fst b/test/nolib/UnfoldArgs.fst index 8c5b03ac6..373e61adc 100644 --- a/test/nolib/UnfoldArgs.fst +++ b/test/nolib/UnfoldArgs.fst @@ -11,41 +11,36 @@ val trade assume val rel : int -> slprop assume val f : int -> int -assume val g : int -> int +assume val g : x:int -> y:int{f y == x} -type box a = - | Box of a - -[@@pulse_unfold] -let unbox (Box x) = x - -let rel2 (Box x) = rel x +let rel2 x = rel (g (f x)) fn test1 (x : _) - requires trade (rel x) emp - ensures trade (rel2 (Box x)) emp + requires trade emp (rel2 x) + ensures trade emp (rel (g (f x))) { (); } fn test2 (x : _) - requires trade (rel2 (Box x)) emp - ensures trade (rel x) emp + requires trade emp (rel (g (f x))) + ensures trade emp (rel2 x) { (); } -(* -fn test3 (x : _) - requires (rel (unbox x)) - ensures (rel2 x) +fn test3 (y : _) + requires trade emp (rel (g y)) + ensures trade emp (rel2 (g y)) { + rewrite each y as f (g y); // ideally automated (); } -fn test4 (x : _) - requires trade (rel (unbox x)) emp - ensures trade (rel2 x) emp +fn test4 (y : _) + requires trade emp (rel2 (g y)) + ensures trade emp (rel (g y)) { + rewrite each rel2 (g y) as rel (g (f (g y))); // ideally automated? (); } From 07aa99e93be74119224532f1ba9310b6a68dd006 Mon Sep 17 00:00:00 2001 From: Tahina Ramananandro Date: Tue, 25 Feb 2025 03:47:50 +0000 Subject: [PATCH 32/32] simplify append_split without that simplification, Rust extraction needs to monomorphize fst and snd, and that does not work very well. --- lib/pulse/lib/Pulse.Lib.Slice.Util.fst | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.Slice.Util.fst b/lib/pulse/lib/Pulse.Lib.Slice.Util.fst index 14e97a8b0..f1a1531a5 100644 --- a/lib/pulse/lib/Pulse.Lib.Slice.Util.fst +++ b/lib/pulse/lib/Pulse.Lib.Slice.Util.fst @@ -38,9 +38,7 @@ fn append_split (#t: Type) (s: S.slice t) (#p: perm) (i: SZ.t) { assert pure (v1 `Seq.equal` Seq.slice (Seq.append v1 v2) 0 (SZ.v i)); assert pure (v2 `Seq.equal` Seq.slice (Seq.append v1 v2) (SZ.v i) (Seq.length v1 + Seq.length v2)); - let r = S.split s i; - rewrite each r as (fst r, snd r); - (fst r, snd r) + S.split s i; } inline_for_extraction