From 242a99bc0842848fd419241d280604ef3c3de0f8 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Thu, 23 Oct 2025 18:17:56 -0700 Subject: [PATCH 1/4] Located resources. --- lib/common/Pulse.Lib.Core.Inv.fsti | 63 +++ lib/common/Pulse.Lib.Core.Refs.fsti | 4 + lib/common/Pulse.Lib.Core.fsti | 105 ++-- .../common/Pulse.Lib.Loc.fsti | 26 +- lib/core/Pulse.Lib.Core.Inv.fst | 40 ++ lib/core/Pulse.Lib.Core.Refs.fst | 2 + lib/core/Pulse.Lib.Core.fst | 58 +- .../core/Pulse.Lib.Loc.fst | 26 +- lib/core/PulseCore.Action.fst | 130 ++++- lib/core/PulseCore.Action.fsti | 25 +- lib/core/PulseCore.Atomic.fst | 13 +- lib/core/PulseCore.Atomic.fsti | 18 +- .../PulseCore.IndirectionTheoryActions.fst | 63 ++- .../PulseCore.IndirectionTheoryActions.fsti | 5 +- lib/core/PulseCore.IndirectionTheorySep.fst | 314 +++++++++-- lib/core/PulseCore.IndirectionTheorySep.fsti | 79 ++- lib/core/PulseCore.InstantiatedSemantics.fsti | 2 + lib/core/PulseCore.KnotInstantiation.fst | 14 +- lib/core/PulseCore.KnotInstantiation.fsti | 10 +- lib/core/PulseCore.Semantics.fst | 20 + lib/pulse/lib/Pulse.Lib.AnchoredReference.fst | 8 + .../lib/Pulse.Lib.AnchoredReference.fsti | 11 + lib/pulse/lib/Pulse.Lib.Array.Core.fst | 207 +++++-- lib/pulse/lib/Pulse.Lib.Array.Core.fsti | 35 +- lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst | 2 + lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti | 3 + lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst | 2 + lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti | 4 + lib/pulse/lib/Pulse.Lib.Box.fst | 2 + lib/pulse/lib/Pulse.Lib.Box.fsti | 3 + .../lib/Pulse.Lib.CancellableInvariant.fst | 45 +- .../lib/Pulse.Lib.CancellableInvariant.fsti | 6 + lib/pulse/lib/Pulse.Lib.ConditionVar.fst | 284 +++++----- lib/pulse/lib/Pulse.Lib.ConditionVar.fsti | 8 +- lib/pulse/lib/Pulse.Lib.FlippableInv.fst | 26 +- lib/pulse/lib/Pulse.Lib.FlippableInv.fsti | 9 +- .../lib/Pulse.Lib.GhostFractionalTable.fst | 4 + .../lib/Pulse.Lib.GhostFractionalTable.fsti | 4 + lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst | 9 + .../lib/Pulse.Lib.GhostPCMReference.fsti | 8 + lib/pulse/lib/Pulse.Lib.GhostReference.fst | 1 + lib/pulse/lib/Pulse.Lib.GhostReference.fsti | 4 + lib/pulse/lib/Pulse.Lib.Inv.fst | 225 ++++++++ lib/pulse/lib/Pulse.Lib.Inv.fsti | 96 ++++ lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst | 2 + .../lib/Pulse.Lib.MonotonicGhostRef.fsti | 6 + lib/pulse/lib/Pulse.Lib.Mutex.fst | 2 + lib/pulse/lib/Pulse.Lib.Mutex.fsti | 2 + lib/pulse/lib/Pulse.Lib.OnRange.fst | 41 ++ lib/pulse/lib/Pulse.Lib.OnRange.fsti | 3 + lib/pulse/lib/Pulse.Lib.PCMReference.fst | 10 + lib/pulse/lib/Pulse.Lib.PCMReference.fsti | 3 + lib/pulse/lib/Pulse.Lib.Par.fst | 9 +- lib/pulse/lib/Pulse.Lib.Par.fsti | 18 +- lib/pulse/lib/Pulse.Lib.Pervasives.fst | 51 +- lib/pulse/lib/Pulse.Lib.Reference.fst | 2 + lib/pulse/lib/Pulse.Lib.Reference.fsti | 3 + lib/pulse/lib/Pulse.Lib.SLPropTable.fst | 4 + lib/pulse/lib/Pulse.Lib.SLPropTable.fsti | 4 + lib/pulse/lib/Pulse.Lib.Send.fst | 377 +++++++++++++ lib/pulse/lib/Pulse.Lib.Send.fsti | 135 +++++ lib/pulse/lib/Pulse.Lib.SpinLock.fst | 125 ++--- lib/pulse/lib/Pulse.Lib.SpinLock.fsti | 25 +- lib/pulse/lib/Pulse.Lib.Task.fst | 115 +++- lib/pulse/lib/Pulse.Lib.Task.fsti | 4 + lib/pulse/lib/Pulse.Lib.WithPure.fst | 69 +-- lib/pulse/lib/Pulse.Lib.WithPure.fsti | 16 + .../lib/class/Pulse.Class.Duplicable.fst | 5 - .../lib/class/Pulse.Class.Duplicable.fsti | 2 - lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst | 79 +-- lib/pulse/lib/pledge/Pulse.Lib.Pledge.fsti | 16 +- .../lib/pledge/Pulse.Lib.SendableTrade.fst | 196 +++++++ .../lib/pledge/Pulse.Lib.SendableTrade.fsti | 96 ++++ lib/pulse/lib/pledge/Pulse.Lib.Trade.fst | 23 + lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti | 7 + pulse2rust/src/Pulse2Rust.Extract.fst | 8 +- share/pulse/examples/CustomSyntax.fst | 17 +- share/pulse/examples/Dekker.fst | 30 +- share/pulse/examples/Example.StructPCM.fst | 11 +- share/pulse/examples/Invariant.fst | 73 +-- share/pulse/examples/MSort.Parallel.fst | 14 +- share/pulse/examples/PledgeArith.fst | 2 +- .../pulse/examples/PulseCorePaper.S2.Lock.fst | 27 +- share/pulse/examples/Quicksort.Parallel.fst | 30 +- share/pulse/examples/Quicksort.Task.fst | 6 +- .../examples/by-example/ParallelIncrement.fst | 106 ++-- .../PulseTutorial.AtomicsAndInvariants.fst | 75 +-- .../PulseTutorial.DoubleIncrement.fst | 6 +- .../by-example/PulseTutorial.Intro.fst | 15 +- ...ulseTutorial.MonotonicCounterShareable.fst | 14 +- ...rial.MonotonicCounterShareableFreeable.fst | 21 +- .../PulseTutorial.PCMParallelIncrement.fst | 40 +- .../PulseTutorial.ParallelIncrement.fst | 99 ++-- .../by-example/PulseTutorial.SpinLock.fst | 18 +- share/pulse/examples/parallel/ParallelFor.fst | 22 +- .../examples/parallel/Promises.Examples3.fst | 37 +- .../examples/parallel/TaskPool.Examples.fst | 6 +- src/checker/Pulse.Checker.Par.fst | 66 --- src/checker/Pulse.Checker.WithInv.fst | 513 ------------------ src/checker/Pulse.Checker.fst | 8 - src/checker/Pulse.Elaborate.Core.fst | 22 - src/checker/Pulse.Extract.Main.fst | 23 - src/checker/Pulse.Lib.Core.Typing.fst | 2 - src/checker/Pulse.Lib.Core.Typing.fsti | 23 - src/checker/Pulse.Reflection.Util.fst | 13 - src/checker/Pulse.Soundness.Par.fst | 114 ---- src/checker/Pulse.Soundness.Par.fsti | 35 -- src/checker/Pulse.Soundness.fst | 6 - src/checker/Pulse.Syntax.Base.fst | 19 - src/checker/Pulse.Syntax.Base.fsti | 13 - src/checker/Pulse.Syntax.Builder.fst | 2 - src/checker/Pulse.Syntax.Naming.fst | 19 - src/checker/Pulse.Syntax.Naming.fsti | 56 -- src/checker/Pulse.Syntax.Printer.fst | 28 - src/checker/Pulse.Typing.FV.fst | 45 -- src/checker/Pulse.Typing.LN.fst | 114 ---- src/checker/Pulse.Typing.fst | 29 - src/extraction/ExtractPulse.fst | 5 +- src/extraction/ExtractPulseOCaml.fst | 4 +- src/ml/PulseSyntaxExtension_Parser.ml | 2 - src/ml/PulseSyntaxExtension_SyntaxWrapper.ml | 6 - src/ml/pulseparser.mly | 11 +- .../PulseSyntaxExtension.Desugar.fst | 43 -- .../PulseSyntaxExtension.Sugar.fst | 56 -- .../PulseSyntaxExtension.SyntaxWrapper.fsti | 1 - test/ExtractionTest.fst | 8 +- test/ExtractionTest.ml.expected | 3 +- test/InlineArrayLen.ml.expected | 22 +- test/bug-reports/Bug.Invariants.fst | 21 +- test/pool/domainslib/Makefile | 3 + test/pool/domainslib/dune/Pulse_Lib_Task.ml | 2 +- test/pool/pulse_task/Makefile | 3 + test/pool/pulse_task/dune/Pulse_Lib_Core.ml | 2 +- 133 files changed, 3058 insertions(+), 2434 deletions(-) create mode 100644 lib/common/Pulse.Lib.Core.Inv.fsti rename src/checker/Pulse.Checker.WithInv.fsti => lib/common/Pulse.Lib.Loc.fsti (54%) create mode 100644 lib/core/Pulse.Lib.Core.Inv.fst rename src/checker/Pulse.Checker.Par.fsti => lib/core/Pulse.Lib.Loc.fst (60%) create mode 100644 lib/pulse/lib/Pulse.Lib.Inv.fst create mode 100644 lib/pulse/lib/Pulse.Lib.Inv.fsti create mode 100644 lib/pulse/lib/Pulse.Lib.Send.fst create mode 100644 lib/pulse/lib/Pulse.Lib.Send.fsti create mode 100644 lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fst create mode 100644 lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fsti delete mode 100644 src/checker/Pulse.Checker.Par.fst delete mode 100644 src/checker/Pulse.Checker.WithInv.fst delete mode 100644 src/checker/Pulse.Soundness.Par.fst delete mode 100644 src/checker/Pulse.Soundness.Par.fsti diff --git a/lib/common/Pulse.Lib.Core.Inv.fsti b/lib/common/Pulse.Lib.Core.Inv.fsti new file mode 100644 index 000000000..5251d05f1 --- /dev/null +++ b/lib/common/Pulse.Lib.Core.Inv.fsti @@ -0,0 +1,63 @@ +(* + 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.Lib.Core.Inv +open Pulse.Lib.Core +open FStar.Ghost +open PulseCore.FractionalPermission +open PulseCore.Observability +open FStar.PCM +open FStar.ExtractAs +module T = FStar.Tactics.V2 + +val inv (i:iname) (p:slprop) : slprop + +val on_inv_eq l i p : squash (on l (inv i p) == inv i p) + +val dup_inv (i:iname) (p:slprop) + : stt_ghost unit emp_inames (inv i p) (fun _ -> inv i p ** inv i p) + +val fresh_invariant + (ctx:inames { Pulse.Lib.GhostSet.is_finite ctx }) + (p:slprop) +: stt_ghost (i:iname { ~(i `GhostSet.mem` ctx) }) emp_inames p (fun i -> inv i p) + +let somewhere (p: slprop) = exists* l. on l p + +inline_for_extraction [@@extract_as + (`(fun (#a:Type0) (#obs #fp #fp' #f_opens #p i:unit) (f:unit -> Dv a) -> + f ()))] +val with_invariant + (#a:Type u#a) + (#obs:_) + (#fp:slprop) + (#fp':a -> slprop) + (#f_opens:inames) + (#p:slprop) + (i:iname { not (mem_inv f_opens i) }) + (f:(unit -> stt_atomic a #obs f_opens (somewhere (later p) ** fp) (fun x -> somewhere (later p) ** fp' x))) +: stt_atomic a #obs (add_inv f_opens i) (inv i p ** fp) (fun x -> inv i p ** fp' x) + +[@@allow_ambiguous] +val invariant_name_identifies_invariant + (#p #q:slprop) + (i:iname) + (j:iname { i == j } ) +: stt_ghost + unit + emp_inames + (inv i p ** inv j q) + (fun _ -> inv i p ** inv j q ** later (equiv p q)) diff --git a/lib/common/Pulse.Lib.Core.Refs.fsti b/lib/common/Pulse.Lib.Core.Refs.fsti index f61a5f232..3adcdfe3a 100644 --- a/lib/common/Pulse.Lib.Core.Refs.fsti +++ b/lib/common/Pulse.Lib.Core.Refs.fsti @@ -56,6 +56,8 @@ val timeless_pcm_pts_to : Lemma (timeless (pcm_pts_to r v)) [SMTPat (timeless (pcm_pts_to r v))] +val on_pcm_pts_to_eq l #a #p r v : squash (on l (pcm_pts_to #a #p r v) == pcm_pts_to r v) + let pcm_ref_null (#a:Type) (p:FStar.PCM.pcm a) @@ -159,6 +161,8 @@ val timeless_ghost_pcm_pts_to : Lemma (timeless (ghost_pcm_pts_to r v)) [SMTPat (timeless (ghost_pcm_pts_to r v))] +val on_ghost_pcm_pts_to_eq l #a #p r v : squash (on l (ghost_pcm_pts_to #a #p r v) == ghost_pcm_pts_to r v) + val ghost_pts_to_not_null (#a:Type) (#p:pcm a) diff --git a/lib/common/Pulse.Lib.Core.fsti b/lib/common/Pulse.Lib.Core.fsti index fe6b57a68..e3ed7e708 100644 --- a/lib/common/Pulse.Lib.Core.fsti +++ b/lib/common/Pulse.Lib.Core.fsti @@ -22,6 +22,7 @@ open FStar.PCM module T = FStar.Tactics.V2 open Pulse.Lib.Dv {} open FStar.ExtractAs +include Pulse.Lib.Loc (* 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 @@ -175,8 +176,6 @@ let inames_subset (is1 is2 : inames) : Type0 = let (/!) (is1 is2 : inames) : Type0 = GhostSet.disjoint is1 is2 -val inv (i:iname) (p:slprop) : 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 @@ -226,11 +225,6 @@ val frame_stt (e:stt a pre post) : stt a (pre ** frame) (fun x -> post x ** frame) -val fork - (#pre:slprop) - (f:unit -> stt unit pre (fun _ -> emp)) -: stt unit pre (fun _ -> emp) - val sub_stt (#a:Type u#a) (#pre1:slprop) (pre2:slprop) @@ -441,12 +435,44 @@ val sub_invs_ghost (_ : squash (inames_subset opens1 opens2)) : stt_ghost a opens2 pre post +//////////////////////////////////////////////////////////////////// +// Locations +//////////////////////////////////////////////////////////////////// + +val loc : loc_id -> timeless_slprop + +val loc_get () : stt_ghost loc_id emp_inames emp (fun l -> loc l) +val loc_dup l : stt_ghost unit emp_inames (loc l) (fun _ -> loc l ** loc l) +val loc_gather l #l' : stt_ghost unit emp_inames (loc l ** loc l') (fun _ -> loc l ** pure (l == l')) + +val on (l:loc_id) ([@@@mkey] p:slprop) : slprop +val on_intro #l p : stt_ghost unit emp_inames (loc l ** p) (fun _ -> loc l ** on l p) +val on_elim #l p : stt_ghost unit emp_inames (loc l ** on l p) (fun _ -> loc l ** p) + +val timeless_on (l:loc_id) (p : slprop) +: Lemma + (requires timeless p) + (ensures timeless (on l p)) + [SMTPat (timeless (on l p))] + +val on_star_eq l a b : squash (on l (a ** b) == on l a ** on l b) +val on_on_eq l1 l2 a : squash (on l1 (on l2 a) == on l2 a) +val on_loc_eq l1 l2 : squash (on l1 (loc l2) == pure (l1 == l2)) + +val ghost_impersonate_core + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre post: slprop) + (f: unit -> stt_ghost unit is pre (fun _ -> post)) + : stt_ghost unit is (on l pre) (fun _ -> on l post) + ////////////////////////////////////////////////////////////////////////// // Later ////////////////////////////////////////////////////////////////////////// val later_credit (amt: nat) : slprop +val on_later_credit_eq l n : squash (on l (later_credit n) == later_credit n) + val timeless_later_credit (amt: nat) : Lemma (timeless (later_credit amt)) [SMTPat (timeless (later_credit amt))] @@ -471,6 +497,8 @@ val later_star p q : squash (later (p ** q) == later p ** later q) val later_exists (#t: Type) (f:t->slprop) : stt_ghost unit emp_inames (later (exists* x. f x)) (fun _ -> exists* x. later (f x)) val exists_later (#t: Type) (f:t->slprop) : stt_ghost unit emp_inames (exists* x. later (f x)) (fun _ -> later (exists* x. f x)) +val on_later_eq l p : squash (on l (later p) == later (on l p)) + ////////////////////////////////////////////////////////////////////////// // Equivalence ////////////////////////////////////////////////////////////////////////// @@ -478,6 +506,8 @@ val exists_later (#t: Type) (f:t->slprop) : stt_ghost unit emp_inames (exists* x (* Two slprops are equal when approximated to the current heap level. *) val equiv (a b: slprop) : slprop +val on_equiv_eq l a b : squash (on l (equiv a b) == equiv a b) + val equiv_dup a b : stt_ghost unit emp_inames (equiv a b) fun _ -> equiv a b ** equiv a b val equiv_refl a : stt_ghost unit emp_inames emp fun _ -> equiv a a val equiv_comm a b : stt_ghost unit emp_inames (equiv a b) fun _ -> equiv b a @@ -502,6 +532,8 @@ val null_slprop_ref : slprop_ref val slprop_ref_pts_to ([@@@mkey]x: slprop_ref) (y: slprop) : slprop +val on_slprop_ref_pts_to_eq l x y : squash (on l (slprop_ref_pts_to x y) == slprop_ref_pts_to x y) + val slprop_ref_alloc (y: slprop) : stt_ghost slprop_ref emp_inames emp fun x -> slprop_ref_pts_to x y @@ -512,57 +544,6 @@ val slprop_ref_share (x: slprop_ref) (#y: slprop) val slprop_ref_gather (x: slprop_ref) (#y1 #y2: slprop) : stt_ghost unit emp_inames (slprop_ref_pts_to x y1 ** slprop_ref_pts_to x y2) fun _ -> slprop_ref_pts_to x y1 ** later (equiv y1 y2) -////////////////////////////////////////////////////////////////////////// -// Invariants -////////////////////////////////////////////////////////////////////////// - -val dup_inv (i:iname) (p:slprop) - : stt_ghost unit emp_inames (inv i p) (fun _ -> inv i p ** inv i p) - -val new_invariant (p:slprop) -: stt_ghost iname emp_inames p (fun i -> inv i p) - -val fresh_invariant - (ctx:inames { Pulse.Lib.GhostSet.is_finite ctx }) - (p:slprop) -: stt_ghost (i:iname { ~(i `GhostSet.mem` ctx) }) emp_inames p (fun i -> inv i p) - -val with_invariant - (#a:Type) - (#obs:_) - (#fp:slprop) - (#fp':a -> slprop) - (#f_opens:inames) - (#p:slprop) - (i:iname { not (mem_inv f_opens i) }) - ($f:unit -> stt_atomic a #obs f_opens - (later p ** fp) - (fun x -> later p ** fp' x)) -: stt_atomic a #obs (add_inv f_opens i) (inv i p ** fp) (fun x -> inv i p ** fp' x) - -val with_invariant_g - (#a:Type) - (#fp:slprop) - (#fp':a -> slprop) - (#f_opens:inames) - (#p:slprop) - (i:iname { not (mem_inv f_opens i) }) - ($f:unit -> stt_ghost a f_opens - (later p ** fp) - (fun x -> later p ** fp' x)) -: stt_ghost a (add_inv f_opens i) (inv i p ** fp) (fun x -> inv i p ** fp' x) - -[@@allow_ambiguous] -val invariant_name_identifies_invariant - (#p #q:slprop) - (i:iname) - (j:iname { i == j } ) -: stt_ghost - unit - emp_inames - (inv i p ** inv j q) - (fun _ -> inv i p ** inv j q ** later (equiv p q)) - (***** end computation types and combinators *****) (* This tactic is called to find non_informative witnesses. @@ -575,6 +556,11 @@ let non_info_tac () : T.Tac unit = // Some basic actions and ghost operations ////////////////////////////////////////////////////////////////////////// +val fork_core + (pre:slprop) #l + (f: (l':loc_id { process_of l' == process_of l } -> stt unit (loc l' ** on l pre) (fun _ -> emp))) +: stt unit (loc l ** pre) (fun _ -> emp) + val rewrite (p:slprop) (q:slprop) (_:slprop_equiv p q) : stt_ghost unit emp_inames p (fun _ -> q) @@ -670,7 +656,8 @@ val elim_false (a:Type) (p:a -> slprop) // Finally, a big escape hatch for introducing architecture/backend-specific // atomic operations from proven stt specifications -[@@warn_on_use "as_atomic is a an assumption"] +[@@warn_on_use "as_atomic is a an assumption"; + extract_as (`(fun (#a: Type0) (pre post: unit) (f: a) -> f))] val as_atomic (#a:Type u#0) (pre:slprop) (post:a -> slprop) (pf:stt a pre post) : stt_atomic a emp_inames pre post diff --git a/src/checker/Pulse.Checker.WithInv.fsti b/lib/common/Pulse.Lib.Loc.fsti similarity index 54% rename from src/checker/Pulse.Checker.WithInv.fsti rename to lib/common/Pulse.Lib.Loc.fsti index df26bb6d2..62096d927 100644 --- a/src/checker/Pulse.Checker.WithInv.fsti +++ b/lib/common/Pulse.Lib.Loc.fsti @@ -1,5 +1,5 @@ (* - Copyright 2023 Microsoft Research + Copyright 2025 Microsoft Research Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -14,21 +14,17 @@ limitations under the License. *) -module Pulse.Checker.WithInv +module Pulse.Lib.Loc +open FStar.Ghost -open Pulse.Syntax -open Pulse.Typing -open Pulse.Checker.Base +[@@erasable] val loc_id : Type0 -module T = FStar.Tactics.V2 +val process_of : loc_id -> loc_id +val process_of_idem (l:loc_id) : Lemma (process_of (process_of l) == process_of l) + [SMTPat (process_of (process_of l))] -val check - (g:env) - (pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (post_hint:post_hint_opt g) - (res_ppname:ppname) - (t:st_term{Tm_WithInv? t.term}) - (check:check_t) +val dummy_loc : loc_id - : T.Tac (checker_result_t g pre post_hint) +inline_for_extraction noextract instance non_informative_loc_id + : NonInformative.non_informative loc_id + = { reveal = (fun x -> reveal x) <: NonInformative.revealer loc_id } diff --git a/lib/core/Pulse.Lib.Core.Inv.fst b/lib/core/Pulse.Lib.Core.Inv.fst new file mode 100644 index 000000000..5ef74f520 --- /dev/null +++ b/lib/core/Pulse.Lib.Core.Inv.fst @@ -0,0 +1,40 @@ +(* + 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.Lib.Core.Inv +module I = PulseCore.InstantiatedSemantics +module A = PulseCore.Atomic +module T = FStar.Tactics.V2 +open PulseCore.InstantiatedSemantics +open PulseCore.FractionalPermission +open PulseCore.Observability +friend PulseCore.InstantiatedSemantics +friend Pulse.Lib.Core +module Sep = PulseCore.IndirectionTheorySep + +(* Invariants, just reexport *) +module Act = PulseCore.Action + +let inv = Act.inv + +let on_inv_eq = Sep.on_inv_eq + +//////////////////////////////////////////////////////////////////// +// Invariants +//////////////////////////////////////////////////////////////////// +let dup_inv = A.dup_inv +let fresh_invariant i p = A.fresh_invariant i p +let with_invariant i f = A.with_invariant i f +let invariant_name_identifies_invariant #p #q i j = A.invariant_name_identifies_invariant p q i j diff --git a/lib/core/Pulse.Lib.Core.Refs.fst b/lib/core/Pulse.Lib.Core.Refs.fst index 1051b6ac6..7865cea49 100644 --- a/lib/core/Pulse.Lib.Core.Refs.fst +++ b/lib/core/Pulse.Lib.Core.Refs.fst @@ -35,6 +35,7 @@ let is_null_core_pcm_ref r = PulseCore.Action.is_core_ref_null r let pcm_pts_to #a (#p:pcm a) (r:pcm_ref p) (v:a) = PulseCore.Action.pts_to #a #p r v let timeless_pcm_pts_to #a #p r v = PulseCore.Action.timeless_pts_to #a #p r v +let on_pcm_pts_to_eq = PulseCore.Action.on_pcm_pts_to_eq let pts_to_not_null #a #p r v = A.pts_to_not_null #a #p r v let alloc @@ -82,6 +83,7 @@ let null_core_ghost_pcm_ref = PulseCore.Action.core_ghost_ref_null let ghost_pcm_pts_to #a #p r v = PulseCore.Action.ghost_pts_to #a #p r v let timeless_ghost_pcm_pts_to #a #p r v = PulseCore.Action.timeless_ghost_pts_to #a #p r v +let on_ghost_pcm_pts_to_eq = PulseCore.Action.on_ghost_pcm_pts_to_eq let ghost_pts_to_not_null #a #p r v = A.ghost_pts_to_not_null #a #p r v let ghost_alloc = A.ghost_alloc let ghost_read = A.ghost_read diff --git a/lib/core/Pulse.Lib.Core.fst b/lib/core/Pulse.Lib.Core.fst index 68b461d16..9974610bc 100644 --- a/lib/core/Pulse.Lib.Core.fst +++ b/lib/core/Pulse.Lib.Core.fst @@ -139,8 +139,6 @@ let join_emp is = GhostSet.lemma_equal_intro (join_inames is emp_inames) is; GhostSet.lemma_equal_intro (join_inames emp_inames is) is -let inv i p = Act.(inv i p) -let inames_live = Sep.inames_live let add_already_there i is = GhostSet.lemma_equal_intro (add_inv is i) is //////////////////////////////////////////////////////////////////// @@ -150,7 +148,6 @@ let stt = I.stt let return_stt_noeq = I.return let bind_stt = I.bind let frame_stt = I.frame -let fork f = I.fork (f ()) let sub_stt = I.sub let conv_stt pf1 pf2 = I.conv #_ _ _ _ _ pf1 pf2 let hide_div = I.hide_div @@ -181,11 +178,38 @@ let frame_ghost = A.frame_ghost let sub_ghost = A.sub_ghost let sub_invs_ghost = A.sub_invs_stt_ghost +let rewrite_eq p q (pf:squash (p == q)) + : stt_ghost unit emp_inames p (fun _ -> q) + = slprop_equiv_elim p q; + A.noop q + +//////////////////////////////////////////////////////////////////// +// Locations +//////////////////////////////////////////////////////////////////// + +let loc = Sep.loc +let loc_get () = A.loc_get () +let loc_dup l = rewrite_eq (loc l) (loc l ** loc l) (Sep.loc_dup_eq l) +let loc_gather l1 #l2 = rewrite_eq (loc l1 ** loc l2) (loc l1 ** pure (l1 == l2)) (Sep.loc_gather_eq l1 l2) + +let on = Sep.on +let on_intro #l p = rewrite_eq (loc l ** p) (loc l ** on l p) (Sep.loc_on_eq l p) +let on_elim #l p = rewrite_eq (loc l ** on l p) (loc l ** p) (Sep.loc_on_eq l p) + +let timeless_on l p = Sep.timeless_on l p + +let on_star_eq = Sep.on_star_eq +let on_on_eq = Sep.on_on_eq +let on_loc_eq = Sep.on_loc_eq + +let ghost_impersonate_core l pre post f = A.impersonate_ghost l (f ()) + ////////////////////////////////////////////////////////////////////////// // Later ////////////////////////////////////////////////////////////////////////// let later_credit = later_credit +let on_later_credit_eq = Sep.on_later_credit_eq let timeless_later_credit amt = Sep.timeless_later_credit amt let later_credit_zero _ = PulseCore.InstantiatedSemantics.later_credit_zero () let later_credit_add a b = PulseCore.InstantiatedSemantics.later_credit_add a b @@ -216,14 +240,13 @@ let exists_later #t f = let h: squash ((exists* x. later (f x)) `implies` later (exists* x. f x)) = h in A.implies_elim _ _ +let on_later_eq = Sep.on_later_eq + ////////////////////////////////////////////////////////////////////////// // Equivalence ////////////////////////////////////////////////////////////////////////// -let rewrite_eq p q (pf:squash (p == q)) - : stt_ghost unit emp_inames p (fun _ -> q) - = slprop_equiv_elim p q; - A.noop q let equiv = I.equiv +let on_equiv_eq = Sep.on_equiv_eq let equiv_dup a b = A.equiv_dup a b let equiv_refl a = A.equiv_refl a let equiv_comm a b = rewrite_eq (equiv a b) (equiv b a) (Sep.equiv_comm a b) @@ -241,28 +264,19 @@ let later_equiv = Sep.later_equiv let slprop_ref = PulseCore.Action.slprop_ref let null_slprop_ref = PulseCore.Action.null_slprop_ref let slprop_ref_pts_to x y = PulseCore.Action.slprop_ref_pts_to x y +let on_slprop_ref_pts_to_eq l x y = Sep.on_slprop_ref_pts_to_eq l x y let slprop_ref_alloc x = A.slprop_ref_alloc x let slprop_ref_share x #y = A.slprop_ref_share x y let slprop_ref_gather x #y1 #y2 = A.slprop_ref_gather x y1 y2 -//////////////////////////////////////////////////////////////////// -// Invariants -//////////////////////////////////////////////////////////////////// -let dup_inv = A.dup_inv -let new_invariant = A.new_invariant -let fresh_invariant = A.fresh_invariant -let inames_live_inv = A.inames_live_inv -let inames_live_empty _ = rewrite_eq emp (inames_live emp_inames) (Sep.inames_live_empty ()) -let share_inames_live i j = rewrite_eq (inames_live (GhostSet.union i j)) (inames_live i ** inames_live j) (Sep.inames_live_union i j) -let gather_inames_live i j = rewrite_eq (inames_live i ** inames_live j) (inames_live (GhostSet.union i j)) (Sep.inames_live_union i j) -let with_invariant = A.with_invariant -let with_invariant_g = A.with_invariant_g -let invariant_name_identifies_invariant #p #q i j = A.invariant_name_identifies_invariant p q i j - ////////////////////////////////////////////////////////////////////////// // Some basic actions and ghost operations ////////////////////////////////////////////////////////////////////////// +let fork_core pre #l f = + let l' = l in // TODO + PulseCore.Action.fork l l' (f l') + let rewrite p q (pf:slprop_equiv p q) : stt_ghost unit emp_inames p (fun _ -> q) = slprop_equiv_elim p q; @@ -306,7 +320,7 @@ let elim_false (a:Type) (p:a -> slprop) = (A.noop (pure False)) (fun _ -> A.bind_ghost (A.elim_pure False) unreachable ) -let as_atomic #a pre post (e:stt a pre post) = admit () // intentional since it is an assumption +let as_atomic #a pre post e = admit () // intentional since it is an assumption let unfold_check_opens = () diff --git a/src/checker/Pulse.Checker.Par.fsti b/lib/core/Pulse.Lib.Loc.fst similarity index 60% rename from src/checker/Pulse.Checker.Par.fsti rename to lib/core/Pulse.Lib.Loc.fst index 9d8ed1976..a5aa712ce 100644 --- a/src/checker/Pulse.Checker.Par.fsti +++ b/lib/core/Pulse.Lib.Loc.fst @@ -1,5 +1,5 @@ (* - Copyright 2023 Microsoft Research + Copyright 2025 Microsoft Research Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -14,21 +14,15 @@ limitations under the License. *) -module Pulse.Checker.Par +module Pulse.Lib.Loc -open Pulse.Syntax -open Pulse.Typing -open Pulse.Checker.Base +[@@erased] +noeq type loc_id = { + process: nat; + thread: nat; +} -module T = FStar.Tactics.V2 +let process_of l = { l with thread = 0 } +let process_of_idem l = () -val check - (g:env) - (pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (post_hint:post_hint_opt g) - (res_ppname:ppname) - (t:st_term{Tm_Par? t.term}) - (check:check_t) - - : T.Tac (checker_result_t g pre post_hint) +let dummy_loc = { process = 0; thread = 0 } \ No newline at end of file diff --git a/lib/core/PulseCore.Action.fst b/lib/core/PulseCore.Action.fst index 22fad5240..70399c89a 100644 --- a/lib/core/PulseCore.Action.fst +++ b/lib/core/PulseCore.Action.fst @@ -381,7 +381,6 @@ let lift (#a:Type u#a) #r #opens #pre #post /////////////////////////////////////////////////////// // invariants /////////////////////////////////////////////////////// -let inv i p = inv i p let dup_inv (i:iref) (p:slprop) = lift_pre_act0_act fun #ictx -> ITA.dup_inv ictx i p let new_invariant p = lift_pre_act0_act fun #ictx -> ITA.new_invariant ictx p @@ -434,6 +433,7 @@ let core_ref_null = Mem.core_ref_null let is_core_ref_null = Mem.core_ref_is_null let pts_to #a #p r x = Sep.lift (Mem.pts_to #a #p r x) let timeless_pts_to #a #p r x = Sep.timeless_lift (Mem.pts_to #a #p r x) +let on_pcm_pts_to_eq l #a #p r v = Sep.on_lift_eq l (Mem.pts_to #a #p r v) let pts_to_not_null #a #p r v = lift_pre_act0_act fun #ictx -> ITA.lift_mem_action (Mem.pts_to_not_null_action #a #p r v) @@ -579,10 +579,20 @@ let elim_exists (#a:Type u#a) (p:a -> slprop) let drop p = lift_pre_act0_act fun #ictx -> ITA.drop #ictx p +let loc_get () = + lift_pre_act0_act #loc_id #Ghost #emp_inames #emp #loc fun #ictx frame m -> + let m1, m2 = split_mem emp (frame `Sep.star` mem_invariant ictx m) m in + assert FStar.Preorder.reflexive is_ghost_action; + let l = current_loc m1 in + interp_loc l m1; + intro_star (loc l) (frame `Sep.star` mem_invariant ictx m) m1 m2; + l, m + let core_ghost_ref = Mem.core_ghost_ref let core_ghost_ref_null = Mem.core_ghost_ref_null let ghost_pts_to #a #pcm r x = Sep.lift (Mem.ghost_pts_to #a #pcm r x) let timeless_ghost_pts_to #a #p r x = Sep.timeless_lift (Mem.ghost_pts_to #a #p r x) +let on_ghost_pcm_pts_to_eq l #a #p r v = Sep.on_lift_eq l (Mem.ghost_pts_to #a #p r v) let ghost_pts_to_not_null #a #p r v = lift_pre_act0_act fun #ictx -> ITA.lift_mem_action (Mem.ghost_pts_to_not_null_action #a #p r v) @@ -611,9 +621,121 @@ let equiv_trans (a b c:slprop) = let equiv_elim (a b:slprop) = lift_pre_act0_act fun #ictx -> ITA.equiv_elim #ictx a b -let slprop_ref = Sep.slprop_ref let null_slprop_ref = Sep.null_slprop_ref -let slprop_ref_pts_to = Sep.slprop_ref_pts_to let slprop_ref_alloc y = lift_pre_act0_act fun #ictx -> ITA.slprop_ref_alloc #ictx y let slprop_ref_share x y = lift_pre_act0_act fun #ictx -> ITA.slprop_ref_share #ictx x y -let slprop_ref_gather x y1 y2 = lift_pre_act0_act fun #ictx -> ITA.slprop_ref_gather #ictx x y1 y2 \ No newline at end of file +let slprop_ref_gather x y1 y2 = lift_pre_act0_act fun #ictx -> ITA.slprop_ref_gather #ictx x y1 y2 + +let impersonate_lem1 l m0 pre ictx frame : + Lemma + (requires interp (on l pre `star` frame `star` mem_invariant ictx m0) m0) + (ensures + (let m1 = set_loc m0 l in + (inames_ok ictx m0 <==> inames_ok ictx m1) /\ + interp (pre `star` loc l `star` on (current_loc m0) frame `star` mem_invariant ictx m1) m1)) = + let l0 = current_loc m0 in + assert interp (on l pre `star` (frame `star` mem_invariant ictx m0)) m0; + let m0z, m0abc = split_mem emp (on l pre `star` frame `star` mem_invariant ictx m0) m0 in + let m0a, m0bc = split_mem (on l pre) (frame `star` mem_invariant ictx m0) m0abc in + let m0b, m0c = split_mem frame (mem_invariant ictx m0) m0bc in + let m1z = set_loc m0z l in + interp_loc l m1z; assert interp (loc l) m1z; + let m1a = set_loc m0a l in + interp_on l pre m0a; assert interp pre m1a; + let m1b = set_loc m0b l in + set_loc_set_loc' m0b l l0; set_loc_current_loc' m0b; + interp_on l0 frame m1b; assert interp (on l0 frame) m1b; + let m1c = set_loc m0c l in + on_mem_invariant l ictx m0; interp_on l (mem_invariant ictx m0) m0c; assert interp (mem_invariant ictx m0) m1c; + let m1 = set_loc m0 l in + mem_invariant_set_loc ictx m0 l; assert mem_invariant ictx m1 == mem_invariant ictx m0; + join_set_loc m0b m0c l; assert (disjoint m1b m1c /\ join m1b m1c == set_loc m0bc l); + intro_star (on l0 frame) (mem_invariant ictx m1) m1b m1c; + let m1bc = set_loc m0bc l in + join_set_loc m0a m0bc l; assert (disjoint m1a m1bc /\ join m1a m1bc == set_loc (join m0a m0bc) l); + intro_star pre (on l0 frame `star` mem_invariant ictx m1) m1a m1bc; + let m1abc = set_loc m0abc l in + join_set_loc m0z m0abc l; assert disjoint m1z m1abc; + intro_star (loc l) (pre `star` on l0 frame `star` mem_invariant ictx m1) m1z m1abc; + inames_ok_set_loc ictx m0 l + +let impersonate_lem2 l l0 m0 post ictx frame : + Lemma + (requires interp (post `star` loc l `star` on l0 frame `star` mem_invariant ictx m0) m0) + (ensures + (let m1 = set_loc m0 l0 in + (inames_ok ictx m0 <==> inames_ok ictx m1) /\ + interp (on l post `star` frame `star` mem_invariant ictx m1) m1)) = + destruct_star (post `star` on l0 frame `star` mem_invariant ictx m0) (loc l) m0; + interp_loc l m0; assert current_loc m0 == l; + impersonate_lem1 l0 m0 frame ictx post; + let m1 = set_loc m0 l0 in + destruct_star (on l post `star` frame `star` mem_invariant ictx m1) (loc l0) m1 + +let impersonate_pre_act #a #r #ictx #pre #post l (k: pre_act a r ictx pre post) : + pre_act a r ictx (on l pre) (fun r -> on l (post r)) = + fun frame m0 -> + assert interp (on l pre `star` frame `star` mem_invariant ictx m0) m0; + let l0 = current_loc m0 in + let m1 = set_loc m0 l in + impersonate_lem1 l m0 pre ictx frame; + assert interp (pre `star` (loc l `star` on l0 frame) `star` mem_invariant ictx m1) m1; + let x, m2 = k (loc l `star` on l0 frame) m1 in + assert interp (post x `star` (loc l `star` on l0 frame) `star` mem_invariant ictx m2) m2; + let m3 = set_loc m2 l0 in + impersonate_lem2 l l0 m2 (post x) ictx frame; + introduce Ghost? r ==> is_ghost_action m0 m3 with _. ( + assert FStar.Preorder.transitive is_ghost_action + ); + x, m3 + +let impersonate #a #r #is #pre #post l k = fun #ictx -> + let (| am, fm, f |) = k #ictx in + (| am, fm, impersonate_pre_act l f |) + +let impersonate_sem_act #a (l: loc_id) (k: Sem.action state a) : + k': Sem.action state a { k'.pre == on l k.pre /\ (forall x. k'.post x == on l (k.post x)) } = + { + pre = on l k.pre; + post = F.on_domain a #(fun _ -> state.pred) (fun x -> on l (k.post x)); + step = fun frame m0 -> + let ictx = GhostSet.empty in + assert interp (on l k.pre `star` frame `star` mem_invariant ictx m0) m0; + let l0 = current_loc m0 in + let m1 = set_loc m0 l in + impersonate_lem1 l m0 k.pre ictx frame; + assert interp (k.pre `star` (loc l `star` on l0 frame) `star` mem_invariant ictx m1) m1; + let x, m2 = k.step (loc l `star` on l0 frame) m1 in + assert interp (k.post x `star` (loc l `star` on l0 frame) `star` mem_invariant ictx m2) m2; + let m3 = set_loc m2 l0 in + impersonate_lem2 l l0 m2 (k.post x) ictx frame; + x, m3 + } + +#push-options "--split_queries always" +let impersonate_stt #a #pre #post (l: loc_id) (k: stt a pre post) : stt a (on l pre) (fun x -> on l (post x)) = + introduce forall x y. on l (x `state.star` y) == on l x `state.star` on l y with on_star_eq l x y; + on_emp l; + fun _ -> Sem.apply_hom (on l) (fun act -> impersonate_sem_act l act) (k ()) +#pop-options + +let fork #p0 (l l': loc_id) (f0:stt unit (loc l' ** on l p0) (fun _ -> emp)) : + stt unit (loc l ** p0) (fun _ -> emp) = + let f0 = impersonate_stt l' f0 in + let f0: stt unit (on l' (loc l' ** on l p0)) (fun _ -> emp) = + on_emp l'; + assert F.feq (F.on_domain unit fun x -> emp) (F.on_domain unit fun x -> on l' emp); + f0 in + let f0: stt unit (on l p0) (fun _ -> emp) = + on_star_eq l' (loc l') (on l p0); + on_loc_same_eq l'; + sep_laws (); + on_on_eq l' l p0; + coerce_eq () f0 in + let f: stt unit (on l p0) (fun _ -> emp) = I.fork f0 in + let f: stt unit (on l p0 ** loc l) (fun _ -> loc l) = I.frame (loc l) f in + let f: stt unit (loc l ** p0) (fun _ -> loc l) = + loc_on_eq l p0; + sep_laws (); + coerce_eq () f in + I.bind f (fun _ -> stt_of_action0 (ITA.drop #GhostSet.empty (loc l))) \ No newline at end of file diff --git a/lib/core/PulseCore.Action.fsti b/lib/core/PulseCore.Action.fsti index fca2ec875..da9a7c28b 100644 --- a/lib/core/PulseCore.Action.fsti +++ b/lib/core/PulseCore.Action.fsti @@ -20,6 +20,7 @@ module I = PulseCore.InstantiatedSemantics module Sep = PulseCore.IndirectionTheorySep open FStar.PCM open FStar.Ghost +open Pulse.Lib.Loc open PulseCore.InstantiatedSemantics @@ -132,7 +133,7 @@ val lift (#a:Type u#a) #r #opens (#pre:slprop) (#post:a -> slprop) let add_inv (e:inames) (i:iref) : inames = GhostSet.union (singleton i) e let mem_inv (e:inames) (i:iref) : GTot bool = GhostSet.mem i e -val inv (i:iref) (p:slprop) : slprop +let inv : iref -> slprop -> slprop = Sep.inv val dup_inv (i:iref) (p:slprop) : act unit Ghost emp_inames (inv i p) (fun _ -> (inv i p) ** (inv i p)) @@ -154,7 +155,7 @@ val with_invariant (#f_opens:inames) (#p:slprop) (i:iref { not (mem_inv f_opens i) }) - (f:unit -> act a r f_opens (later p ** fp) (fun x -> later p ** fp' x)) + (f:unit -> act a r f_opens (somewhere (later p) ** fp) (fun x -> somewhere (later p) ** fp' x)) : act a r (add_inv f_opens i) ((inv i p) ** fp) (fun x -> (inv i p) ** fp' x) val invariant_name_identifies_invariant @@ -204,6 +205,8 @@ val timeless_pts_to (v:a) : Lemma (timeless (pts_to r v)) +val on_pcm_pts_to_eq l #a #p r v : squash (Sep.on l (pts_to #a #p r v) == pts_to r v) + val pts_to_not_null (#a:Type) (#p:FStar.PCM.pcm a) (r:ref a p) (v:a) : act (squash (not (is_ref_null r))) Ghost @@ -298,6 +301,9 @@ val elim_exists (#a:Type u#a) (p:a -> slprop) val drop (p:slprop) : act unit Ghost emp_inames p (fun _ -> emp) +val loc_get () +: act loc_id Ghost emp_inames emp (fun l -> Sep.loc l) + //////////////////////////////////////////////////////////////////////// // Ghost References //////////////////////////////////////////////////////////////////////// @@ -314,6 +320,8 @@ val timeless_ghost_pts_to (v:a) : Lemma (timeless (ghost_pts_to r v)) +val on_ghost_pcm_pts_to_eq l #a #p r v : squash (Sep.on l (ghost_pts_to #a #p r v) == ghost_pts_to r v) + val ghost_pts_to_not_null (#a:Type) (#p:FStar.PCM.pcm a) (r:ghost_ref p) (v:a) : act (squash (r =!= core_ghost_ref_null)) Ghost @@ -398,11 +406,11 @@ val equiv_elim (a b:slprop) /// slprop_refs [@@erasable] -val slprop_ref : Type0 +let slprop_ref : Type0 = Sep.slprop_ref val null_slprop_ref : slprop_ref -val slprop_ref_pts_to (x: slprop_ref) (y: slprop) : slprop +let slprop_ref_pts_to (x: slprop_ref) (y: slprop) : slprop = Sep.slprop_ref_pts_to x y val slprop_ref_alloc (y: slprop) : act slprop_ref Ghost emp_inames emp fun x -> slprop_ref_pts_to x y @@ -412,3 +420,12 @@ val slprop_ref_share (x:slprop_ref) (y:slprop) val slprop_ref_gather (x:slprop_ref) (y1 y2: slprop) : act unit Ghost emp_inames (slprop_ref_pts_to x y1 ** slprop_ref_pts_to x y2) fun _ -> slprop_ref_pts_to x y1 ** later (I.equiv y1 y2) + +val impersonate #a #r #is #pre #post l (k: act a r is pre post) : + act a r is (Sep.on l pre) (fun r -> Sep.on l (post r)) + +val impersonate_stt #a #pre #post (l: loc_id) (k: stt a pre post) : + stt a (Sep.on l pre) (fun x -> Sep.on l (post x)) + +val fork #p0 (l l': loc_id) (f0:stt unit (loc l' ** on l p0) (fun _ -> emp)) : + stt unit (loc l ** p0) (fun _ -> emp) \ No newline at end of file diff --git a/lib/core/PulseCore.Atomic.fst b/lib/core/PulseCore.Atomic.fst index 3cc0df789..a08d0a4e7 100644 --- a/lib/core/PulseCore.Atomic.fst +++ b/lib/core/PulseCore.Atomic.fst @@ -258,6 +258,7 @@ let ghost_reveal (a:Type) (x:erased a) pure_trivial (reveal x == reveal x) (); m +let loc_get () = lift_neutral_ghost (A.loc_get ()) let dup_inv (i:iref) (p:slprop) = lift_neutral_ghost (A.dup_inv i p) @@ -273,7 +274,7 @@ let with_invariant #a #fp #fp' #f_opens #p i $f = A.with_invariant i f let with_invariant_g #a #fp #fp' #f_opens #p i $f = - let f: act (erased a) Ghost f_opens (later p ** fp) (fun x -> later p ** fp' x) = f () in + let f: act (erased a) Ghost f_opens (somewhere (later p) ** fp) (fun x -> somewhere (later p) ** fp' x) = f () in A.with_invariant #(erased a) #Ghost #fp #(as_ghost_post fp') #f_opens #p i (fun _ -> f) let slprop_post_equiv_intro #t (#p #q: t->slprop) (h: (x:t -> squash (p x == q x))) : slprop_post_equiv p q = @@ -325,4 +326,12 @@ let equiv_elim (a b:slprop) = lift_neutral_ghost (A.equiv_elim a b) let slprop_ref_alloc y = lift_neutral_ghost (A.slprop_ref_alloc y) let slprop_ref_share x y = lift_neutral_ghost (A.slprop_ref_share x y) -let slprop_ref_gather x y1 y2 = lift_neutral_ghost (A.slprop_ref_gather x y1 y2) \ No newline at end of file +let slprop_ref_gather x y1 y2 = lift_neutral_ghost (A.slprop_ref_gather x y1 y2) + +let impersonate_atomic #a #obs #opens #pre #post l (k: stt_atomic a #obs opens pre post) : + stt_atomic a #obs opens (Sep.on l pre) (fun x -> Sep.on l (post x)) = + A.impersonate l k + +let impersonate_ghost #a #opens #pre #post l (k: stt_ghost a opens pre post) : + stt_ghost a opens (Sep.on l pre) (fun x -> Sep.on l (post x)) = + A.impersonate l k \ No newline at end of file diff --git a/lib/core/PulseCore.Atomic.fsti b/lib/core/PulseCore.Atomic.fsti index b68999db0..15c3dffa1 100644 --- a/lib/core/PulseCore.Atomic.fsti +++ b/lib/core/PulseCore.Atomic.fsti @@ -21,6 +21,7 @@ open FStar.Ghost open PulseCore.InstantiatedSemantics open PulseCore.Action open PulseCore.Observability +open Pulse.Lib.Loc module Sep = PulseCore.IndirectionTheorySep (* stt_unobservable a opens pre post: The type of a pulse computation that when run in a state satisfying `pre` @@ -229,6 +230,9 @@ val elim_exists (#a:Type u#a) (p:a -> slprop) val ghost_reveal (a:Type) (x:erased a) : stt_ghost a emp_inames emp (fun y -> pure (reveal x == y)) +val loc_get () + : stt_ghost loc_id emp_inames emp (fun l -> Sep.loc l) + ////////////////////////////////////////////////////////////////// val dup_inv (i:iref) (p:slprop) @@ -255,8 +259,8 @@ val with_invariant (#p:slprop) (i:iref { not (mem_inv f_opens i) }) ($f:unit -> stt_atomic a #obs f_opens - (later p ** fp) - (fun x -> later p ** fp' x)) + (somewhere (later p) ** fp) + (fun x -> somewhere (later p) ** fp' x)) : stt_atomic a #obs (add_inv f_opens i) ((inv i p) ** fp) (fun x -> (inv i p) ** fp' x) val with_invariant_g @@ -267,8 +271,8 @@ val with_invariant_g (#p:slprop) (i:iref { not (mem_inv f_opens i) }) ($f:unit -> stt_ghost a f_opens - (later p ** fp) - (fun x -> later p ** fp' x)) + (somewhere (later p) ** fp) + (fun x -> somewhere (later p) ** fp' x)) : stt_ghost a (add_inv f_opens i) ((inv i p) ** fp) (fun x -> (inv i p) ** fp' x) // val distinct_invariants_have_distinct_names @@ -471,3 +475,9 @@ val slprop_ref_share (x:slprop_ref) (y:slprop) val slprop_ref_gather (x:slprop_ref) (y1 y2: slprop) : stt_ghost unit emp_inames (slprop_ref_pts_to x y1 ** slprop_ref_pts_to x y2) fun _ -> slprop_ref_pts_to x y1 ** later (I.equiv y1 y2) + +val impersonate_atomic #a #obs #opens #pre #post l (k: stt_atomic a #obs opens pre post) : + stt_atomic a #obs opens (Sep.on l pre) (fun x -> Sep.on l (post x)) + +val impersonate_ghost #a #opens #pre #post l (k: stt_ghost a opens pre post) : + stt_ghost a opens (Sep.on l pre) (fun x -> Sep.on l (post x)) \ No newline at end of file diff --git a/lib/core/PulseCore.IndirectionTheoryActions.fst b/lib/core/PulseCore.IndirectionTheoryActions.fst index cbed7c167..00aa24265 100644 --- a/lib/core/PulseCore.IndirectionTheoryActions.fst +++ b/lib/core/PulseCore.IndirectionTheoryActions.fst @@ -314,37 +314,50 @@ let intro_read_inv (i:iref) (p frame:slprop) (m:mem) iname_ok i m /\ level m > 0 /\ interp (inv i p `star` later p `star` frame) m) - (ensures interp (inv i p `star` later (read_inv i m) `star` frame) m) + (ensures interp (inv i p `star` read_inv i m `star` frame) m) = sep_laws(); dup_inv_equiv i p; let sl, sr = split_mem (later p `star` inv i p) (inv i p `star` frame) m in disjoint_join_levels sl sr; - destruct_star (later p) (inv i p) sl; - inames_ok_single i p sl; - read_inv_equiv i sl p; - assert (interp (later (read_inv i sl)) sl); + read_inv_intro i sl p; + assert (interp (read_inv i sl) sl); read_inv_disjoint i sl sr; - intro_star (later (read_inv i m)) (inv i p `star` frame) sl sr + intro_star (read_inv i m) (inv i p `star` frame) sl sr -let elim_read_inv (i:iref) (p frame:slprop) (m:mem) +let intro_read_inv' (i:iref) (p frame:slprop) (m:mem) : Lemma (requires iname_ok i m /\ level m > 0 /\ - interp (inv i p `star` later (read_inv i m) `star` frame) m) - (ensures interp (inv i p `star` later p `star` frame) m) + interp (inv i p `star` somewhere (later p) `star` frame) m) + (ensures interp (inv i p `star` read_inv i m `star` frame) m) = sep_laws(); dup_inv_equiv i p; - let sl, sr = split_mem (later (read_inv i m) `star` inv i p) (inv i p `star` frame) m in + let sl, sr = split_mem (somewhere (later p) `star` inv i p) (inv i p `star` frame) m in disjoint_join_levels sl sr; - destruct_star (later (read_inv i m)) (inv i p) sl; + read_inv_intro' i sl p; + assert (interp (read_inv i sl) sl); + read_inv_disjoint i sl sr; + intro_star (read_inv i m) (inv i p `star` frame) sl sr + +let elim_read_inv (i:iref) (p frame:slprop) (m:mem) +: Lemma + (requires + iname_ok i m /\ + level m > 0 /\ + interp (inv i p `star` read_inv i m `star` frame) m) + (ensures interp (inv i p `star` somewhere (later p) `star` frame) m) += sep_laws(); + dup_inv_equiv i p; + let sl, sr = split_mem (read_inv i m `star` inv i p) (inv i p `star` frame) m in + destruct_star (read_inv i m) (inv i p) sl; inames_ok_single i p sl; read_inv_disjoint i sl sr; - assert (interp (later (read_inv i sl) `star` inv i p) sl); - destruct_star (later (read_inv i m)) (inv i p) sl; - read_inv_equiv i sl p; - assert (interp (later p) sl); - intro_star (later p) (inv i p `star` frame) sl sr + assert (interp (read_inv i sl `star` inv i p) sl); + let l = read_inv_elim i sl p in + assert (interp (somewhere (later p)) sl); + intro_star (somewhere (later p)) (inv i p `star` frame) sl sr; + l let intro_read_inv_later (i:iref) (p frame:slprop) (m:mem) : Lemma @@ -352,7 +365,7 @@ let intro_read_inv_later (i:iref) (p frame:slprop) (m:mem) iname_ok i m /\ level m > 0 /\ interp (inv i p `star` p `star` frame) m) - (ensures interp (inv i p `star` later (read_inv i m) `star` frame) m) + (ensures interp (inv i p `star` read_inv i m `star` frame) m) = sep_laws(); let s1, s2, s3 = split_mem3 (inv i p) p frame m in intro_later p s2; @@ -390,7 +403,7 @@ let fresh_invariant (e:inames) (p:slprop) (ctx:inames { Pulse.Lib.GhostSet.is_fi assert (interp (inv i p `star` frame `star` (mem_invariant (add_inv e i) s1 `star` - later (read_inv i s1))) s1); + read_inv i s1)) s1); mem_invariant_equiv e s1 i; assert (interp (inv i p `star` frame `star` mem_invariant e s1) s1); assert (is_ghost_action s0 s1); @@ -436,8 +449,8 @@ let with_invariant (#a:Type) (i:iref{not (mem_inv opened_invariants i)}) (f:_act_except a ak (add_inv opened_invariants i) - (later p `star` fp) - (fun x -> later p `star` fp' x)) + (somewhere (later p) `star` fp) + (fun x -> somewhere (later p) `star` fp' x)) : _act_except a ak opened_invariants (inv i p `star` fp) (fun x -> inv i p `star` fp' x) @@ -448,11 +461,11 @@ let with_invariant (#a:Type) assert (inames_ok (single i) s0); mem_invariant_equiv opened_invariants s0 i; assert (interp (inv i p `star` fp `star` frame `star` - (mem_invariant (add_inv opened_invariants i) s0 `star` later (read_inv i s0))) s0); - elim_read_inv i p (fp `star` frame `star` mem_invariant (add_inv opened_invariants i) s0) s0; + (mem_invariant (add_inv opened_invariants i) s0 `star` read_inv i s0)) s0); + let l = elim_read_inv i p (fp `star` frame `star` mem_invariant (add_inv opened_invariants i) s0) s0 in inames_ok_union (single i) opened_invariants s0; assert (inames_ok (add_inv opened_invariants i) s0); - assert (interp ((later p `star` fp) + assert (interp ((somewhere (later p) `star` fp) `star` (frame `star` inv i p) `star` mem_invariant (add_inv opened_invariants i) s0) s0); @@ -460,10 +473,10 @@ let with_invariant (#a:Type) inames_ok_union (single i) opened_invariants s1; assert (inames_ok (single i) s1); assert (iname_ok i s1); - intro_read_inv i p (fp' x `star` frame `star` mem_invariant (add_inv opened_invariants i) s1) s1; + intro_read_inv' i p (fp' x `star` frame `star` mem_invariant (add_inv opened_invariants i) s1) s1; assert (interp ((inv i p `star` fp' x) `star` frame - `star` (mem_invariant (add_inv opened_invariants i) s1 `star` later (read_inv i s1))) + `star` (mem_invariant (add_inv opened_invariants i) s1 `star` read_inv i s1)) s1); mem_invariant_equiv opened_invariants s1 i; assert (interp ((inv i p `star` fp' x) diff --git a/lib/core/PulseCore.IndirectionTheoryActions.fsti b/lib/core/PulseCore.IndirectionTheoryActions.fsti index 6a65fbc69..4e42f60fe 100644 --- a/lib/core/PulseCore.IndirectionTheoryActions.fsti +++ b/lib/core/PulseCore.IndirectionTheoryActions.fsti @@ -2,6 +2,7 @@ module PulseCore.IndirectionTheoryActions module PM = PulseCore.MemoryAlt module HST = PulseCore.HoareStateMonad open PulseCore.IndirectionTheorySep +open Pulse.Lib.Loc type action_kind = | GHOST @@ -80,8 +81,8 @@ val with_invariant (#a:Type) (i:iref{not (mem_inv opened_invariants i)}) (f:_act_except a ak (add_inv opened_invariants i) - (later p `star` fp) - (fun x -> later p `star` fp' x)) + (somewhere (later p) `star` fp) + (fun x -> somewhere (later p) `star` fp' x)) : _act_except a ak opened_invariants (inv i p `star` fp) (fun x -> inv i p `star` fp' x) diff --git a/lib/core/PulseCore.IndirectionTheorySep.fst b/lib/core/PulseCore.IndirectionTheorySep.fst index dc0eba489..724569276 100644 --- a/lib/core/PulseCore.IndirectionTheorySep.fst +++ b/lib/core/PulseCore.IndirectionTheorySep.fst @@ -34,6 +34,7 @@ let mem_le' (a b: premem) : prop = level_ a == level_ b /\ (forall i. hogs_val_le (read a i) (read b i)) /\ timeless_heap_le (timeless_heap_of a) (timeless_heap_of b) /\ + current_loc_ a == current_loc_ b /\ credits_ a <= credits_ b [@@"opaque_to_smt"] let mem_le = mem_le' @@ -85,10 +86,12 @@ let mem = w:premem { mem_ok w } let timeless_mem_of m = timeless_heap_of m let level (w: mem) : GTot nat = level_ w let credits (w: mem) : GTot nat = credits_ w +let current_loc (w: mem) : loc_id = current_loc_ w let unpack (x: premem) : premem2 = { saved_credits = credits_ x; timeless_heap = timeless_heap_of x; + current_loc = current_loc_ x; hogs = read x; } @@ -98,6 +101,9 @@ let update_timeless_mem m p = let update_credits m c = pack (level m) { unpack m with saved_credits = c } +let update_loc m c = + pack (level m) { unpack m with current_loc = c } + let slprop = p:mem_pred { slprop_ok p } let mk_slprop (p: premem -> prop { slprop_ok' p }) : slprop = reveal_slprop_ok (); F.on_dom _ p @@ -111,6 +117,7 @@ let reveal_mem (m: erased premem) (h: B.mem { h == timeless_heap_of m }) : m': p let m' = pack (level_ m) { timeless_heap = h; saved_credits = (unpack m).saved_credits; + current_loc = (unpack m).current_loc; hogs = (unpack m).hogs } in mem_ext m m' (fun _ -> ()); @@ -163,15 +170,18 @@ let disjoint_hogs_of_le (m1 m2: premem) : Lemma (requires mem_le m1 m2) (ensures disjoint_hogs m1 m2) = reveal_mem_le () -let empty n : mem = +let empty n l : mem = pack n { timeless_heap = B.empty_mem; saved_credits = 0; + current_loc = l; hogs = (fun _ -> None); } -let age_to_empty (m n: erased nat) : Lemma (age_to (empty n) m == empty m) [SMTPat (age_to (empty n) m)] = - mem_ext (age_to (empty n) m) (empty m) fun a -> read_age_to_ (empty n) m a +let empty_for m = empty (level_ m) (current_loc_ m) + +let age_to_empty (m n: erased nat) (l: loc_id) : Lemma (age_to (empty n l) m == empty m l) [SMTPat (age_to (empty n l) m)] = + mem_ext (age_to (empty n l) m) (empty m l) fun a -> read_age_to_ (empty n l) m a let emp : slprop = mk_slprop fun w -> True @@ -182,12 +192,14 @@ let pure p : slprop = let disjoint_mem (w0 w1:premem) : prop = disjoint_hogs w0 w1 /\ + current_loc_ w0 == current_loc_ w1 /\ B.disjoint_mem (timeless_heap_of w0) (timeless_heap_of w1) let join_premem (is0:premem) (is1:premem { disjoint_mem is0 is1 }) = pack (level_ is0) { saved_credits = credits_ is0 + credits_ is1; timeless_heap = B.join_mem (timeless_heap_of is0) (timeless_heap_of is1); + current_loc = current_loc_ is0; hogs = on _ (fun a -> match read is0 a, read is1 a with | None, None -> None @@ -244,6 +256,7 @@ let mem_le_iff (w1 w2: premem) : let w3 = pack (level_ w2) { timeless_heap = ph3; saved_credits = sc3; + current_loc = current_loc_ w1; hogs = (fun a -> read w2 a); } in mem_ext (join_premem w1 w3) w2 fun a -> () @@ -367,22 +380,25 @@ let star_assoc (x y z:slprop) : Lemma (star x (star y z) == star (star x y) z) = star__assoc x y z -let disjoint_empty w : squash (disjoint_mem w (empty (level_ w)) /\ disjoint_mem (empty (level_ w)) w) = +let disjoint_empty w : squash (disjoint_mem w (empty_for w) /\ disjoint_mem (empty_for w) w) = H2.join_empty (timeless_heap_of w); - join_premem_commutative w (empty (level_ w)) + join_premem_commutative w (empty_for w) -let join_empty w : squash (disjoint_mem (empty (level_ w)) w /\ join_premem (empty (level_ w)) w == w) = +let join_empty w : squash (disjoint_mem (empty_for w) w /\ join_premem (empty_for w) w == w) = disjoint_empty w; H2.join_empty (timeless_heap_of w); H2.join_commutative (timeless_heap_of w) B.empty_mem; - mem_ext (join_premem (empty (level_ w)) w) w fun a -> () + mem_ext (join_premem (empty_for w) w) w fun a -> () + +let empty_join w : squash (disjoint_mem w (empty_for w) /\ join_premem w (empty_for w) == w) = + join_empty w; + join_premem_commutative w (empty_for w) let star_emp (x: slprop) : squash (star x emp == x) = mem_pred_ext (star x emp) x fun w -> introduce x w ==> star x emp w with _. ( - let w2 = empty (level_ w) in - join_empty w; - join_premem_commutative w2 w; + let w2 = empty_for w in + empty_join w; star__intro x emp w w w2 ); introduce star x emp w ==> x w with _. ( @@ -419,6 +435,7 @@ let clear_except_hogs_ (w: premem) : v:premem { disjoint_mem w v /\ w == join_pr let v = pack (level_ w) { saved_credits = 0; timeless_heap = B.empty_mem; + current_loc = current_loc_ w; hogs = (fun a -> read w a); } in H2.join_empty (timeless_heap_of w); @@ -586,6 +603,7 @@ let rejuvenate1 (m: premem) (m': premem { mem_le m' (age1_ m) }) : let m'' = pack (level_ m) { saved_credits = credits_ m'; timeless_heap = timeless_heap_of m'; + current_loc = current_loc_ m'; hogs = (fun a -> if None? (read m' a) then None else read m a) } in mem_ext (age1_ m'') m' (fun _ -> ()); @@ -621,7 +639,7 @@ let later_star (p q: slprop) : squash (later (star p q) == star (later p) (later ) else ( assert later (star p q) w; join_empty w; - star_intro (later p) (later q) w (empty (level_ w)) w + star_intro (later p) (later q) w (empty_for w) w ) let timeless_star p q = @@ -669,7 +687,7 @@ let interp_equiv_star (p q r: slprop) m : ); introduce equiv p q m /\ r m ==> star (equiv p q) r m with _. ( join_empty m; - star_intro (equiv p q) r m (empty (level_ m)) m + star_intro (equiv p q) r m (empty_for m) m ) let equiv_elim (p q: slprop) : squash (equiv p q `star` p == equiv p q `star` q) = @@ -752,6 +770,138 @@ let intro_later p m = reveal_slprop_ok () let elim_later_timeless p m = () +let set_loc_ (m: premem) (l: loc_id) : premem = + pack (level_ m) { + hogs = (fun a -> read m a); + timeless_heap = timeless_heap_of m; + current_loc = l; + saved_credits = credits_ m; + } + +let set_loc (m: mem) (l: loc_id) : mem = + set_loc_ m l + +let set_loc__age1 m l : + Lemma (set_loc_ (age1_ m) l == age1_ (set_loc_ m l)) + [SMTPat (set_loc_ (age1_ m) l)] = + mem_ext (set_loc_ (age1_ m) l) (age1_ (set_loc_ m l)) fun a -> () + +let disjoint_set_loc l a b : + Lemma (requires disjoint_mem a b) + (ensures disjoint_mem (set_loc_ a l) (set_loc_ b l)) + [SMTPat (disjoint_mem (set_loc_ a l) (set_loc_ b l))] = + () + +let join_set_loc_ l a b : + Lemma (requires disjoint_mem a b) + (ensures join_premem (set_loc_ a l) (set_loc_ b l) == set_loc_ (join_premem a b) l) + [SMTPat (join_premem (set_loc_ a l) (set_loc_ b l)); SMTPat (set_loc_ (join_premem a b) l)] = + mem_ext (join_premem (set_loc_ a l) (set_loc_ b l)) (set_loc_ (join_premem a b) l) fun a -> () + +let set_loc_current_loc m : Lemma (set_loc_ m (current_loc_ m) == m) [SMTPat (set_loc_ m (current_loc_ m))] = + mem_ext (set_loc_ m (current_loc_ m)) m fun _ -> () + +let set_loc_set_loc_ l1 l2 (m: premem) : + Lemma (set_loc_ (set_loc_ m l2) l1 == set_loc_ m l1) + [SMTPat (set_loc_ (set_loc_ m l2) l1)] = + mem_ext (set_loc_ (set_loc_ m l2) l1) (set_loc_ m l1) fun _ -> () + +let set_loc_set_loc' _ _ _ = () +let set_loc_current_loc' _ = () +let join_set_loc a b l = () + +let loc (l: loc_id) : (p: slprop { timeless p }) = + reveal_slprop_ok (); + reveal_mem_le (); + mk_slprop fun m -> current_loc_ m == l + +let interp_loc l m = () + +let loc_dup_eq l = + mem_pred_ext (star (loc l) (loc l)) (loc l) fun m -> + introduce star (loc l) (loc l) m ==> loc l m with _. ( + let m1, m2 = star_elim (loc l) (loc l) m in + () + ); + introduce loc l m ==> star (loc l) (loc l) m with _. ( + join_empty m; + star_intro (loc l) (loc l) m (empty_for m) m + ) + +let loc_gather_eq l1 l2 = + mem_pred_ext (star (loc l1) (loc l2)) (star (loc l1) (pure (l1 == l2))) fun m -> + introduce star (loc l1) (loc l2) m ==> star (loc l1) (pure (l1 == l2)) m with _. ( + let m1, m2 = star_elim (loc l1) (loc l2) m in + assert l1 == l2; + star_intro (loc l1) (pure (l1 == l2)) m m1 m2 + ); + introduce star (loc l1) (pure (l1 == l2)) m ==> star (loc l1) (loc l2) m with _. ( + let m1, m2 = star_elim (loc l1) (pure (l1 == l2)) m in + star_intro (loc l1) (loc l2) m m1 m2 + ) + +let on_ (l: loc_id) (p: slprop) : mem_pred = + F.on_dom premem fun m -> p (set_loc_ m l) + +let on_affine l (p: slprop) : squash (mem_pred_affine (on_ l p)) = + reveal_slprop_ok (); + introduce forall a b. mem_le a b /\ on_ l p a ==> on_ l p b with + introduce _ ==> _ with _. ( + reveal_mem_le (); + assert mem_le (set_loc_ a l) (set_loc_ b l) + ) + +let on (l: loc_id) (p: slprop) : slprop = + reveal_slprop_ok (); + on_affine l p; + on_ l p + +let interp_on l p m = () + +let current_loc__age1 m : + Lemma (current_loc_ (age1_ m) == current_loc_ m) + [SMTPat (current_loc_ (age1_ m))] = + () + +let loc_on_eq l p = + mem_pred_ext (loc l `star` p) (loc l `star` on l p) fun m -> + introduce star (loc l) p m ==> star (loc l) (on l p) m with _. ( + let m1, m2 = star_elim (loc l) p m in + star_intro (loc l) (on l p) m m1 m2 + ); + introduce star (loc l) (on l p) m ==> star (loc l) p m with _. ( + let m1, m2 = star_elim (loc l) (on l p) m in + star_intro (loc l) p m m1 m2 + ) + +let timeless_on l (p: slprop { timeless p }) : squash (timeless (on l p)) = + () + +let on_emp l = mem_pred_ext (on l emp) emp fun _ -> () + +let on_star_eq l a b = + mem_pred_ext (on l (star a b)) (star (on l a) (on l b)) fun m -> + introduce on l (star a b) m ==> star (on l a) (on l b) m with _. ( + let m1, m2 = star_elim a b (set_loc_ m l) in + let m1' = set_loc_ m1 (current_loc_ m) in + let m2' = set_loc_ m2 (current_loc_ m) in + assert join_premem m1' m2' == set_loc_ (join_premem m1 m2) (current_loc_ m); + assert current_loc_ m1 == current_loc_ (set_loc_ m l); + star_intro (on l a) (on l b) m m1' m2' + ); + introduce star (on l a) (on l b) m ==> on l (star a b) m with _. ( + let m1, m2 = star_elim (on l a) (on l b) m in + star_intro a b (set_loc_ m l) (set_loc_ m1 l) (set_loc_ m2 l) + ) + +let on_on_eq l1 l2 (a: slprop) = mem_pred_ext (on l1 (on l2 a)) (on l2 a) fun m -> () +let on_loc_eq l1 l2 = mem_pred_ext (on l1 (loc l2)) (pure (l1 == l2)) fun m -> () +let on_loc_same_eq l = mem_pred_ext (on l (loc l)) emp fun m -> () +let on_later_credit_eq l n = mem_pred_ext (on l (later_credit n)) (later_credit n) fun m -> () +let on_later_eq l p = mem_pred_ext (on l (later p)) (later (on l p)) fun m -> () +let on_equiv_eq l a b = mem_pred_ext (on l (equiv a b)) (equiv a b) fun m -> () +let on_lift_eq l p = mem_pred_ext (on l (lift p)) (lift p) fun m -> () + let iref = address let inv (i:iref) (p:slprop) : slprop = @@ -775,10 +925,16 @@ let hogs_inames_ok_internal (e: inames) (is: premem) : prop = let hogs_inames_ok (e: inames) (is: mem) : prop = hogs_inames_ok_internal e is +let inames_ok_set_loc _ _ _ = () let inames_ok_empty m = () let inames_ok_union i j m = assert (hogs_inames_ok (GS.union i j) m <==> hogs_inames_ok i m /\ hogs_inames_ok j m) +let iname_ok i m = hogs_iname_ok i m + +let read_inv (i: iref) (is: mem { hogs_iname_ok i is }) : slprop = + let Inv p = read is i in somewhere (later p) + let rec hogs_invariant_ (ex: inames) (is: mem) (f: address) : slprop = if reveal f = 0 then emp @@ -788,7 +944,7 @@ let rec hogs_invariant_ (ex: inames) (is: mem) (f: address) : slprop = hogs_invariant_ ex is f' else match read is f' with - | Inv p -> later p `star` hogs_invariant_ ex is f' + | Inv p -> read_inv f' is `star` hogs_invariant_ ex is f' | _ -> hogs_invariant_ ex is f' let rec hogs_invariant__congr (ex: inames) (m: mem) (f1 f2: (f:address { fresh_addr m f })) : @@ -844,6 +1000,7 @@ let spend_mem m = let m' = pack (level m) { hogs = (fun a -> read m a); timeless_heap = timeless_heap_of m; + current_loc = current_loc_ m; saved_credits = if credits_ m > 0 then credits_ m - 1 else 0; } in GS.lemma_equal_intro (hogs_dom m) (hogs_dom m'); @@ -853,20 +1010,38 @@ let spend_lemma m = () let spend_disjoint m0 m1 = mem_ext (spend (join m0 m1)) (join (spend m0) m1) fun _ -> () -let iname_ok i m = hogs_iname_ok i m let inames_ok_single i p m = () let iname_ok_inames_ok i m = () -let read_inv (i: iref) (is: mem { hogs_iname_ok i is }) : slprop = - let Inv p = read is i in p +let read_inv_intro i m p = + destruct_star (later p) (inv i p) m; + let Inv p' = read m i in + assert on (current_loc m) (later p') m; + assert_norm (somewhere (later p') m == exists l. on l (later p') m); + assert somewhere (later p') m + +let read_inv_intro' i m p = + destruct_star (somewhere (later p)) (inv i p) m; + let Inv p' = read m i in + assert somewhere (later p) m; + assert_norm (somewhere (later p') m == exists l. on l (later p') m); + assert_norm (somewhere (later p) m == exists l. on l (later p) m); + assert somewhere (later p') m + +let read_inv_elim i m p = + destruct_star (read_inv i m) (inv i p) m; + let Inv p' = read m i in + assert somewhere (later p') m; + assert_norm (somewhere (later p') m == exists l. on l (later p') m); + assert_norm (somewhere (later p) m == exists l. on l (later p) m); + assert somewhere (later p) m -let read_inv_equiv i m p = () let read_inv_disjoint i m0 m1 = () let rec hogs_invariant__equiv (ex: inames) (m: mem) (i:iref { hogs_iname_ok i m /\ ~(GS.mem i ex) }) (f: address) : Lemma (hogs_invariant_ ex m f == (if i < f then - hogs_invariant_ (add_inv ex i) m f `star` later (read_inv i m) + hogs_invariant_ (add_inv ex i) m f `star` read_inv i m else hogs_invariant_ (add_inv ex i) m f)) = if reveal f = 0 then @@ -883,18 +1058,58 @@ let rec hogs_invariant__equiv (ex: inames) (m: mem) (i:iref { hogs_iname_ok i m let hogs_invariant_equiv (ex: inames) (m: mem) (i:iref { hogs_iname_ok i m /\ ~(GS.mem i ex) }) : Lemma (hogs_invariant ex m == - hogs_invariant (add_inv ex i) m `star` later (read_inv i m)) = + hogs_invariant (add_inv ex i) m `star` read_inv i m) = hogs_invariant__equiv ex m i (some_fresh_addr m) let mem_invariant_equiv e m i = hogs_invariant_equiv e m i; sep_laws() +let on_somewhere l p : Lemma (on l (somewhere p) == somewhere p) [SMTPat (on l (somewhere p))] = + mem_pred_ext (on l (somewhere p)) (somewhere p) fun m -> + assert_norm (forall m. somewhere p m == exists l. on l p m) + +let rec on_hogs_invariant_ l ex m (f: address) : + Lemma (on l (hogs_invariant_ ex m f) == hogs_invariant_ ex m f) = + if reveal f = 0 then + on_emp l + else + let f': address = f - 1 in + on_hogs_invariant_ l ex m f'; + if GS.mem f' ex then + () + else + match read m f' with + | Inv _ -> on_star_eq l (read_inv f' m) (hogs_invariant_ ex m f') + | _ -> () + +let on_hogs_invariant l ex m : + Lemma (on l (hogs_invariant ex m) == hogs_invariant ex m) = + on_hogs_invariant_ l ex m (some_fresh_addr m) + +let on_mem_invariant l ictx m = + on_hogs_invariant l ictx m + +let mem_invariant_set_loc ictx m l = hogs_invariant_congr2 ictx (set_loc m l) m + let inames_ok_hogs_dom e m = () let inames_ok_update e m0 m1 = assert forall i. GS.mem i (hogs_dom m0) <==> GS.mem i (hogs_dom m1) +let read_inv_age f' (is: mem { level_ is > 0 /\ iname_ok f' is }) (w: premem { 1 < level_ w /\ level_ w <= level_ is }) : + Lemma (requires read_inv f' is w) (ensures read_inv f' (age1 is) (age1_ w)) = + let Inv p = read is f' in + let Inv p' = read (age1 is) f' in + assert eq_at (level_ is - 1) p p'; + assert_norm (somewhere (later p) w == exists l. on l (later p) w); + let l = IndefiniteDescription.indefinite_description_ghost _ (fun l -> on l (later p) w) in + assert p (age1_ (set_loc_ w l)); reveal_slprop_ok (); assert p (age1_ (age1_ (set_loc_ w l))); + eq_at_elim (level_ is - 1) p p' (age1_ (age1_ (set_loc_ w l))); + assert_norm (somewhere (later p') (age1_ w) == exists l. on l (later p') (age1_ w)); + assert somewhere (later p') (age1_ w); + assert read_inv f' (age1 is) (age1_ w) + #push-options "--split_queries always" let rec hogs_invariant__age (e:inames) (is: mem { level_ is > 0 }) (f: address) : Lemma (forall w. 1 < level_ w /\ level_ w <= level_ is /\ hogs_invariant_ e is f w ==> @@ -910,17 +1125,16 @@ let rec hogs_invariant__age (e:inames) (is: mem { level_ is > 0 }) (f: address) match read is f' with | Inv p -> let Inv p' = read (age1_ is) f' in - assert eq_at (level_ is - 1) p p'; introduce forall (w:premem { 1 < level_ w /\ level_ w <= level_ is /\ hogs_invariant_ e is f w }). hogs_invariant_ e (age1 is) f (age1_ w) with ( - let (w1, w2) = star_elim (later p) (hogs_invariant_ e is f') w in + let (w1, w2) = star_elim (read_inv f' is) (hogs_invariant_ e is f') w in assert hogs_invariant_ e (age1 is) f' (age1_ w2); - assert p (age1_ w1); - eq_at_elim (level_ is - 1) p p' (age1_ (age1_ w1)); - reveal_slprop_ok (); - star_intro (later (later p')) (later (hogs_invariant_ e (age1 is) f')) w w1 w2; - later_star (later p') (hogs_invariant_ e (age1 is) f'); - assert (later p' `star` hogs_invariant_ e (age1 is) f') (age1_ w) + assert read_inv f' is w1; + read_inv_age f' is w1; + assert read_inv f' (age1_ is) (age1_ w1); + star_intro (later (read_inv f' (age1_ is))) (later (hogs_invariant_ e (age1 is) f')) w w1 w2; + later_star (read_inv f' (age1_ is)) (hogs_invariant_ e (age1 is) f'); + assert (read_inv f' (age1_ is) `star` hogs_invariant_ e (age1 is) f') (age1_ w) ) | _ -> () @@ -996,12 +1210,12 @@ let rec hogs_invariant__mono (ex1: inames) (ex2: inames) else match read m f' with | Inv p -> - let (w1, w2) = star_elim (later p) (hogs_invariant_ ex1 m f') w in + let (w1, w2) = star_elim (read_inv f' m) (hogs_invariant_ ex1 m f') w in hogs_invariant__mono ex1 ex2 m f' w2; join_premem_commutative w1 w2; mem_le_iff w2 w; reveal_slprop_ok (); - star_intro (later p) (hogs_invariant_ ex2 m f') w w1 w2 + star_intro (read_inv f' m) (hogs_invariant_ ex2 m f') w w1 w2 | _ -> hogs_invariant__mono ex1 ex2 m f' w #pop-options @@ -1065,24 +1279,25 @@ let mem_invariant_age e m0 m1 = let mem_invariant_spend e m = hogs_invariant_congr2 e m (spend m) -let hogs_single n (a: iref) (p: slprop) : mem = +let hogs_single n l (a: iref) (p: slprop) : mem = let m = pack n { saved_credits = 0; timeless_heap = B.empty_mem; + current_loc = l; hogs = (fun b -> if reveal a = reveal b then Inv p else None) } in assert fresh_addr m (a+1); reveal_mem_le (); reveal_slprop_ok (); m -let rec hogs_single_invariant_ n a p f : squash (hogs_invariant_ (single a) (hogs_single n a p) f == emp) = +let rec hogs_single_invariant_ n l a p f : squash (hogs_invariant_ (single a) (hogs_single n l a p) f == emp) = if reveal f = 0 then () else - hogs_single_invariant_ n a p (f - 1) + hogs_single_invariant_ n l a p (f - 1) -let hogs_single_invariant n a p : Lemma (hogs_invariant (single a) (hogs_single n a p) == emp) = - hogs_single_invariant_ n a p (some_fresh_addr (hogs_single n a p)) +let hogs_single_invariant n l a p : Lemma (hogs_invariant (single a) (hogs_single n l a p) == emp) = + hogs_single_invariant_ n l a p (some_fresh_addr (hogs_single n l a p)) let hogs_fresh_inv (p: slprop) (is: mem) (a: iref { None? (read is a) }) : is':mem { @@ -1091,14 +1306,14 @@ let hogs_fresh_inv (p: slprop) (is: mem) (a: iref { None? (read is a) }) : hogs_invariant (single a) is' == emp /\ GS.disjoint (hogs_dom is) (hogs_dom is') } = - let is' = hogs_single (level_ is) a p in - hogs_single_invariant (level_ is) a p; + let is' = hogs_single (level_ is) (current_loc_ is) a p in + hogs_single_invariant (level_ is) (current_loc_ is) a p; is' let buy1_mem m = PM.ghost_action_preorder (); join_empty m; - let m' = update_credits (empty (level m)) 1 in + let m' = update_credits (empty_for m) 1 in introduce forall (e: inames). mem_invariant e m == mem_invariant e (join_mem m' m) with hogs_invariant_congr2 e m (join_mem m' m); m' @@ -1141,7 +1356,7 @@ let fresh_inv p m ctx = let i = fresh_inv_name m ctx in let m': mem = hogs_fresh_inv p m i in let _: squash (inv i p `star` mem_invariant (single i) m' == inv i p) = - hogs_single_invariant (level m) i p; + hogs_single_invariant (level m) (current_loc m) i p; sep_laws () in Classical.forall_intro (H2.join_empty u#3); PM.ghost_action_preorder u#3 (); @@ -1162,6 +1377,8 @@ let invariant_name_identifies_invariant i p q = let (w1, w2) = star_elim (inv i p) (inv i q) m in assert later (equiv p q) m +let on_inv_eq l x y = mem_pred_ext (on l (inv x y)) (inv x y) fun m -> () + let slprop_ref = address let null_slprop_ref = 0 @@ -1173,34 +1390,35 @@ let slprop_ref_pts_to x y = read m x == Pred y' /\ eq_at (level_ m) y y' -let single_slprop_pts_to n (i: slprop_ref) (p: slprop) : mem = +let single_slprop_pts_to n l (i: slprop_ref) (p: slprop) : mem = let m = pack n { timeless_heap = B.empty_mem; saved_credits = 0; + current_loc = l; hogs = (fun a -> if reveal a = reveal i then Pred p else None); } in assert fresh_addr m (i+1); reveal_mem_le (); reveal_slprop_ok (); m -let rec hogs_invariant__single_slprop_pts_to ex (n: nat) i p f : - squash (hogs_invariant_ ex (single_slprop_pts_to n i p) f == emp) = +let rec hogs_invariant__single_slprop_pts_to ex (n: nat) l i p f : + squash (hogs_invariant_ ex (single_slprop_pts_to n l i p) f == emp) = if reveal f = 0 then () else let f': nat = f - 1 in sep_laws (); - hogs_invariant__single_slprop_pts_to ex n i p f' -let hogs_invariant_single_slprop_pts_to ex (n: nat) i p : - squash (hogs_invariant ex (single_slprop_pts_to n i p) == emp) = - hogs_invariant__single_slprop_pts_to ex n i p (some_fresh_addr (single_slprop_pts_to n i p)) + hogs_invariant__single_slprop_pts_to ex n l i p f' +let hogs_invariant_single_slprop_pts_to ex (n: nat) l i p : + squash (hogs_invariant ex (single_slprop_pts_to n l i p) == emp) = + hogs_invariant__single_slprop_pts_to ex n l i p (some_fresh_addr (single_slprop_pts_to n l i p)) let fresh_slprop_ref p m = let i = indefinite_description_ghost slprop_ref fun i -> fresh_addr m i in - let m' = single_slprop_pts_to (level_ m) i p in + let m' = single_slprop_pts_to (level_ m) (current_loc_ m) i p in assert slprop_ref_pts_to i p m'; let _: squash (slprop_ref_pts_to i p `star` mem_invariant GS.empty m' == slprop_ref_pts_to i p) = - hogs_invariant_single_slprop_pts_to GS.empty (level_ m) i p; + hogs_invariant_single_slprop_pts_to GS.empty (level_ m) (current_loc_ m) i p; star_emp emp; star_emp (slprop_ref_pts_to i p) in Classical.forall_intro (H2.join_empty u#3); @@ -1222,6 +1440,8 @@ let slprop_ref_pts_to_gather x y1 y2 = let (m1, m2) = star_elim (slprop_ref_pts_to x y1) (slprop_ref_pts_to x y2) m in star_intro (slprop_ref_pts_to x y1) (later (equiv y1 y2)) m m1 m2 +let on_slprop_ref_pts_to_eq l x y = mem_pred_ext (on l (slprop_ref_pts_to x y)) (slprop_ref_pts_to x y) fun m -> () + let implies' (p q: slprop) : prop = forall (m: premem). p m ==> q m diff --git a/lib/core/PulseCore.IndirectionTheorySep.fsti b/lib/core/PulseCore.IndirectionTheorySep.fsti index 5aeeb7d3c..b291d47bf 100644 --- a/lib/core/PulseCore.IndirectionTheorySep.fsti +++ b/lib/core/PulseCore.IndirectionTheorySep.fsti @@ -18,6 +18,7 @@ module PulseCore.IndirectionTheorySep module F = FStar.FunctionalExtensionality module PM = PulseCore.MemoryAlt module B = PulseCore.BaseHeapSig +open Pulse.Lib.Loc open FStar.Ghost let timeless_mem : Type u#4 = PM.mem u#0 @@ -26,9 +27,12 @@ val mem: Type u#4 val timeless_mem_of: mem -> timeless_mem val level (k:mem) : GTot nat val credits (k:mem) : GTot nat +val current_loc (k:mem) : loc_id let budget (m: mem) : GTot int = level m - credits m - 1 val update_timeless_mem (m: mem) (p: timeless_mem) : - n:mem { timeless_mem_of n == p /\ level m == level n /\ credits m == credits n } + n:mem { timeless_mem_of n == p /\ level m == level n /\ credits m == credits n /\ current_loc m == current_loc n } +val update_loc (m:mem) (l:loc_id) : + n:mem { timeless_mem_of n == timeless_mem_of m /\ level m == level n /\ credits m == credits n /\ current_loc n == l } [@@erasable] val slprop : Type u#4 @@ -70,6 +74,7 @@ val sep_laws (_:unit) : squash ( val disjoint (m0 m1:mem) : p:prop { p ==> B.disjoint_mem (timeless_mem_of m0) (timeless_mem_of m1) /\ + current_loc m0 == current_loc m1 /\ level m0 == level m1 } val join (m0:mem) (m1:mem { disjoint m0 m1 }) : n:mem { timeless_mem_of n == B.join_mem (timeless_mem_of m0) (timeless_mem_of m1) } @@ -121,6 +126,7 @@ val split_mem (p:slprop) (q:slprop) (m:erased mem { interp (p `star` q) m }) disjoint l r /\ reveal m == join l r /\ level l == level m /\ level r == level m /\ + current_loc l == current_loc m /\ current_loc r == current_loc m /\ interp p l /\ interp q r } @@ -218,6 +224,39 @@ val equiv_star_congr (p q r: slprop) : squash (equiv q r == equiv q r `star` equ val intro_later (p:slprop) (m:mem) : Lemma (interp p m ==> interp (later p) m) +val set_loc (m: mem) (l: loc_id) : (m':mem { + budget m' == budget m /\ + (is_full m' <==> is_full m) /\ + current_loc m' == l /\ + is_ghost_action m m' /\ + timeless_mem_of m' == timeless_mem_of m +}) + +val set_loc_set_loc' m l1 l2 : squash (set_loc (set_loc m l1) l2 == set_loc m l2) +val set_loc_current_loc' m : squash (set_loc m (current_loc m) == m) + +val join_set_loc a b l : Lemma (requires disjoint a b) + (ensures disjoint (set_loc a l) (set_loc b l) /\ join (set_loc a l) (set_loc b l) == set_loc (join a b) l) + +val loc (l:loc_id) : (p:slprop { timeless p }) +val interp_loc l m : squash (interp (loc l) m <==> l == current_loc m) +val loc_dup_eq l : squash (star (loc l) (loc l) == loc l) +val loc_gather_eq l1 l2 : squash (star (loc l1) (loc l2) == star (loc l1) (pure (l1 == l2))) + +val on (l:loc_id) (p:slprop) : slprop +val interp_on l p m : squash (interp (on l p) m <==> interp p (set_loc m l)) +val loc_on_eq l p : squash (star (loc l) p == star (loc l) (on l p)) +val timeless_on l (p: slprop { timeless p }) : squash (timeless (on l p)) +val on_emp l : squash (on l emp == emp) +val on_star_eq l a b : squash (on l (star a b) == star (on l a) (on l b)) +val on_on_eq l1 l2 a : squash (on l1 (on l2 a) == on l2 a) +val on_loc_eq l1 l2 : squash (on l1 (loc l2) == pure (l1 == l2)) +val on_loc_same_eq l : squash (on l (loc l) == emp) +val on_later_credit_eq l n : squash (on l (later_credit n) == later_credit n) +val on_later_eq l p : squash (on l (later p) == later (on l p)) +val on_equiv_eq l a b : squash (on l (equiv a b) == equiv a b) +val on_lift_eq l p : squash (on l (lift p) == lift p) + (**** Memory invariants *) [@@erasable] val iref : Type0 @@ -232,6 +271,8 @@ val hogs_inames_ok (e:inames) (m:mem) : prop let inames_ok (e:inames) (m:mem) : prop = hogs_inames_ok e m +val inames_ok_set_loc ictx m l : squash (inames_ok ictx (set_loc m l) <==> inames_ok ictx m) + (** The empty set of invariants is always empty *) val inames_ok_empty (m:mem) : Lemma (ensures inames_ok GhostSet.empty m) @@ -241,6 +282,11 @@ val inames_ok_union (i j:inames) (m:mem) inames_ok i m /\ inames_ok j m) +let somewhere (p: slprop) = exists* l. on l p + +val iname_ok (i: iref) (m: mem) : prop +val read_inv (i: iref) (m: mem { iname_ok i m }) : slprop + val hogs_invariant (ex:inames) (i:mem) : slprop let mem_invariant (e:inames) (w:mem) : slprop @@ -313,7 +359,6 @@ let mem_inv (e:inames) (i:iref) : GTot bool = GhostSet.mem i e -val iname_ok (i: iref) (m: mem) : prop val inames_ok_single (i: iref) (p:slprop) (m:mem) : Lemma (requires interp (inv i p) m) @@ -323,15 +368,18 @@ val iname_ok_inames_ok (i:iref) (m:mem) : Lemma (inames_ok (single i) m <==> iname_ok i m) [SMTPat (inames_ok (single i) m)] -val read_inv (i: iref) (m: mem { iname_ok i m }) : slprop -val read_inv_equiv (i:iref) (m:mem { iname_ok i m /\ level m > 0 }) p -: Lemma - (requires - interp (inv i p) m) - (ensures - interp (later (read_inv i m)) m - <==> - interp (later p) m) +val read_inv_intro (i:iref) (m:mem) p : + Lemma (requires interp (later p `star` inv i p) m) + (ensures iname_ok i m /\ interp (read_inv i m) m) + +val read_inv_intro' (i:iref) (m:mem) p : + Lemma (requires interp (somewhere (later p) `star` inv i p) m) + (ensures iname_ok i m /\ interp (read_inv i m) m) + +val read_inv_elim (i:iref) (m:mem { iname_ok i m }) p : + Lemma + (requires interp (read_inv i m `star` inv i p) m) + (ensures interp (somewhere (later p)) m) val read_inv_disjoint (i:iref) (m0 m1:mem) : Lemma @@ -351,8 +399,11 @@ val mem_invariant_equiv : ~(mem_inv e i)) (ensures (mem_invariant e m == - mem_invariant (add_inv e i) m `star` later (read_inv i m))) + mem_invariant (add_inv e i) m `star` read_inv i m)) + +val on_mem_invariant l ictx m : squash (on l (mem_invariant ictx m) == mem_invariant ictx m) +val mem_invariant_set_loc ictx m l : squash (mem_invariant ictx (set_loc m l) == mem_invariant ictx m) val inames_ok_hogs_dom (e:inames) (m:mem) : Lemma (inames_ok e m ==> FStar.GhostSet.subset e (hogs_dom m)) @@ -432,6 +483,8 @@ val dup_inv_equiv : val invariant_name_identifies_invariant (i: iref) (p q: slprop) : squash (star (inv i p) (inv i q) `implies` later (equiv p q)) +val on_inv_eq l i p : squash (on l (inv i p) == inv i p) + (**** References to predicates *) [@@erasable] val slprop_ref : Type0 @@ -460,3 +513,5 @@ val slprop_ref_pts_to_share (x: slprop_ref) (y: slprop) val slprop_ref_pts_to_gather (x: slprop_ref) (y1 y2: slprop) : squash ((slprop_ref_pts_to x y1 `star` slprop_ref_pts_to x y2) `implies` (slprop_ref_pts_to x y1 `star` later (equiv y1 y2))) + +val on_slprop_ref_pts_to_eq l x y : squash (on l (slprop_ref_pts_to x y) == slprop_ref_pts_to x y) \ No newline at end of file diff --git a/lib/core/PulseCore.InstantiatedSemantics.fsti b/lib/core/PulseCore.InstantiatedSemantics.fsti index 4f1f6c681..deb7b7982 100644 --- a/lib/core/PulseCore.InstantiatedSemantics.fsti +++ b/lib/core/PulseCore.InstantiatedSemantics.fsti @@ -15,6 +15,8 @@ *) module PulseCore.InstantiatedSemantics open PulseCore.IndirectionTheorySep +open Pulse.Lib.Loc +include PulseCore.IndirectionTheorySep { on, loc, somewhere } [@@erasable] let slprop : Type u#4 = slprop val timeless (p:slprop) : prop diff --git a/lib/core/PulseCore.KnotInstantiation.fst b/lib/core/PulseCore.KnotInstantiation.fst index 566471a8f..f8c60ba92 100644 --- a/lib/core/PulseCore.KnotInstantiation.fst +++ b/lib/core/PulseCore.KnotInstantiation.fst @@ -30,6 +30,7 @@ let map_hogvs #a #b (f:a -> b) : (hogvs a ^-> hogvs b) = noeq type premem_ (x: Type u#4) : Type u#4 = { hogs: hogvs x; saved_credits: erased nat; + current_loc: loc_id; timeless_heap: PM.mem u#0; } @@ -70,6 +71,9 @@ let read (m: premem) (a: address) : hogs_val = (unpack m).hogs a let level_ (w: premem) : GTot nat = IT.level w let credits_ (m: premem) : GTot nat = (unpack m).saved_credits + +let current_loc_ m = (unpack m).current_loc + let timeless_heap_of (m: premem) = (unpack m).timeless_heap let approx (n: erased nat) : (mem_pred ^-> mem_pred) = approx #_ #functor_heap n @@ -77,9 +81,9 @@ let approx_def n p w = assert_norm (approx n p w == (if IT.level w >= n then False else p w)) let premem_of2 (x: premem2) : premem_ mem_pred = - { hogs = F.on _ x.hogs; saved_credits = x.saved_credits; timeless_heap = x.timeless_heap } + { hogs = F.on _ x.hogs; saved_credits = x.saved_credits; current_loc = x.current_loc; timeless_heap = x.timeless_heap } let premem2of_ (x: premem_ mem_pred) : premem2 = - { hogs = x.hogs; saved_credits = x.saved_credits; timeless_heap = x.timeless_heap } + { hogs = x.hogs; saved_credits = x.saved_credits; current_loc = x.current_loc; timeless_heap = x.timeless_heap } let pack (n: erased nat) (x: premem2) : premem = pack n (premem_of2 x) let unpack (x: premem) : premem2 = premem2of_ (unpack x) @@ -96,10 +100,14 @@ let credits_pack n x = let x': premem_ (IT.predicate functor_heap) = premem_of2 x in IT.unpack_pack n x'; assert_norm ((map_premem (IT.approx #_ #functor_heap n) x').saved_credits == x'.saved_credits) +let current_loc_pack n x = + let x': premem_ (IT.predicate functor_heap) = premem_of2 x in + IT.unpack_pack n x'; + assert_norm ((map_premem (IT.approx #_ #functor_heap n) x').current_loc == x'.current_loc) let level_pack n x = unpack_pack n (premem_of2 x) -let mem_ext (w1: premem) (w2: premem { level_ w1 == level_ w2 /\ credits_ w1 == credits_ w2 /\ timeless_heap_of w1 == timeless_heap_of w2 }) +let mem_ext (w1: premem) w2 (h: (a: address -> squash (read w1 a == read w2 a))) : squash (w1 == w2) = pack_unpack w1; pack_unpack w2; diff --git a/lib/core/PulseCore.KnotInstantiation.fsti b/lib/core/PulseCore.KnotInstantiation.fsti index a38bff457..bf78aecc5 100644 --- a/lib/core/PulseCore.KnotInstantiation.fsti +++ b/lib/core/PulseCore.KnotInstantiation.fsti @@ -15,6 +15,7 @@ *) module PulseCore.KnotInstantiation open FStar.FunctionalExtensionality +open Pulse.Lib.Loc module F = FStar.FunctionalExtensionality module PM = PulseCore.MemoryAlt open FStar.Ghost {erased, hide, reveal} @@ -52,6 +53,7 @@ let hogs_val = hogs_val_ mem_pred val read (m: premem) (a: address) : hogs_val val level_ (w: premem) : GTot nat val credits_ (m: premem) : GTot nat +val current_loc_ (m: premem) : loc_id val timeless_heap_of (m: premem) : PM.mem u#0 val approx (n: erased nat) : (mem_pred ^-> mem_pred) @@ -62,6 +64,7 @@ val approx_def (n: erased nat) (p: mem_pred) w : noeq type premem2 : Type u#4 = { hogs: address -> hogs_val; saved_credits: erased nat; + current_loc: loc_id; timeless_heap: PM.mem u#0; } @@ -76,11 +79,14 @@ val timeless_heap_of_pack n x : val credits_pack n x : Lemma (credits_ (pack n x) == reveal x.saved_credits) [SMTPat (credits_ (pack n x))] +val current_loc_pack n x : + Lemma (current_loc_ (pack n x) == reveal x.current_loc) + [SMTPat (current_loc_ (pack n x))] val level_pack n x : Lemma (level_ (pack n x) == reveal n) [SMTPat (level_ (pack n x))] -val mem_ext (w1: premem) (w2: premem { level_ w1 == level_ w2 /\ credits_ w1 == credits_ w2 /\ timeless_heap_of w1 == timeless_heap_of w2 }) +val mem_ext (w1: premem) (w2: premem { level_ w1 == level_ w2 /\ credits_ w1 == credits_ w2 /\ current_loc_ w1 == current_loc_ w2 /\ timeless_heap_of w1 == timeless_heap_of w2 }) (h: (a: address -> squash (read w1 a == read w2 a))) : squash (w1 == w2) val mem_pred_ext (f g: mem_pred) (h: (w:premem -> squash (f w <==> g w))) : squash (f == g) @@ -90,7 +96,7 @@ val approx_read (m: premem) a : [SMTPat (read m a)] val age_to_ (m: premem) (i: erased nat) : - n:premem { credits_ n == credits_ m /\ timeless_heap_of n == timeless_heap_of m /\ level_ n == reveal i } + n:premem { credits_ n == credits_ m /\ current_loc_ n == current_loc_ m /\ timeless_heap_of n == timeless_heap_of m /\ level_ n == reveal i } val read_age_to_ (m: premem) (n: erased nat) a : Lemma (read (age_to_ m n) a == (map_hogs_val (approx n) (read m a))) diff --git a/lib/core/PulseCore.Semantics.fst b/lib/core/PulseCore.Semantics.fst index a8b91450f..0e334f749 100644 --- a/lib/core/PulseCore.Semantics.fst +++ b/lib/core/PulseCore.Semantics.fst @@ -401,6 +401,26 @@ let rec frame (#st:state u#s) let k' = frame fr k in Par m0 k' +let rec apply_hom (#st:state u#s) + (hom: st.pred->st.pred + { hom st.emp == st.emp /\ (forall x y. hom (x `st.star` y) == hom x `st.star` hom y) }) + (hom_act: (#b:Type u#act -> act:action st b -> act':action st b + { act'.pre == hom act.pre /\ (forall x. act'.post x == hom (act.post x)) })) + (#a:Type u#a) + (#p:st.pred) + (#q:post st a) + (f:m a p q) + : Dv (m u#s u#a u#act a (hom p) (F.on_dom a (fun x -> hom (q x)))) + = match f with + | Ret x -> Ret x + | Act f k -> + Act (hom_act f) (fun x -> apply_hom hom hom_act (k x)) + | Par #_ #pre0 m0 #_ #prek #postk k -> + let m0' = apply_hom hom hom_act m0 in + let k' = apply_hom hom hom_act k in + assert as_post #st #(U.raise_t unit) st.emp == as_post (hom st.emp); + Par m0' k' + (** * [fork]: Parallel execution using fork * Works by just using the `Par` node and `Ret` as its continuation diff --git a/lib/pulse/lib/Pulse.Lib.AnchoredReference.fst b/lib/pulse/lib/Pulse.Lib.AnchoredReference.fst index ac33c93dd..717d50bb6 100644 --- a/lib/pulse/lib/Pulse.Lib.AnchoredReference.fst +++ b/lib/pulse/lib/Pulse.Lib.AnchoredReference.fst @@ -58,6 +58,8 @@ let pts_to_full : p:slprop { timeless p } = core_pts_to r #q n true +let placeless_pts_to_full r n = Tactics.Typeclasses.solve + let pts_to (#a:Type) (#p:preorder a) (#anc:anchor_rel p) (r:ref a p anc) @@ -66,6 +68,8 @@ let pts_to : p:slprop { timeless p } = core_pts_to r #q n false +let placeless_pts_to r n = Tactics.Typeclasses.solve + let anchored (#a:Type) (#p:_) @@ -77,12 +81,16 @@ let anchored GPR.pts_to r k ** pure (owns_only_anchor n k) +let placeless_anchored r n = Tactics.Typeclasses.solve + let snapshot (#a:Type) (#p:_) (#anc:_) (r : ref a p anc) (n:a) : p:slprop { timeless p } = exists* (k:FRAP.knowledge anc) . GPR.pts_to r k ** pure (snapshot_pred n k) +let placeless_snapshot r n = Tactics.Typeclasses.solve + let init_val (#a:Type) (#p:_) (anc:anchor_rel p) (x:a { anc x x }) : v:FRAP.knowledge anc { fractional_ownership_maybe_with_anchor 1.0R x true true v } = let perm = (Some 1.0R, (Some x)) in diff --git a/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti b/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti index 74cb9063e..ec9d5c531 100644 --- a/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.AnchoredReference.fsti @@ -37,6 +37,9 @@ val pts_to_full (n:a) : p:slprop { timeless p } +instance val placeless_pts_to_full #a #p #anc r #pr n : + placeless (pts_to_full #a #p #anc r #pr n) + val pts_to (#a:Type) (#p:_) (#anc:_) ([@@@mkey]r:ref a p anc) @@ -44,6 +47,9 @@ val pts_to (n:a) : p:slprop { timeless p } +instance val placeless_pts_to #a #p #anc r #pr n : + placeless (pts_to #a #p #anc r #pr n) + val anchored (#a:Type) (#p:_) @@ -52,9 +58,14 @@ val anchored (n:a) : p:slprop{ timeless p } +instance val placeless_anchored #a #p #anc r n : + placeless (anchored #a #p #anc r n) + val snapshot (#a:Type) (#p:_) (#anc:_) (r : ref a p anc) (v:a) : p:slprop { timeless p } +instance val placeless_snapshot #a #p #anc r n : + placeless (snapshot #a #p #anc r n) ghost fn alloc (#a:Type) (x:a) (#p:_) (#anc:anchor_rel p) diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fst b/lib/pulse/lib/Pulse.Lib.Array.Core.fst index f4ee9d271..df1e229d0 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.fst @@ -17,7 +17,6 @@ module Pulse.Lib.Array.Core #lang-pulse open Pulse.Main -open FStar.Tactics.V2 open Pulse.Lib.Core open PulseCore.FractionalPermission open FStar.Ghost @@ -29,6 +28,7 @@ module PM = Pulse.Lib.PCM.Map open Pulse.Lib.PCM.Array module PA = Pulse.Lib.PCM.Array open Pulse.Lib.PCMReference +open Pulse.Class.Duplicable /// An abstract type to represent a base array (whole allocation @@ -41,6 +41,8 @@ noeq type base_t : Type0 = { }; } +let univ_vis : visibility = fun _ -> dummy_loc + noeq type array' : Type0 = { base_len: base_len:Ghost.erased nat { SZ.fits base_len }; @@ -49,10 +51,19 @@ type array' : Type0 = { }; offset: offset: nat { offset <= base_len }; length: length:Ghost.erased nat {offset + length <= base_len }; + alloc_loc: alloc_loc:loc_id { base_ref == null_core_pcm_ref ==> alloc_loc == dummy_loc }; + vis: vis:visibility { base_ref == null_core_pcm_ref ==> vis == univ_vis }; } let array elt = array' -let null_array' : array' = { base_len = 0; base_ref = null_core_pcm_ref; offset = 0; length = 0 } +let null_array' : array' = { + base_len = 0; + base_ref = null_core_pcm_ref; + offset = 0; + length = 0; + alloc_loc = dummy_loc; + vis = univ_vis; +} let length (#elt: Type) (a: array elt) = a.length let base_of #t (a: array t) : base_t = { base_len = a.base_len; base_ref = a.base_ref } @@ -64,28 +75,33 @@ let is_full_array (#elt: Type) (a: array elt) : Tot prop = let null #a : array a = null_array' let is_null a = is_null_core_pcm_ref a.base_ref -let lptr_of #elt (a: array elt) : pcm_ref (PA.pcm elt a.base_len) = +let pcm (elt: Type) (len: erased nat) = + PA.pcm (elt & loc_id) len + +let lptr_of #elt (a: array elt) : pcm_ref (pcm elt a.base_len) = a.base_ref [@@noextract_to "krml"] -let mk_carrier_f #elt (off: nat) (len: nat) (f: perm) (v: Seq.seq elt) (mask: nat -> bool) : - index_t len -> Pulse.Lib.PCM.Fraction.fractional elt = fun i -> +let mk_carrier_f #elt (off: nat) (len: nat) (f: perm) (v: Seq.seq elt) (mask: nat -> bool) (l: loc_id) : + index_t len -> Pulse.Lib.PCM.Fraction.fractional (elt & loc_id) = fun i -> if off <= i && i < off + Seq.length v && mask (i - off) then - Some (Seq.index v (i - off), f) + Some ((Seq.index v (i - off), l), f) else None +let carrier elt len = carrier (elt & loc_id) len + [@@noextract_to "krml"] -let mk_carrier #elt (off: nat) (len: nat) (f: perm) (v: Seq.seq elt) (mask: nat -> bool) : carrier elt len = - Map.map_literal #(index_t len) #(Pulse.Lib.PCM.Fraction.fractional elt) (mk_carrier_f off len f v mask) +let mk_carrier #elt (off: nat) (len: nat) (f: perm) (v: Seq.seq elt) (mask: nat -> bool) (l: loc_id) : carrier elt len = + Map.map_literal (mk_carrier_f off len f v mask l) irreducible let pull_mask (f: nat -> prop) (len: nat) : Ghost (nat -> bool) (requires True) (ensures fun res -> forall i. res i <==> i >= len \/ f i) = let s = Seq.init_ghost len fun i -> IndefiniteDescription.strong_excluded_middle (f i) in fun i -> if i < len then Seq.index s i else true -let mk_carrier' #t (a: array t) (f: perm) (v: Seq.seq t) (mask: nat -> prop) : GTot (carrier t a.base_len) = - mk_carrier a.offset a.base_len f v (pull_mask mask a.length) +let mk_carrier' #t (a: array t) (f: perm) (v: Seq.seq t) (mask: nat -> prop) (l: loc_id) : GTot (carrier t a.base_len) = + mk_carrier a.offset a.base_len f v (pull_mask mask a.length) l let mask_nonempty (mask: nat -> prop) (len: nat) : prop = exists i. mask i /\ i < len @@ -95,10 +111,42 @@ let squash' (t: Type u#a) = squash t let intro_squash #t (x: t) : squash' t = () let pts_to_mask #t ([@@@mkey] a: array t) (#[full_default()] f: perm) (v: erased (Seq.seq t)) (mask: nat -> prop) : slprop = - pcm_pts_to (lptr_of a) (mk_carrier' a f v mask) ** + exists* l. loc l ** + pcm_pts_to (lptr_of a) (mk_carrier' a f v mask (a.vis l)) ** pure (Seq.length v == reveal a.length /\ (mask_nonempty mask a.length ==> f <=. 1.0R) /\ squash' t) -let pts_to_mask_timeless _ _ _ _ = () +let loc_id_of_array #a (x:array a) = x.alloc_loc + +let visibility_of_array #a (x:array a) : visibility = x.vis + +ghost fn is_send_across_pts_to_mask' u#a (#t: Type u#a) a f v mask : is_send_across (visibility_of_array a) (pts_to_mask #t a #f v mask) = l1 l2 { + ghost_impersonate l1 (on l1 (pts_to_mask a #f v mask)) (on l2 (pts_to_mask a #f v mask)) fn _ { + on_elim _; + unfold pts_to_mask; + loc_gather l1; + ghost_impersonate l2 + (pcm_pts_to (lptr_of a) (mk_carrier' a f v mask (a.vis l1)) ** + pure (Seq.length v == reveal a.length /\ (mask_nonempty mask a.length ==> f <=. 1.0R) /\ squash' t)) + (on l2 (pts_to_mask a #f v mask)) + fn _ { + loc_dup l2; + fold pts_to_mask a #f v mask; + on_intro (pts_to_mask a #f v mask) + } + } +} +let is_send_across_pts_to_mask = is_send_across_pts_to_mask' + +ghost fn is_send_pts_to_mask' u#a (#t: Type u#a) a #f v mask : is_send (pts_to_mask #t a #f v mask) = l1 l2 { + is_send_across_pts_to_mask #t a f v mask l1 l2; +} +let is_send_pts_to_mask = is_send_pts_to_mask' + +let pts_to_mask_timeless #t a f v mask = + assert_norm (pts_to_mask #t a #f v mask == + exists* l. loc l ** + pcm_pts_to (lptr_of a) (mk_carrier' a f v mask (a.vis l)) ** + pure (Seq.length v == reveal a.length /\ (mask_nonempty mask a.length ==> f <=. 1.0R) /\ squash' t)) ghost fn pts_to_mask_props u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask @@ -145,7 +193,8 @@ ghost fn mask_vext u#a (#t: Type u#a) (arr: array t) #f #v v' #mask ensures pts_to_mask arr #f v' mask { unfold pts_to_mask arr #f v mask; - assert pure (mk_carrier' arr f v mask `Map.equal` mk_carrier' arr f v' mask); + with l. assert loc l; + assert pure (mk_carrier' arr f v mask (arr.vis l) `Map.equal` mk_carrier' arr f v' mask (arr.vis l)); fold pts_to_mask arr #f v' mask; } @@ -155,7 +204,8 @@ ghost fn mask_mext u#a (#t: Type u#a) (arr: array t) #f #v #mask (mask': nat -> ensures pts_to_mask arr #f v mask' { unfold pts_to_mask arr #f v mask; - assert pure (mk_carrier' arr f v mask `Map.equal` mk_carrier' arr f v mask'); + with l. assert loc l; + assert pure (mk_carrier' arr f v mask (arr.vis l) `Map.equal` mk_carrier' arr f v mask' (arr.vis l)); fold pts_to_mask arr #f v mask'; } @@ -171,23 +221,43 @@ ghost fn mask_ext u#a (#t: Type u#a) (arr: array t) #f #v #mask v' (mask': nat - } [@@noextract_to "krml"] -fn mask_alloc u#a (#elt: Type u#a) {| small_type u#a |} (x: elt) (n: SZ.t) +fn mask_alloc_with_vis u#a (#elt: Type u#a) {| small_type u#a |} + (x: elt) (n: SZ.t) (#l:loc_id) + (vis:visibility) + preserves loc l returns a: array elt ensures pts_to_mask a (Seq.create (SZ.v n) x) (fun _ -> True) - ensures pure (length a == SZ.v n /\ is_full_array a) + ensures pure ( + length a == SZ.v n /\ + is_full_array a /\ + visibility_of_array a == vis /\ + loc_id_of_array a == l) { - let v = mk_carrier 0 (SZ.v n) 1.0R (Seq.create (SZ.v n) x) (fun _ -> true); - FStar.PCM.compatible_refl (PA.pcm elt (SZ.v n)) v; - let b = alloc #_ #(PA.pcm elt (SZ.v n)) v; + loc_dup l; + let v = mk_carrier 0 (SZ.v n) 1.0R (Seq.create (SZ.v n) x) (fun _ -> true) (vis l); + FStar.PCM.compatible_refl (pcm elt (SZ.v n)) v; + let b = alloc #_ #(pcm elt (SZ.v n)) v; pts_to_not_null b _; - let arr: array elt = { base_ref = b; base_len = SZ.v n; length = SZ.v n; offset = 0 }; + let arr: array elt = { base_ref = b; base_len = SZ.v n; length = SZ.v n; offset = 0; alloc_loc = l; vis }; rewrite each b as lptr_of arr; - assert pure (v `Map.equal` mk_carrier' arr 1.0R (Seq.create (SZ.v n) x) (fun _ -> l_True)); + assert pure (v `Map.equal` mk_carrier' arr 1.0R (Seq.create (SZ.v n) x) (fun _ -> l_True) (vis l)); intro_squash x; fold pts_to_mask arr (Seq.create (SZ.v n) x) (fun _ -> l_True); arr } +noextract inline_for_extraction +fn mask_alloc u#a (#elt: Type u#a) {| small_type u#a |} (x: elt) (n: SZ.t) + returns a: array elt + ensures pts_to_mask a (Seq.create (SZ.v n) x) (fun _ -> True) + ensures pure (length a == SZ.v n /\ is_full_array a /\ visibility_of_array a == process_of) +{ + let l = loc_get (); + let arr = mask_alloc_with_vis x n process_of; + drop_ (loc l); + arr +} + [@@noextract_to "krml"] fn mask_free u#a (#elt: Type u#a) (a: array elt) (#s: Ghost.erased (Seq.seq elt)) #mask requires pts_to_mask a s mask @@ -210,65 +280,74 @@ ghost fn pcm_rw u#a (#t: Type u#a) requires pure ( a1.base_len == a2.base_len /\ a1.base_ref == a2.base_ref /\ + a1.alloc_loc == a2.alloc_loc /\ a1.vis == a2.vis /\ reveal a2.length == Seq.length s2 /\ - mk_carrier' a1 p1 s1 m1 `Map.equal` mk_carrier' a2 p2 s2 m2 + (forall l. mk_carrier' a1 p1 s1 m1 l `Map.equal` mk_carrier' a2 p2 s2 m2 l) ) ensures pts_to_mask #t a2 #p2 s2 m2 { unfold pts_to_mask a1 #p1 s1 m1; + with l. assert loc l; rewrite each lptr_of a1 as lptr_of a2; let i = get_mask_idx m2 (length a2); assert pure (mask_nonempty m2 (length a2) ==> - Map.sel (mk_carrier' a2 p2 s2 m2) (i + a2.offset) == Some (Seq.index s2 i, p2)); + Map.sel (mk_carrier' a2 p2 s2 m2 (process_of l)) (i + a2.offset) == Some ((Seq.index s2 i, process_of l), p2)); fold pts_to_mask a2 #p2 s2 m2; } -ghost fn pcm_share u#a (#t: Type u#a) +ghost fn pcm_share u#a (#t: Type u#a) #l (a: array t) p s m (a1: array t) p1 s1 m1 (a2: array t) p2 s2 m2 + preserves loc l requires pts_to_mask a #p s m requires pure (Seq.length s1 == a1.length) requires pure (Seq.length s2 == a2.length) requires pure ( a1.base_len == a.base_len /\ a2.base_len == a.base_len /\ a1.base_ref == a.base_ref /\ a2.base_ref == a.base_ref /\ - composable (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2) /\ - compose (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2) - `Map.equal` mk_carrier' a p s m + a1.alloc_loc == a.alloc_loc /\ a1.vis == a.vis /\ + a2.alloc_loc == a.alloc_loc /\ a2.vis == a.vis /\ + composable (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) /\ + compose (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) + `Map.equal` mk_carrier' a p s m (a.vis l) ) ensures pts_to_mask a1 #p1 s1 m1 ensures pts_to_mask a2 #p2 s2 m2 { unfold pts_to_mask a #p s m; - share (lptr_of a) (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2); + loc_gather l; + share (lptr_of a) (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)); rewrite - pcm_pts_to (lptr_of a) (mk_carrier' a1 p1 s1 m1) as - pcm_pts_to (lptr_of a1) (mk_carrier' a1 p1 s1 m1); + pcm_pts_to (lptr_of a) (mk_carrier' a1 p1 s1 m1 (a1.vis l)) as + pcm_pts_to (lptr_of a1) (mk_carrier' a1 p1 s1 m1 (a1.vis l)); rewrite - pcm_pts_to (lptr_of a) (mk_carrier' a2 p2 s2 m2) as - pcm_pts_to (lptr_of a2) (mk_carrier' a2 p2 s2 m2); + pcm_pts_to (lptr_of a) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) as + pcm_pts_to (lptr_of a2) (mk_carrier' a2 p2 s2 m2 (a2.vis l)); let i1 = get_mask_idx m1 (length a1); let i2 = get_mask_idx m2 (length a2); assert pure (mask_nonempty m1 (length a1) ==> - Some? (Map.sel (mk_carrier' a p s m) (i1 + a1.offset))); + Some? (Map.sel (mk_carrier' a p s m (a.vis l)) (i1 + a1.offset))); + loc_dup l; fold pts_to_mask a1 #p1 s1 m1; assert pure (mask_nonempty m2 (length a2) ==> - Some? (Map.sel (mk_carrier' a p s m) (i2 + a2.offset))); + Some? (Map.sel (mk_carrier' a p s m (a.vis l)) (i2 + a2.offset))); + loc_dup l; fold pts_to_mask a2 #p2 s2 m2; } -ghost fn pcm_gather u#a (#t: Type u#a) +ghost fn pcm_gather u#a (#t: Type u#a) #l (a: array t) p s m (a1: array t) p1 s1 m1 (a2: array t) p2 s2 m2 + preserves loc l requires pure (Seq.length s == a.length) requires pure ( a1.base_len == a.base_len /\ a2.base_len == a.base_len /\ a1.base_ref == a.base_ref /\ a2.base_ref == a.base_ref /\ - (composable (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2) ==> - compose (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2) - `Map.equal` mk_carrier' a p s m) + (composable (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) ==> + compose (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) + `Map.equal` mk_carrier' a p s m (a.vis l)) ) requires pts_to_mask a1 #p1 s1 m1 requires pts_to_mask a2 #p2 s2 m2 @@ -276,23 +355,26 @@ ghost fn pcm_gather u#a (#t: Type u#a) ensures pure ( a1.base_len == a.base_len /\ a2.base_len == a.base_len /\ a1.base_ref == a.base_ref /\ a2.base_ref == a.base_ref /\ - composable (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2) /\ - compose (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2) - `Map.equal` mk_carrier' a p s m + composable (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) /\ + compose (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) + `Map.equal` mk_carrier' a p s m (a.vis l) ) { unfold pts_to_mask a1 #p1 s1 m1; + loc_gather l; unfold pts_to_mask a2 #p2 s2 m2; + loc_gather l; rewrite - pcm_pts_to (lptr_of a1) (mk_carrier' a1 p1 s1 m1) as - pcm_pts_to (lptr_of a) (mk_carrier' a1 p1 s1 m1); + pcm_pts_to (lptr_of a1) (mk_carrier' a1 p1 s1 m1 (a1.vis l)) as + pcm_pts_to (lptr_of a) (mk_carrier' a1 p1 s1 m1 (a1.vis l)); rewrite - pcm_pts_to (lptr_of a2) (mk_carrier' a2 p2 s2 m2) as - pcm_pts_to (lptr_of a) (mk_carrier' a2 p2 s2 m2); - gather (lptr_of a) (mk_carrier' a1 p1 s1 m1) (mk_carrier' a2 p2 s2 m2); + pcm_pts_to (lptr_of a2) (mk_carrier' a2 p2 s2 m2 (a2.vis l)) as + pcm_pts_to (lptr_of a) (mk_carrier' a2 p2 s2 m2 (a2.vis l)); + gather (lptr_of a) (mk_carrier' a1 p1 s1 m1 (a1.vis l)) (mk_carrier' a2 p2 s2 m2 (a2.vis l)); let i = get_mask_idx m (length a); assert pure (mask_nonempty m a.length ==> - Map.sel (mk_carrier' a p s m) (i + a.offset) == Some (Seq.index s i, p)); + Map.sel (mk_carrier' a p s m (a.vis l)) (i + a.offset) == Some ((Seq.index s i, a.vis l), p)); + loc_dup l; fold pts_to_mask a #p s m; } @@ -302,11 +384,13 @@ fn mask_share u#a (#a: Type u#a) (arr:array a) (#s: Seq.seq a) #p #mask ensures pts_to_mask arr #(p /. 2.0R) s mask ensures pts_to_mask arr #(p /. 2.0R) s mask { + loc_get (); pts_to_mask_props arr; pcm_share arr p s mask arr (p /. 2.0R) s mask arr (p /. 2.0R) s mask; + drop_ (loc _); } [@@allow_ambiguous] @@ -318,6 +402,7 @@ ghost fn mask_gather u#a (#t: Type u#a) (arr: array t) #p1 #p2 #s1 #s2 #mask1 #m pure ((Seq.length v == Seq.length s1 /\ Seq.length v == Seq.length s2) /\ (forall (i: nat). i < Seq.length v /\ mask1 i ==> Seq.index v i == Seq.index s1 i /\ Seq.index v i == Seq.index s2 i)) { + let l = loc_get (); mask_mext arr #p2 #s2 mask1; pts_to_mask_props arr #p1 #s1 #mask1; pts_to_mask_props arr #p2 #s2 #mask1; @@ -326,7 +411,9 @@ ghost fn mask_gather u#a (#t: Type u#a) (arr: array t) #p1 #p2 #s1 #s2 #mask1 #m arr p1 s1 mask1 arr p2 s2 mask1; assert pure (forall (i: nat). (i < Seq.length s1 /\ mask1 i) ==> - Map.sel (mk_carrier' arr p1 s1 mask1) (i + arr.offset) == Some (Seq.index s1 i, p1)); + Map.sel (mk_carrier' arr p1 s1 mask1 (process_of l)) (i + arr.offset) == + Some ((Seq.index s1 i, process_of l), p1)); + drop_ (loc l); } ghost fn split_mask u#a (#t: Type u#a) (arr: array t) #f #v #mask (pred: nat -> prop) @@ -334,11 +421,13 @@ ghost fn split_mask u#a (#t: Type u#a) (arr: array t) #f #v #mask (pred: nat -> ensures pts_to_mask arr #f v (mask_isect mask pred) ensures pts_to_mask arr #f v (mask_diff mask pred) { + loc_get (); pts_to_mask_props arr; pcm_share arr f v mask arr f v (mask_isect mask pred) arr f v (mask_diff mask pred); + drop_ (loc _); } let mix #t (v1: Seq.seq t) (v2: Seq.seq t { Seq.length v1 == Seq.length v2 }) (mask: nat -> prop) : @@ -361,6 +450,7 @@ ghost fn join_mask u#a (#t: Type u#a) (arr: array t) #f #v1 #v2 #mask1 #mask2 (mask1 i ==> Seq.index v i == Seq.index v1 i) /\ (mask2 i ==> Seq.index v i == Seq.index v2 i))) { + loc_get (); pts_to_mask_props arr #f #v1 #mask1; pts_to_mask_props arr #f #v2 #mask2; let v = mix v1 v2 mask1; @@ -369,6 +459,7 @@ ghost fn join_mask u#a (#t: Type u#a) (arr: array t) #f #v1 #v2 #mask1 #mask2 arr f v mask arr f v1 mask1 arr f v2 mask2; + drop_ (loc _); } [@@allow_ambiguous] @@ -392,11 +483,14 @@ fn pts_to_mask_injective_eq u#a (#a: Type u#a) #p0 #p1 #s0 #s1 #mask0 #mask1 (ar Seq.index s0 i == Seq.index s1 i)) { unfold pts_to_mask arr #p0 s0 mask0; + with l. assert loc l; unfold pts_to_mask arr #p1 s1 mask1; - gather (lptr_of arr) (mk_carrier' arr p0 s0 mask0) (mk_carrier' arr p1 s1 mask1); - share (lptr_of arr) (mk_carrier' arr p0 s0 mask0) (mk_carrier' arr p1 s1 mask1); + loc_gather l; + gather (lptr_of arr) (mk_carrier' arr p0 s0 mask0 (arr.vis l)) (mk_carrier' arr p1 s1 mask1 (arr.vis l)); + share (lptr_of arr) (mk_carrier' arr p0 s0 mask0 (arr.vis l)) (mk_carrier' arr p1 s1 mask1 (arr.vis l)); assert pure (forall (i: nat). i < Seq.length s0 /\ mask0 i ==> - Map.sel (mk_carrier' arr p0 s0 mask0) (i + arr.offset) == Some (Seq.index s0 i, p0)); + Map.sel (mk_carrier' arr p0 s0 mask0 (arr.vis l)) (i + arr.offset) == Some ((Seq.index s0 i, arr.vis l), p0)); + loc_dup l; fold pts_to_mask arr #p0 s0 mask0; fold pts_to_mask arr #p1 s1 mask1; } @@ -412,7 +506,7 @@ fn mask_read u#a (#t: Type u#a) (a: array t) (i: SZ.t) #p (#s: erased (Seq.seq t with w. assert pcm_pts_to (lptr_of a) w; let v = read (lptr_of a) w (fun _ -> w); fold pts_to_mask a #p s mask; - fst (Some?.v (FStar.Map.sel v (a.offset + SZ.v i))); + fst (fst (Some?.v (FStar.Map.sel v (a.offset + SZ.v i)))); } [@@noextract_to "krml"] @@ -422,19 +516,20 @@ fn mask_write u#a (#t: Type u#a) (a: array t) (i: SZ.t) (v: t) (#s: erased (Seq. ensures pts_to_mask a (Seq.upd s (SZ.v i) v) mask { unfold pts_to_mask a s mask; + with l. assert loc l; with w. assert (pcm_pts_to (lptr_of a) w); write (lptr_of a) w _ (PM.lift_frame_preserving_upd _ _ (Frac.mk_frame_preserving_upd - (Seq.index s (SZ.v i)) - v + (Seq.index s (SZ.v i), a.vis l) + (v, a.vis l) ) _ (a.offset + SZ.v i)); assert pure ( - Map.upd (mk_carrier' a 1.0R s mask) (a.offset + SZ.v i) (Some (v, 1.0R)) + Map.upd (mk_carrier' a 1.0R s mask (a.vis l)) (a.offset + SZ.v i) (Some ((v, a.vis l), 1.0R)) `Map.equal` - mk_carrier' a 1.0R (Seq.upd s (SZ.v i) v) mask + mk_carrier' a 1.0R (Seq.upd s (SZ.v i) v) mask (a.vis l) ); fold pts_to_mask a (Seq.upd s (SZ.v i) v) mask; } diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fsti b/lib/pulse/lib/Pulse.Lib.Array.Core.fsti index a9cb2e38f..e67c7c735 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.fsti @@ -16,7 +16,6 @@ module Pulse.Lib.Array.Core #lang-pulse -open FStar.Tactics.V2 open Pulse.Lib.Core open Pulse.Main open Pulse.Class.PtsTo @@ -24,6 +23,10 @@ open PulseCore.FractionalPermission open FStar.Ghost module SZ = FStar.SizeT open Pulse.Lib.SmallType +open Pulse.Lib.Send + +let visibility = + vis:(loc_id -> loc_id) { forall l. vis (process_of l) == vis l } [@@erasable] val base_t : Type0 @@ -45,6 +48,18 @@ val is_null #a (r: array a) : b:bool {b <==> r == null #a} val pts_to_mask (#t: Type u#a) ([@@@mkey] a: array t) (#[full_default()] f: perm) (v: erased (Seq.seq t)) (mask: nat -> prop) : slprop +val loc_id_of_array #a (x:array a) : loc_id + +val visibility_of_array #a (x:array a) : visibility + +let array_visible_at #a (x:array a) (l:loc_id) = + visibility_of_array x l == + visibility_of_array x (loc_id_of_array x) + +val is_send_across_pts_to_mask #a x f s mask : is_send_across (visibility_of_array x) (pts_to_mask #a x #f s mask) + +instance val is_send_pts_to_mask #a r #p n m : is_send (pts_to_mask #a r #p n m) + val pts_to_mask_timeless (#a:Type u#a) (x:array a) (p:perm) (s:Seq.seq a) mask : Lemma (timeless (pts_to_mask x #p s mask)) [SMTPat (timeless (pts_to_mask x #p s mask))] @@ -83,11 +98,27 @@ ghost fn mask_ext u#a (#t: Type u#a) (arr: array t) #f #v #mask v' (mask': nat - (forall (i: nat). mask i /\ i < Seq.length v ==> Seq.index v i == Seq.index v' i)) ensures pts_to_mask arr #f v' mask' +[@@deprecated "Array.mask_alloc_with_vis is unsound; only use for model implementations"] +fn mask_alloc_with_vis u#a (#elt: Type u#a) {| small_type u#a |} + (x: elt) (n: SZ.t) (#l:loc_id) + (vis:visibility) + preserves loc l + returns a: array elt + ensures pts_to_mask a (Seq.create (SZ.v n) x) (fun _ -> True) + ensures pure ( + length a == SZ.v n /\ + is_full_array a /\ + visibility_of_array a == vis /\ + loc_id_of_array a == l) + +[@@deprecated "Array.mask_alloc is unsound; only use for model implementations"] +noextract inline_for_extraction fn mask_alloc u#a (#elt: Type u#a) {| small_type u#a |} (x: elt) (n: SZ.t) returns a: array elt ensures pts_to_mask a (Seq.create (SZ.v n) x) (fun _ -> True) - ensures pure (length a == SZ.v n /\ is_full_array a) + ensures pure (length a == SZ.v n /\ is_full_array a /\ visibility_of_array a == process_of) +[@@deprecated "Array.mask_free is unsound; only use for model implementations"] fn mask_free u#a (#elt: Type u#a) (a: array elt) (#s: Ghost.erased (Seq.seq elt)) #mask requires pts_to_mask a s mask requires pure (forall i. mask i) diff --git a/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst index 397b77dfb..7e8b64396 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst @@ -28,6 +28,8 @@ open Pulse.Lib.WithPure let pts_to (#elt: Type u#a) (a: array elt) (#p: perm) (s: Seq.seq elt) : Tot slprop = pts_to_mask a #p s fun i -> True +let is_send_pts_to _ _ = Tactics.Typeclasses.solve + ghost fn to_mask u#a (#t: Type u#a) (arr: array t) #f (#v: erased _) requires arr |-> Frac f v ensures pts_to_mask arr #f v (fun _ -> True) diff --git a/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti index c4b81e99d..304035a00 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti @@ -26,6 +26,7 @@ module SZ = FStar.SizeT module Seq = FStar.Seq open Pulse.Lib.Array.Core open Pulse.Lib.SmallType +open Pulse.Lib.Send val pts_to (#a:Type u#a) ([@@@mkey]x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop @@ -38,6 +39,8 @@ instance has_pts_to_larray (a:Type u#a) (n : nat) : has_pts_to (larray a n) (Seq pts_to = pts_to; } +instance val is_send_pts_to #a r #p n : is_send (pts_to #a r #p n) + ghost fn to_mask u#a (#t: Type u#a) (arr: array t) #f (#v: erased _) requires arr |-> Frac f v ensures pts_to_mask arr #f v (fun _ -> True) diff --git a/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst index 03c48950e..d83699b83 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst @@ -39,6 +39,8 @@ let pts_to_range : slprop = with_pure (i <= j /\ j <= length x) fun _ -> pts_to (gsub x i j) #p s +let is_send_pts_to_range x i j p s = Tactics.Typeclasses.solve + ghost fn fold_pts_to_range u#a (#a: Type u#a) (x: array a) (i: nat) (j: nat { i <= j /\ j <= length x }) #p #s0 s #mask requires pts_to_mask (gsub x i j) #p s0 mask requires pure (Seq.equal s s0) diff --git a/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti index fb3a3e5e4..c5dbbbc56 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti @@ -24,6 +24,7 @@ open PulseCore.FractionalPermission open FStar.Ghost module SZ = FStar.SizeT module Seq = FStar.Seq +open Pulse.Lib.Send open Pulse.Lib.Array.Core open Pulse.Lib.Array.PtsTo @@ -35,6 +36,9 @@ val pts_to_range (#[exact (`1.0R)] p:perm) (s : Seq.seq a) : slprop +instance val is_send_pts_to_range (#a: Type u#a) (x:array a) (i j : nat) (p:perm) (s:Seq.seq a) + : is_send (pts_to_range x i j #p s) + (* Exposing these is necessary to convert an array cell with pts_to_range to a ref *) ghost fn fold_pts_to_range u#a (#a: Type u#a) (x: array a) (i: nat) (j: nat { i <= j /\ j <= length x }) #p #s0 s #mask requires pts_to_mask (gsub x i j) #p s0 mask diff --git a/lib/pulse/lib/Pulse.Lib.Box.fst b/lib/pulse/lib/Pulse.Lib.Box.fst index 7bb86a223..f0a9f7f45 100644 --- a/lib/pulse/lib/Pulse.Lib.Box.fst +++ b/lib/pulse/lib/Pulse.Lib.Box.fst @@ -33,6 +33,8 @@ let is_null #a (r : box a) let pts_to b #p v = R.pts_to b.r #p v ** pure (R.is_full_ref b.r) +let is_send_pts_to _ _ = Tactics.Typeclasses.solve + let pts_to_timeless _ _ _ = () (* This function is extracted primitively. The implementation diff --git a/lib/pulse/lib/Pulse.Lib.Box.fsti b/lib/pulse/lib/Pulse.Lib.Box.fsti index cb634d5fe..92a4f78b3 100644 --- a/lib/pulse/lib/Pulse.Lib.Box.fsti +++ b/lib/pulse/lib/Pulse.Lib.Box.fsti @@ -22,6 +22,7 @@ open PulseCore.FractionalPermission open Pulse.Lib.Core open Pulse.Class.PtsTo +open Pulse.Lib.Send module T = FStar.Tactics.V2 module R = Pulse.Lib.Reference @@ -38,6 +39,8 @@ val pts_to (#a:Type0) (#[T.exact (`1.0R)] p:perm) (v:a) : slprop +instance val is_send_pts_to #a b #p v : is_send (pts_to #a b #p v) + [@@pulse_unfold] instance has_pts_to_box (a:Type u#0) : has_pts_to (box a) a = { pts_to = pts_to; diff --git a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst index e7fe941cb..0e9cf71e1 100644 --- a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst +++ b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fst @@ -32,12 +32,29 @@ instance non_informative_cinv = { let cinv_vp_aux (r:GR.ref bool) (v:slprop) :slprop = exists* (b:bool). pts_to r #0.5R b ** - (if b then v else emp) + cond b v emp + +irreducible instance is_send_across_cond #b' #g c a b {| da: is_send_across #b' g a, db: is_send_across g b |} : + is_send_across g (cond c a b) = + if c then da else db + +irreducible instance placeless_cond c a b {| da: placeless a, db: placeless b |} : + placeless (cond c a b) = + is_send_across_cond c a b #da #db + +irreducible instance is_send_cond c a b {| da: is_send a, db: is_send b |} : + is_send (cond c a b) = + is_send_across_cond c a b #da #db let cinv_vp c v = cinv_vp_aux c.r v +instance is_send_across_cinv_vp_aux #b #g c v {| is_send_across #b g v |} : is_send_across g (cinv_vp c v) = + Tactics.Typeclasses.solve + let active c p = pts_to c.r #(p /. 2.0R) true +let placeless_active c p = Tactics.Typeclasses.solve + let active_timeless p c = () let iname_of c = c.i @@ -51,7 +68,8 @@ fn new_cancellable_invariant (v:slprop) ensures inv (iname_of c) (cinv_vp c v) ** active c 1.0R { let r = GR.alloc true; - rewrite v as (if true then v else emp); + rewrite v as cond true v emp; + // somewhere_intro (cond true v emp) #_; GR.share r; fold (cinv_vp_aux r v); let i = new_invariant (cinv_vp_aux r v); @@ -62,7 +80,7 @@ fn new_cancellable_invariant (v:slprop) } -let unpacked c _v = pts_to c.r #0.5R true +let unpacked c v = pts_to c.r #0.5R true ghost fn unpack_cinv_vp (#p:perm) (#v:slprop) (c:cinv) @@ -72,10 +90,11 @@ 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)); + with b. assert cond b v emp; + assert (pts_to c.r #0.5R b ** (cond b v emp)); unfold active; GR.pts_to_injective_eq c.r; - rewrite (if b then v else emp) as v; + rewrite cond b v emp as v; fold (active c p); fold (unpacked c v) } @@ -89,7 +108,7 @@ fn pack_cinv_vp (#v:slprop) (c:cinv) opens [] { unfold unpacked; - rewrite v as (if true then v else emp); + rewrite v as cond true v emp; fold (cinv_vp_aux c.r v); fold (cinv_vp c v) } @@ -132,14 +151,14 @@ fn cancel_ (#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)); + with b. assert (pts_to c.r #0.5R b ** (cond b v emp)); unfold active; GR.pts_to_injective_eq c.r; - rewrite (if b then v else emp) as v; + rewrite cond b v emp as v; GR.gather c.r; GR.(c.r := false); - rewrite emp as (if false then v else emp); GR.share c.r; + rewrite emp as (cond false v emp); fold (cinv_vp_aux c.r v); fold (cinv_vp c v); drop_ (pts_to c.r #0.5R _) @@ -154,13 +173,9 @@ fn cancel (#v:slprop) (c:cinv) ensures v opens [iname_of c] { - with_invariants (iname_of c) - returns _:unit - ensures later (cinv_vp c v) ** v - opens [iname_of c] { - later_elim _; + with_invariants_g unit emp_inames (iname_of c) (cinv_vp c v) + (active c 1.0R) (fun _ -> v) fn _ { cancel_ c; - later_intro (cinv_vp c v); }; drop_ (inv (iname_of c) _) } diff --git a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fsti b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fsti index 3be6a34d6..b00010e65 100644 --- a/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fsti +++ b/lib/pulse/lib/Pulse.Lib.CancellableInvariant.fsti @@ -27,8 +27,14 @@ instance val non_informative_cinv val cinv_vp ([@@@mkey] c:cinv) (v:slprop) : slprop +instance val is_send_across_cinv_vp_aux #b #g c v {| is_send_across #b g v |} : is_send_across g (cinv_vp c v) +instance placeless_cinv_vp_aux c v {| i: placeless v |} : placeless (cinv_vp c v) = is_send_across_cinv_vp_aux c v #i +instance is_send_cinv_vp_aux c v {| i: is_send v |} : is_send (cinv_vp c v) = is_send_across_cinv_vp_aux c v #i + val active ([@@@mkey] c:cinv) (p:perm) : slprop +instance val placeless_active c p : placeless (active c p) + val active_timeless (c:cinv) (p:perm) : Lemma (timeless (active c p)) [SMTPat (timeless (active c p))] diff --git a/lib/pulse/lib/Pulse.Lib.ConditionVar.fst b/lib/pulse/lib/Pulse.Lib.ConditionVar.fst index 5108a75e9..8581cab46 100644 --- a/lib/pulse/lib/Pulse.Lib.ConditionVar.fst +++ b/lib/pulse/lib/Pulse.Lib.ConditionVar.fst @@ -17,6 +17,7 @@ module Pulse.Lib.ConditionVar #lang-pulse open Pulse.Lib.Pervasives +open Pulse.Lib.SendableTrade module U32 = FStar.UInt32 module OR = Pulse.Lib.OnRange module SLT = Pulse.Lib.SLPropTable @@ -35,7 +36,6 @@ type cvar_t = { } let singleton #a (i:a) = Seq.create 1 i -let full_perm : perm = 1.0R let predicate_at (t:SLT.table) (f:perm) (pred:Seq.seq slprop) (i:nat) : slprop @@ -43,16 +43,66 @@ let predicate_at (t:SLT.table) (f:perm) (pred:Seq.seq slprop) (i:nat) then SLT.pts_to t i #f (Seq.index pred i) else emp +instance placeless_predicate_at t f pred i : placeless (predicate_at t f pred i) = + if i < Seq.length pred then + SLT.placeless_pts_to t i #f (Seq.index pred i) + else + placeless_emp + [@@pulse_unfold] let stored_predicates (t:SLT.table) (n:nat) (f:perm) (pred:Seq.seq slprop) = OR.on_range (predicate_at t f pred) 0 n let index_preds (pred:Seq.seq slprop) (i:nat) -= if i < Seq.length pred then Seq.index pred i else emp += if i < Seq.length pred then sendable (Seq.index pred i) else emp + +instance is_send_index_preds pred i : is_send (index_preds pred i) = + if i < Seq.length pred then is_send_sendable (Seq.index pred i) else is_send_placeless emp let istar (pred:Seq.seq slprop) = OR.on_range (index_preds pred) 0 (Seq.length pred) +ghost fn rec is_send_on_range' p (i j: nat) (l: loc_id) {| (k:nat -> is_send (p k)) |} + requires in_same_process l + requires OR.on_range p i j + ensures on l (OR.on_range p i j) + decreases j +{ + if (i > j) { + OR.on_range_eq_false p i j; + rewrite OR.on_range p i j as pure False; + unreachable () + } else if (i = j) { + OR.on_range_empty_elim p i; + drop_ (in_same_process l); + ghost_impersonate l emp (on l (OR.on_range p i j)) fn _ { + OR.on_range_empty p i; + on_intro (OR.on_range p i j); + } + } else { + OR.on_range_unsnoc () #p #i #j; + is_send_intro_on (p (j-1)) l; + is_send_on_range' p i (j-1) l #_; + ghost_impersonate l + (on l (p (j - 1)) ** on l (OR.on_range p i (j - 1))) + (on l (OR.on_range p i j)) fn _ { + on_elim (p (j - 1)); + on_elim _; + OR.on_range_snoc (); + on_intro (OR.on_range p i j); + } + } +} + +ghost fn is_send_on_range p i j {| (k:nat -> is_send (p k)) |} : is_send (OR.on_range p i j) = l1 l2 { + ghost_impersonate l1 (on l1 (OR.on_range p i j)) (on l2 (OR.on_range p i j)) fn _ { + on_elim _; + loc_dup l1; + fold in_same_process l2; + is_send_on_range' p i j l2 #_; + } +} + ghost fn weaken_on_range (f g: (nat -> slprop)) (i j:nat) @@ -67,16 +117,13 @@ ensures OR.on_range_weaken f g i j fn k { rewrite f k as g k } } -let istar_singleton (p:slprop) -: Lemma (istar (singleton p) == p) -= slprop_equivs (); - OR.on_range_eq_emp (index_preds (singleton p)) 1 1; - OR.on_range_eq_cons (index_preds (singleton p)) 0 1 - let maybe_holds (v:U32.t) (p:slprop) (pred:Seq.seq slprop) : slprop -= if v = 0ul then equiv (istar pred) p else istar pred += if v = 0ul then trade p (istar pred) else istar pred +instance is_send_maybe_holds v p pred : is_send (maybe_holds v p pred) = + if v = 0ul then is_send_trade #emp_inames p (istar pred) + else is_send_on_range (index_preds pred) 0 (Seq.length pred) let cvar_inv (b: cvar_t_core) (p:slprop) : slprop @@ -104,7 +151,10 @@ let recv (b: cvar_t) (p:slprop) cvar b q ** SLT.pts_to b.core.tab i #0.5R p -fn create (p:slprop) +instance is_send_send c p : is_send (send c p) = Tactics.Typeclasses.solve +instance is_send_recv c p : is_send (recv c p) = Tactics.Typeclasses.solve + +fn create (p:slprop) {| is_send p |} requires emp returns c:cvar_t ensures send c p ** recv c p @@ -117,10 +167,13 @@ fn create (p:slprop) as (predicate_at tab 0.5R (singleton p) 0); OR.on_range_singleton_intro (predicate_at tab 0.5R (singleton p)) 0; Box.share r; - istar_singleton p; - equiv_refl (istar (singleton p)); - rewrite (equiv (istar (singleton p)) (istar (singleton p))) - as (maybe_holds 0ul p (singleton p)); + intro (p @==> istar (singleton p)) fn _ { + sendable_intro p #_; + rewrite sendable p as index_preds (singleton p) 0; + OR.on_range_singleton_intro (index_preds (singleton p)) 0; + fold istar (singleton p); + }; + fold maybe_holds 0ul p (singleton p); let core = { r; tab }; rewrite each r as core.r; rewrite each tab as core.tab; @@ -129,7 +182,7 @@ fn create (p:slprop) let cv = { core; i }; rewrite each core as cv.core; rewrite each i as cv.i; - dup_inv cv.i _; + dup (inv cv.i (cvar_inv cv.core p)) (); fold (cvar cv p); fold (send cv p); fold (cvar cv p); @@ -147,24 +200,18 @@ ensures { unfold send; unfold cvar; - with_invariants b.i - returns _:unit - ensures later (cvar_inv b.core p) + with_invariants_a unit emp_inames b.i (cvar_inv b.core p) + (p ** Box.pts_to b.core.r #0.5R 0ul) (fun _ -> emp) fn _ { - later_elim _; unfold cvar_inv; Box.gather b.core.r; - with v preds. assert (maybe_holds v p preds); - assert pure (v == 0ul); + with v preds. unfold (maybe_holds (reveal v) p preds); + assert rewrites_to v 0ul; write_atomic_box b.core.r 1ul; - rewrite (maybe_holds v p preds) - as (equiv (istar preds) p); - equiv_comm _ _; - equiv_elim p (istar preds); - rewrite (istar preds) as (maybe_holds 1ul p preds); + elim_trade p (istar preds); + fold (maybe_holds 1ul p preds); Box.share b.core.r; fold (cvar_inv b.core p); - later_intro (cvar_inv b.core p); drop_ (Box.pts_to b.core.r #0.5R _) }; drop_ (inv _ _) @@ -235,21 +282,18 @@ ensures with q. assert (cvar b q); unfold cvar; later_credit_buy 1; - later_credit_buy 1; - // show_proof_state; - let res:bool = - with_invariants b.i - returns res:bool - ensures later (cvar_inv b.core q) ** - (if res then p else SLT.pts_to b.core.tab i #0.5R p) + let res = + with_invariants bool emp_inames b.i (cvar_inv b.core q) + (SLT.pts_to b.core.tab i #0.5R p ** later_credit 1) + (fun res -> cond res p (SLT.pts_to b.core.tab i #0.5R p)) + fn _ { - later_elim _; unfold cvar_inv; let vv = read_atomic_box b.core.r; if (vv = 0ul) { fold (cvar_inv b.core q); - later_intro (cvar_inv b.core q); + fold cond false p (SLT.pts_to b.core.tab i #0.5R p); drop_ (later_credit 1); false; } @@ -259,14 +303,16 @@ ensures rewrite (maybe_holds v q preds) as (istar preds); get_predicate_at_i b.core.tab i p preds; - later_elim _; unfold istar; OR.on_range_get i #(index_preds preds); - rewrite (index_preds preds i) as (Seq.index preds i); + rewrite (index_preds preds i) as sendable (Seq.index preds i); + sendable_elim (Seq.index preds i); + later_elim (equiv _ _); equiv_elim _ _; SLT.update b.core.tab i emp; let preds' : erased (Seq.seq slprop) = FStar.Seq.upd preds i emp; - rewrite emp as (index_preds preds' i); + sendable_intro emp #_; + rewrite sendable emp as (index_preds preds' i); weaken_and_put (index_preds preds) (index_preds preds') @@ -282,13 +328,14 @@ ensures 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 _); + fold cond true p (SLT.pts_to b.core.tab i #0.5R p); true } }; - if res { drop_ (inv b.i _); () } + if res { drop_ (inv b.i _); elim_cond_true _ _ _; } else { + elim_cond_false _ _ _; fold (cvar b q); fold (recv b p); wait b #p @@ -296,108 +343,7 @@ ensures } ghost -fn equiv_star_cong_r (p q r x:slprop) -requires - equiv (p ** x) r ** - equiv x q -ensures - equiv (p ** q) r -{ - equiv_star_congr p x q; - rewrite (equiv x q) as (equiv x q ** equiv (p ** x) (p ** q)); - equiv_comm (p ** x) (p ** q); - equiv_trans (p ** q) (p ** x) r; - drop_ (equiv x q) -} - -let istar_preds_preds'_eq - (preds:Seq.seq slprop) - (i:nat{ i < Seq.length preds }) - (p1 p2:slprop) -: Lemma ( - let preds' = FStar.Seq.(snoc (snoc (Seq.upd preds i emp) p1) p2) in - istar preds == - OR.on_range (index_preds preds') 0 (Seq.length preds) ** Seq.index preds i) -= let preds' = FStar.Seq.(snoc (snoc (Seq.upd preds i emp) p1) p2) in - calc (==) { - istar preds; - (==) {} - OR.on_range (index_preds preds) 0 (Seq.length preds); - (==) { OR.on_range_eq_get (index_preds preds) 0 i (Seq.length preds) } - OR.on_range (index_preds preds) 0 i ** index_preds preds i ** OR.on_range (index_preds preds) (i + 1) (Seq.length preds); - (==) { - OR.on_range_frame (index_preds preds) (index_preds preds') 0 i; - OR.on_range_frame (index_preds preds) (index_preds preds') (i + 1) (Seq.length preds) - } - OR.on_range (index_preds preds') 0 i ** index_preds preds i ** OR.on_range (index_preds preds') (i + 1) (Seq.length preds); - (==) { slprop_equivs () } - (OR.on_range (index_preds preds') 0 i ** index_preds preds' i ** OR.on_range (index_preds preds') (i + 1) (Seq.length preds)) ** - index_preds preds i; - (==) { OR.on_range_eq_get (index_preds preds') 0 i (Seq.length preds) } - OR.on_range (index_preds preds') 0 (Seq.length preds) ** Seq.index preds i; - } - -let istar_preds'_tail - (preds:Seq.seq slprop) - (i:nat{ i < Seq.length preds }) - (p1 p2:slprop) -: Lemma ( - let preds' = FStar.Seq.(snoc (snoc (Seq.upd preds i emp) p1) p2) in - p1 ** p2 == (OR.on_range (index_preds preds') (Seq.length preds) (Seq.length preds'))) -= let preds' = FStar.Seq.(snoc (snoc (Seq.upd preds i emp) p1) p2) in - OR.on_range_eq_emp (index_preds preds') (Seq.length preds') (Seq.length preds'); - OR.on_range_eq_cons (index_preds preds') (Seq.length preds) (Seq.length preds'); - OR.on_range_eq_cons (index_preds preds') (Seq.length preds + 1) (Seq.length preds'); - slprop_equivs () - -ghost -fn rewrite_istar_equiv (preds:Seq.seq slprop) (preds':Seq.seq slprop) (i:nat{ i < Seq.length preds }) (p1 p2 q:slprop) -requires - pure (preds' == FStar.Seq.(snoc (snoc (Seq.upd preds i emp) p1) p2)) ** - equiv (istar preds) q ** - later (equiv (Seq.index preds i) (p1 ** p2)) ** - later_credit 1 -ensures - equiv (istar preds') q -{ - later_elim _; - istar_preds_preds'_eq preds i p1 p2; - 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 -fn rewrite_istar (preds:Seq.seq slprop) (preds':Seq.seq slprop) (i:nat{ i < Seq.length preds }) (p1 p2 q:slprop) -requires - pure (preds' == FStar.Seq.(snoc (snoc (Seq.upd preds i emp) p1) p2)) ** - istar preds ** - later (equiv (Seq.index preds i) (p1 ** p2)) ** - later_credit 1 -ensures - istar preds' -{ - later_elim _; - istar_preds_preds'_eq preds i p1 p2; - rewrite (istar preds) as (OR.on_range (index_preds preds') 0 (Seq.length preds) ** Seq.index preds i); - equiv_elim _ _; - istar_preds'_tail preds i p1 p2; - rewrite (p1 ** p2) - as (OR.on_range (index_preds preds') (Seq.length preds) (Seq.length preds')); - OR.on_range_join 0 (Seq.length preds) (Seq.length preds') #(index_preds preds'); - fold (istar preds') -} - -ghost -fn split (b:cvar_t) (#p1 #p2:slprop) +fn split (b:cvar_t) (#p1 #p2:slprop) {| is_send p1, is_send p2 |} requires recv b (p1 ** p2) ** later_credit 2 ensures @@ -412,16 +358,13 @@ opens with i. assert (SLT.pts_to b.core.tab i #0.5R (p1 ** p2)); with q. assert (cvar b q); unfold cvar; - let _ : unit = - with_invariants b.i - returns _:unit - ensures - later (cvar_inv b.core q) ** + with_invariants_g unit emp_inames b.i (cvar_inv b.core q) + (later_credit 1 ** SLT.pts_to b.core.tab i #0.5R (p1 ** p2)) + (fun _ -> (exists* j k. SLT.pts_to b.core.tab j #0.5R p1 ** - SLT.pts_to b.core.tab k #0.5R p2) - { - later_elim _; + SLT.pts_to b.core.tab k #0.5R p2)) + fn _ { unfold cvar_inv; with v preds. assert (maybe_holds v q preds); get_predicate_at_i b.core.tab i (p1 ** p2) preds; @@ -445,30 +388,49 @@ opens rewrite SLT.pts_to b.core.tab (Seq.length preds + 1) #0.5R p2 as (predicate_at b.core.tab 0.5R preds' (Seq.length preds + 1)); OR.on_range_snoc(); + later_elim (equiv _ _); + intro (istar preds @==> istar preds') + #(equiv (Seq.Base.index preds i) (p1 ** p2)) fn _ { + unfold istar preds; + OR.on_range_get i; + weaken_on_range (index_preds preds) (index_preds preds') 0 i; + weaken_on_range (index_preds preds) (index_preds preds') (i+1) (Seq.length preds); + sendable_intro emp #_; + rewrite sendable emp as index_preds preds' i; + OR.on_range_put 0 i (Seq.length preds); + rewrite index_preds preds i as sendable (Seq.index preds i); + sendable_elim (Seq.index preds i); + equiv_elim _ _; + sendable_intro p1 #_; rewrite sendable p1 as index_preds preds' (Seq.length preds); + sendable_intro p2 #_; rewrite sendable p2 as index_preds preds' (Seq.length preds + 1); + OR.on_range_snoc (); + OR.on_range_snoc (); + fold istar preds'; + }; let vz = (reveal v = 0ul); if (vz) { - rewrite (maybe_holds v q preds) as (equiv (istar preds) q); + rewrite (maybe_holds v q preds) as (q @==> istar preds); OR.on_range_eq_get (index_preds preds) 0 i (Seq.length preds); - rewrite_istar_equiv preds preds' i p1 p2 q; - // show_proof_state; - // step (); - rewrite equiv (istar preds') q as maybe_holds v q preds'; + intro (q @==> istar preds') + #(trade q (istar preds) ** trade (istar preds) (istar preds')) fn _ { + elim_trade q (istar preds); + elim_trade (istar preds) (istar preds'); + }; + rewrite (q @==> 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); } else { rewrite (maybe_holds v q preds) as (istar preds); - rewrite_istar preds preds' i p1 p2 q; - rewrite istar preds' as maybe_holds v q preds'; + elim_trade (istar preds) (istar 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); } }; - dup_inv b.i _; + dup (inv b.i (cvar_inv b.core q)) (); fold (cvar b q); fold (recv b p1); fold (cvar b q); diff --git a/lib/pulse/lib/Pulse.Lib.ConditionVar.fsti b/lib/pulse/lib/Pulse.Lib.ConditionVar.fsti index 9b6661102..4dbc96f9f 100644 --- a/lib/pulse/lib/Pulse.Lib.ConditionVar.fsti +++ b/lib/pulse/lib/Pulse.Lib.ConditionVar.fsti @@ -17,6 +17,7 @@ module Pulse.Lib.ConditionVar #lang-pulse open Pulse.Lib.Pervasives + val cvar_t : Type0 val inv_name (c:cvar_t) : iname @@ -25,7 +26,10 @@ val send (c:cvar_t) (p:slprop) : slprop val recv (c:cvar_t) (p:slprop) : slprop -fn create (p:slprop) +instance val is_send_send c p : is_send (send c p) +instance val is_send_recv c p : is_send (recv c p) + +fn create (p:slprop) {| is_send p |} requires emp returns c:cvar_t ensures send c p ** recv c p @@ -45,7 +49,7 @@ fn wait (b:cvar_t) (#p:slprop) ensures p ghost -fn split (b:cvar_t) (#p #q:slprop) +fn split (b:cvar_t) (#p #q:slprop) {| is_send p, is_send q |} requires recv b (p ** q) ** later_credit 2 ensures recv b p ** recv b q opens [ inv_name b ] diff --git a/lib/pulse/lib/Pulse.Lib.FlippableInv.fst b/lib/pulse/lib/Pulse.Lib.FlippableInv.fst index 69eef3210..c2be7678e 100644 --- a/lib/pulse/lib/Pulse.Lib.FlippableInv.fst +++ b/lib/pulse/lib/Pulse.Lib.FlippableInv.fst @@ -43,7 +43,7 @@ let on #p (fi : finv p) : slprop = pts_to fi.r #0.5R true ** inv fi.i (finv_p p fi.r) -fn mk_finv (p:slprop) +ghost fn mk_finv (p:slprop) requires emp returns f:(finv p) ensures off f @@ -68,7 +68,7 @@ fn mk_finv (p:slprop) let iname_of #p (f : finv p) : iname = f.i -atomic +ghost fn flip_on (#p:slprop) (fi:finv p) requires off fi ** p ** later_credit 1 ensures on fi @@ -76,27 +76,22 @@ fn flip_on (#p:slprop) (fi:finv p) { open Pulse.Lib.GhostReference; unfold off; - with_invariants fi.i - returns _:unit - ensures later (finv_p p fi.r) ** - pts_to fi.r #0.5R true - opens [fi.i] + with_invariants_g unit emp_inames fi.i (finv_p p fi.r) + (p ** pts_to fi.r #0.5R false) (fun _ -> pts_to fi.r #0.5R true) fn _ { - later_elim _; unfold finv_p; with b. assert (pts_to fi.r #0.5R b ** pts_to fi.r #0.5R false); - GR.gather fi.r; + GR.gather fi.r #false #_; rewrite each b as false; fi.r := true; GR.share fi.r; fold_finv_p p fi.r; - later_intro (finv_p p fi.r); }; fold on fi; } -atomic +ghost fn flip_off (#p:slprop) (fi : finv p) requires on fi ** later_credit 1 ensures off fi ** p @@ -104,13 +99,9 @@ fn flip_off (#p:slprop) (fi : finv p) { open Pulse.Lib.GhostReference; unfold on; - with_invariants fi.i - returns _:unit - ensures later (finv_p p fi.r) ** - pts_to fi.r #0.5R false ** p - opens [fi.i] + with_invariants_g unit emp_inames fi.i (finv_p p fi.r) + (pts_to fi.r #0.5R true) (fun _ -> p ** pts_to fi.r #0.5R false) fn _ { - later_elim _; unfold finv_p; with b. assert (pts_to fi.r #0.5R b ** pts_to fi.r #0.5R true); @@ -119,7 +110,6 @@ fn flip_off (#p:slprop) (fi : finv p) fi.r := false; GR.share fi.r; fold_finv_p p fi.r; - later_intro (finv_p p fi.r); }; fold off fi; } diff --git a/lib/pulse/lib/Pulse.Lib.FlippableInv.fsti b/lib/pulse/lib/Pulse.Lib.FlippableInv.fsti index b59719c4a..649a164e0 100644 --- a/lib/pulse/lib/Pulse.Lib.FlippableInv.fsti +++ b/lib/pulse/lib/Pulse.Lib.FlippableInv.fsti @@ -24,12 +24,15 @@ val finv (p:slprop) : Type0 val off #p (fi : finv p) : slprop val on #p (fi : finv p) : slprop -val mk_finv (p:slprop) : stt (finv p) emp (fun x -> off x) +ghost +fn mk_finv (p:slprop) + returns x:finv p + ensures off x val iname_of #p (f : finv p) : iname -atomic +ghost fn flip_on (#p:slprop) (fi : finv p) requires off fi ** p ** later_credit 1 ensures on fi @@ -37,7 +40,7 @@ fn flip_on (#p:slprop) (fi : finv p) -atomic +ghost fn flip_off (#p:slprop) (fi : finv p) requires on fi ** later_credit 1 ensures off fi ** p diff --git a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst index 159178a6a..2c8223150 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst @@ -35,11 +35,15 @@ let is_table #a ([@@@mkey]t:table a) (max:nat) : slprop = GPR.pts_to t (full_table_above max) +let placeless_is_table #a t max = Tactics.Typeclasses.solve + let pts_to #a (t:table a) (i:nat) (#f:perm) (p:a) : slprop = GPR.pts_to t (singleton i f (Some p)) ** pure (PF.perm_ok f) +let placeless_pts_to #a t i #f p = Tactics.Typeclasses.solve + ghost fn create (#a:Type) requires emp diff --git a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti index db2186029..9493ab172 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fsti @@ -8,8 +8,12 @@ val table (a:Type0) : Type0 instance val non_informative_table (a:Type): NonInformative.non_informative (table a) val is_table #a ([@@@mkey] t:table a) (max:nat) : slprop +instance val placeless_is_table #a t max : placeless (is_table #a t max) + val pts_to #a ([@@@mkey] t:table a) (i:nat) (#f:perm) (p:a) : slprop +instance val placeless_pts_to #a t i #f p : placeless (pts_to #a t i #f p) + ghost fn create (#a:Type) requires emp diff --git a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst index 8d97fcbdf..e5c43957a 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst @@ -32,6 +32,15 @@ let small_token (inst: small_type u#a) = emp let pts_to (#a:Type u#a) (#p:pcm a) ([@@@mkey] r:ghost_pcm_ref p) (v:a) : slprop = exists* (inst: small_type u#a). C.ghost_pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst +ghost fn placeless_ghost_pcm_pts_to' #a #p r v : placeless (C.ghost_pcm_pts_to #a #p r v) = l1 l2 { + C.on_ghost_pcm_pts_to_eq l1 r v; + C.on_ghost_pcm_pts_to_eq l2 r v; + rewrite on l1 (C.ghost_pcm_pts_to r v) as on l2 (C.ghost_pcm_pts_to r v) +} +instance placeless_ghost_pcm_pts_to #a #p = placeless_ghost_pcm_pts_to' #a #p + +instance pts_to_placeless #a #p r v = Tactics.Typeclasses.solve + let pts_to_is_timeless #a #p r v = assert_norm (pts_to r v == op_exists_Star fun (inst: small_type u#a) -> diff --git a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti index b6a16f9ea..b274f5ef0 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti @@ -17,6 +17,7 @@ module Pulse.Lib.GhostPCMReference #lang-pulse open Pulse.Lib.SmallType open Pulse.Lib.Core +open Pulse.Lib.Send open Pulse.Main open FStar.PCM @@ -47,6 +48,13 @@ val pts_to (v:a) : slprop +instance val pts_to_placeless + (#a:Type) + (#p:pcm a) + (r:gref p) + (v:a) +: placeless (pts_to r v) + val pts_to_is_timeless (#a:Type) (#p:pcm a) diff --git a/lib/pulse/lib/Pulse.Lib.GhostReference.fst b/lib/pulse/lib/Pulse.Lib.GhostReference.fst index 9864ebf12..fd785d0fe 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostReference.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostReference.fst @@ -29,6 +29,7 @@ let null #a = GR.null_core_ghost_pcm_ref let pts_to (#a:Type) (r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) = GR.pts_to r (Some (n, p)) ** pure (perm_ok p) +let pts_to_placeless r p n = Tactics.Typeclasses.solve let pts_to_timeless _ _ _ = () diff --git a/lib/pulse/lib/Pulse.Lib.GhostReference.fsti b/lib/pulse/lib/Pulse.Lib.GhostReference.fsti index d1f633f45..baf96136e 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostReference.fsti @@ -18,6 +18,7 @@ module Pulse.Lib.GhostReference #lang-pulse open FStar.Tactics open Pulse.Lib.Core +open Pulse.Lib.Send open Pulse.Main open PulseCore.FractionalPermission open FStar.Ghost @@ -46,6 +47,9 @@ instance has_pts_to_ref (a:Type u#a) : has_pts_to (ref a) a = { pts_to = (fun r #f v -> pts_to r #f v); } +instance val pts_to_placeless (#a:Type u#a) (r:ref a) (p:perm) (n:a) : + placeless (pts_to r #p n) + val pts_to_timeless (#a:Type u#a) (r:ref a) (p:perm) (n:a) : Lemma (timeless (pts_to r #p n)) [SMTPat (timeless (pts_to r #p n))] diff --git a/lib/pulse/lib/Pulse.Lib.Inv.fst b/lib/pulse/lib/Pulse.Lib.Inv.fst new file mode 100644 index 000000000..e3d23518a --- /dev/null +++ b/lib/pulse/lib/Pulse.Lib.Inv.fst @@ -0,0 +1,225 @@ +(* + Copyright 2025 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.Lib.Inv +#lang-pulse +open Pulse.Lib.Core +open Pulse.Class.Duplicable +module C = Pulse.Lib.Core.Inv + +ghost fn placeless_c_inv' (i: iname) (p: slprop) : placeless (C.inv i p) = l1 l2 { + C.on_inv_eq l1 i p; + C.on_inv_eq l2 i p; + rewrite on l1 (C.inv i p) as on l2 (C.inv i p); +} +instance placeless_c_inv = placeless_c_inv' + +unfold +let move_tag0 l1 l2 p + (f: unit -> stt_ghost unit emp_inames (on l1 p) (fun _ -> on l2 p)) + = emp + +let move_tag l1 l2 p f g = + move_tag0 l1 l2 p f ** move_tag0 l2 l1 p g + +let inv (i: iname) (p: slprop) = + exists* l l' f g. + loc l ** move_tag l l' p f g ** + C.inv i (on l' p) + +let aux #p (inst: placeless p) l1 l2 = + fun () -> inst l1 l2 + +ghost fn move i p l1 l2 + (fwd: unit -> stt_ghost unit emp_inames (on l1 p) (fun _ -> on l2 p)) + (bwd: unit -> stt_ghost unit emp_inames (on l2 p) (fun _ -> on l1 p)) + requires on l1 (inv i p) + ensures on l2 (inv i p) +{ + ghost_impersonate l1 (on l1 (inv i p)) (on l2 (inv i p)) fn _ { + on_elim (inv i p); + unfold inv i p; with l_ l' f g. _; + loc_gather l1 #l_; + drop_ (move_tag l_ l' p _ _); + ghost_impersonate l2 (C.inv i (on l' p)) (on l2 (inv i p)) fn _ { + ghost fn f' () + requires on l2 p + ensures on l' p + { + bwd (); + let f = f; f () + }; + ghost fn g' () + requires on l' p + ensures on l2 p + { + let g = g; g (); + fwd (); + }; + fold move_tag l2 l' p f' g'; + loc_dup l2; + fold inv i p; + on_intro (inv i p); + } + } +} + +ghost fn is_send_across_inv #b #g i p {| inst: is_send_across #b g p |} : is_send_across g (inv i p) = l1 l2 { + move i p l1 l2 + fn _ { inst l1 l2 } + fn _ { inst l2 l1 } +} + +ghost fn dup_inv' i p () : duplicable_f (inv i p) = { + unfold inv i p; with l l' f g. _; + C.dup_inv i (on l' p); + loc_dup _; + fold move_tag l l' p f g; + fold inv i p; + fold inv i p; +} + +instance duplicable_inv i p : duplicable (inv i p) = + { dup_f = dup_inv' i p } + +ghost fn fresh_invariant + (ctx: inames { Pulse.Lib.GhostSet.is_finite ctx }) + (p: slprop) + requires p + returns i: iname + ensures inv i p + ensures pure (~(Pulse.Lib.GhostSet.mem i ctx)) +{ + let l = loc_get (); + on_intro p; + let i = C.fresh_invariant ctx (on l p); + ghost fn f () requires on l p ensures on l p {}; + fold move_tag l l p f f; + fold inv i p; + i +} + +ghost fn new_invariant (p: slprop) + requires p + returns i: iname + ensures inv i p +{ + fresh_invariant emp_inames p +} + +inline_for_extraction noextract +unobservable fn with_inv_unobs u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_atomic a #Neutral is (pre ** p) (fun x -> post x ** p)) + opens add_inv is i + preserves inv i p + requires later_credit 1 + requires pre + returns x:a + ensures post x +{ + unfold inv i p; with l l' f g. _; + let x = C.with_invariant #a #Neutral + #(pre ** later_credit 1 ** loc l) + #(fun x -> post x ** loc l) #is #(on l' p) i fn _ { + unfold C.somewhere (later (on l' p)); + with l''. assert on l'' (later (on l' p)); + on_on_eq l'' l' (later p); on_later_eq l' p; + rewrite on l'' (later (on l' p)) as later (on l' p); + later_elim (on l' p); + { let g=g; g() }; + on_elim p; + let x = k (); + on_intro p; + { let f=f; f() }; + later_intro (on l' p); + rewrite later (on l' p) as on l'' (later (on l' p)); + fold C.somewhere (later (on l' p)); + x + }; + fold inv i p; + x +} + +ghost fn with_invariants_g u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_ghost a is (pre ** p) (fun x -> post x ** p)) + opens add_inv is i + preserves inv i p + requires later_credit 1 + requires pre + returns x:a + ensures post x +{ + ghost fn k () + opens is + requires pre ** p + returns x: Ghost.erased a + ensures post x ** p + { + let r = k (); + r + }; + let r = with_inv_unobs (Ghost.erased a) is i p pre (fun r -> post r) fn _ { k () }; + r +} + +inline_for_extraction noextract +atomic fn with_invariants_a u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_atomic a #Observable is (pre ** p) (fun x -> post x ** p)) + opens add_inv is i + preserves inv i p + requires later_credit 1 + requires pre + returns x:a + ensures post x +{ + unfold inv i p; with l l' f g. _; + let x = C.with_invariant #a #Observable + #(pre ** later_credit 1 ** loc l) + #(fun x -> post x ** loc l) #is #(on l' p) i fn _ { + unfold C.somewhere (later (on l' p)); + with l''. assert on l'' (later (on l' p)); + on_on_eq l'' l' (later p); on_later_eq l' p; + rewrite on l'' (later (on l' p)) as later (on l' p); + later_elim (on l' p); + { let g=g; g() }; + on_elim p; + let x = k (); + on_intro p; + { let f=f; f() }; + later_intro (on l' p); + rewrite later (on l' p) as on l'' (later (on l' p)); + fold C.somewhere (later (on l' p)); + x + }; + fold inv i p; + x +} + +inline_for_extraction noextract +fn with_invariants u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_atomic a #Observable is (pre ** p) (fun x -> post x ** p)) + preserves inv i p + requires pre + returns x:a + ensures post x +{ + later_credit_buy 1; + with_invariants_a a is i p pre post k +} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.Inv.fsti b/lib/pulse/lib/Pulse.Lib.Inv.fsti new file mode 100644 index 000000000..196afcd1d --- /dev/null +++ b/lib/pulse/lib/Pulse.Lib.Inv.fsti @@ -0,0 +1,96 @@ +(* + Copyright 2025 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.Lib.Inv +#lang-pulse +open Pulse.Lib.Core +open Pulse.Lib.Send +open Pulse.Class.Duplicable +open PulseCore.Observability + +val inv (i: iname) (p: slprop) : slprop + +ghost fn move i p l1 l2 + (fwd: unit -> stt_ghost unit emp_inames (on l1 p) (fun _ -> on l2 p)) + (bwd: unit -> stt_ghost unit emp_inames (on l2 p) (fun _ -> on l1 p)) + requires on l1 (inv i p) + ensures on l2 (inv i p) + +instance val is_send_across_inv #b #g i p {| is_send_across #b g p |} : is_send_across g (inv i p) +instance placeless_inv i p {| inst: placeless p |} : placeless (inv i p) = is_send_across_inv i p #inst +instance is_send_inv i p {| inst: is_send p |} : is_send (inv i p) = is_send_across_inv i p #inst +instance val duplicable_inv i p : duplicable (inv i p) + +ghost fn dup_inv (i:iname) (p:slprop) + preserves inv i p + ensures inv i p +{ + dup (inv i p) () +} + +ghost fn fresh_invariant + (ctx: inames { Pulse.Lib.GhostSet.is_finite ctx }) + (p: slprop) + requires p + returns i: iname + ensures inv i p + ensures pure (~(Pulse.Lib.GhostSet.mem i ctx)) + +ghost fn new_invariant (p: slprop) + requires p + returns i: iname + ensures inv i p + +inline_for_extraction noextract +unobservable fn with_inv_unobs u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_atomic a #Neutral is (pre ** p) (fun x -> post x ** p)) + opens add_inv is i + preserves inv i p + requires later_credit 1 + requires pre + returns x:a + ensures post x + +ghost fn with_invariants_g u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_ghost a is (pre ** p) (fun x -> post x ** p)) + opens add_inv is i + preserves inv i p + requires later_credit 1 + requires pre + returns x:a + ensures post x + +inline_for_extraction noextract +atomic fn with_invariants_a u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_atomic a #Observable is (pre ** p) (fun x -> post x ** p)) + opens add_inv is i + preserves inv i p + requires later_credit 1 + requires pre + returns x:a + ensures post x + +inline_for_extraction noextract +fn with_invariants u#a (a: Type u#a) + is (i: iname { not (mem_inv is i) }) (p: slprop) pre (post: a->slprop) + (k: unit -> stt_atomic a #Observable is (pre ** p) (fun x -> post x ** p)) + preserves inv i p + requires pre + returns x:a + ensures post x \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst index 67257e136..4fe253d88 100644 --- a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst +++ b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fst @@ -25,6 +25,7 @@ let pts_to' (#t:Type) pure (f <=. 1.0R /\ Cons? h /\ PulseCore.Preorder.curval h == v) let pts_to = pts_to' +let placeless_pts_to r v = Tactics.Typeclasses.solve let pts_to_is_timeless (#t:Type) (#p:preorder t) (r:mref p) #f (v:t) = () [@@pulse_unfold] @@ -37,6 +38,7 @@ let snapshot' (#t:Type) GR.pts_to r (None, h) ** pure (Cons? h /\ PulseCore.Preorder.curval h == v) let snapshot = snapshot' +let placeless_snapshot r v = Tactics.Typeclasses.solve let snapshot_is_timeless (#t:Type) (#p:preorder t) (r:mref p) (v:t) = () let full (#t:Type) (#p:preorder t) (v:t) : FP.pcm_carrier p = (Some 1.0R, [v]) diff --git a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti index b978d1a4a..32b0cdf6f 100644 --- a/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti +++ b/lib/pulse/lib/Pulse.Lib.MonotonicGhostRef.fsti @@ -20,6 +20,9 @@ val pts_to (#t:Type) (v:t) : slprop +instance val placeless_pts_to (#t:Type) (#p:preorder t) (r:mref p) (#f:perm) (v:t) +: placeless (pts_to r #f v) + val pts_to_is_timeless (#t:Type) (#p:preorder t) (r:mref p) (#f:perm) (v:t) : Lemma (timeless (pts_to r #f v)) [SMTPat (timeless (pts_to r #f v))] @@ -30,6 +33,9 @@ val snapshot (#t:Type) (v:t) : slprop +instance val placeless_snapshot (#t:Type) (#p:preorder t) (r:mref p) (v:t) +: placeless (snapshot r v) + val snapshot_is_timeless (#t:Type) (#p:preorder t) (r:mref p) (v:t) : Lemma (timeless (snapshot r v)) [SMTPat (timeless (snapshot r v))] diff --git a/lib/pulse/lib/Pulse.Lib.Mutex.fst b/lib/pulse/lib/Pulse.Lib.Mutex.fst index 6c2e25b8d..8c8c91cd8 100644 --- a/lib/pulse/lib/Pulse.Lib.Mutex.fst +++ b/lib/pulse/lib/Pulse.Lib.Mutex.fst @@ -40,6 +40,8 @@ let lock_inv (#a:Type0) (r:B.box a) (v:a -> slprop) : slprop = let mutex_live #a m #p v = lock_alive m.l #p (lock_inv m.r v) +let is_send_mutex_live #a m #p v #_ = Tactics.Typeclasses.solve + let pts_to mg #p x = pts_to mg #p x let op_Bang #a mg #x #p = R.op_Bang #a mg #x #p diff --git a/lib/pulse/lib/Pulse.Lib.Mutex.fsti b/lib/pulse/lib/Pulse.Lib.Mutex.fsti index 2600d3d6f..70f527f4e 100644 --- a/lib/pulse/lib/Pulse.Lib.Mutex.fsti +++ b/lib/pulse/lib/Pulse.Lib.Mutex.fsti @@ -35,6 +35,8 @@ val mutex_live (#[T.exact (`1.0R)] p:perm) (v:a -> slprop) : slprop +instance val is_send_mutex_live #a m #p v {| (x:a -> is_send (v x)) |} : is_send (mutex_live #a m #p v) + // // mutex_guard is a ref-like type // diff --git a/lib/pulse/lib/Pulse.Lib.OnRange.fst b/lib/pulse/lib/Pulse.Lib.OnRange.fst index 40327b29a..e01aec08c 100644 --- a/lib/pulse/lib/Pulse.Lib.OnRange.fst +++ b/lib/pulse/lib/Pulse.Lib.OnRange.fst @@ -494,3 +494,44 @@ fn rec on_range_unzip (p q:nat -> slprop) (i j:nat) } } +ghost fn rec on_range_move p (i j: nat) (l1 l2: loc_id) + (f: (k:nat -> stt_ghost unit emp_inames (on l1 (p k)) (fun _ -> on l2 (p k)))) + requires on l1 (on_range p i j) + ensures on l2 (on_range p i j) + decreases j +{ + ghost_impersonate l1 (on l1 (on_range p i j)) (on l2 (on_range p i j)) fn _ { + on_elim _; + if (i > j) { + on_range_eq_false p i j; + rewrite on_range p i j as pure False; + unreachable () + } else if (i = j) { + on_range_empty_elim p i; + ghost_impersonate l2 emp (on l2 (on_range p i j)) fn _ { + on_range_empty p i; + on_intro (on_range p i j); + } + } else { + on_range_unsnoc () #p #i #j; + on_intro (p (j-1)); f (j-1); + on_intro (on_range p i (j-1)); on_range_move p i (j-1) l1 l2 f; + ghost_impersonate l2 + (on l2 (p (j - 1)) ** on l2 (on_range p i (j - 1))) + (on l2 (on_range p i j)) fn _ { + on_elim (p (j - 1)); + on_elim (on_range p i (j - 1)); + on_range_snoc (); + on_intro (on_range p i j); + } + } + } +} + +ghost fn placeless_on_range p i j {| inst : (k:nat -> placeless (p k)) |} : placeless (on_range p i j) = l1 l2 { + on_range_move p i j l1 l2 fn k { inst k l1 l2 } +} + +ghost fn is_send_on_range p i j {| (k:nat -> is_send (p k)) |} : is_send (on_range p i j) = l1 l2 { + on_range_move p i j l1 l2 fn k { is_send_elim (p k) l2 } +} diff --git a/lib/pulse/lib/Pulse.Lib.OnRange.fsti b/lib/pulse/lib/Pulse.Lib.OnRange.fsti index f005fd2d8..a25dfed0b 100644 --- a/lib/pulse/lib/Pulse.Lib.OnRange.fsti +++ b/lib/pulse/lib/Pulse.Lib.OnRange.fsti @@ -231,3 +231,6 @@ val on_range_unzip (p q:nat -> slprop) (i j:nat) : stt_ghost unit emp_inames (on_range (fun k -> p k ** q k) i j) (fun _ -> on_range p i j ** on_range q i j) + +instance val placeless_on_range p i j {| (k:nat -> placeless (p k)) |} : placeless (on_range p i j) +instance val is_send_on_range p i j {| (k:nat -> is_send (p k)) |} : is_send (on_range p i j) diff --git a/lib/pulse/lib/Pulse.Lib.PCMReference.fst b/lib/pulse/lib/Pulse.Lib.PCMReference.fst index a8955a43c..9840d95ea 100644 --- a/lib/pulse/lib/Pulse.Lib.PCMReference.fst +++ b/lib/pulse/lib/Pulse.Lib.PCMReference.fst @@ -39,6 +39,16 @@ let timeless_pcm_pts_to #a #p r v = op_exists_Star fun (inst: small_type u#a) -> C.pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst) +ghost fn placeless_pcm_pts_to'' #a #p r v : placeless (C.pcm_pts_to #a #p r v) = l1 l2 { + C.on_pcm_pts_to_eq l1 r v; + C.on_pcm_pts_to_eq l2 r v; + rewrite on l1 (C.pcm_pts_to r v) as on l2 (C.pcm_pts_to r v) +} +instance placeless_pcm_pts_to' #a #p = placeless_pcm_pts_to'' #a #p + +let placeless_pcm_pts_to #a #p r v = + Tactics.Typeclasses.solve + ghost fn pts_to_small u#a (#a:Type u#a) (#p:FStar.PCM.pcm a) (r:pcm_ref p) (v:a) preserves pcm_pts_to r v returns inst: small_type u#a diff --git a/lib/pulse/lib/Pulse.Lib.PCMReference.fsti b/lib/pulse/lib/Pulse.Lib.PCMReference.fsti index 65e56ebe7..4b8a8fb77 100644 --- a/lib/pulse/lib/Pulse.Lib.PCMReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.PCMReference.fsti @@ -16,6 +16,7 @@ module Pulse.Lib.PCMReference open Pulse.Lib.SmallType open Pulse.Lib.Core +open Pulse.Lib.Send open Pulse.Main open FStar.PCM open FStar.Ghost @@ -38,6 +39,8 @@ val pcm_pts_to (#a:Type u#a) (#p:pcm a) ([@@@mkey] r:pcm_ref p) (v:a) : slprop val timeless_pcm_pts_to (#a:Type u#a) (#p:pcm a) (r:pcm_ref p) (v:a) : Lemma (timeless (pcm_pts_to r v)) [SMTPat (timeless (pcm_pts_to r v))] +instance val placeless_pcm_pts_to #a #p r v : placeless (pcm_pts_to #a #p r v) + ghost fn pts_to_small u#a (#a: Type u#a) (#p:FStar.PCM.pcm a) (r:pcm_ref p) (v:a) preserves pcm_pts_to r v returns inst: small_type u#a diff --git a/lib/pulse/lib/Pulse.Lib.Par.fst b/lib/pulse/lib/Pulse.Lib.Par.fst index 1d96d5f65..341f72ba3 100644 --- a/lib/pulse/lib/Pulse.Lib.Par.fst +++ b/lib/pulse/lib/Pulse.Lib.Par.fst @@ -19,19 +19,18 @@ open Pulse.Lib.ConditionVar #lang-pulse -fn par_stt' #preL #postL #preR #postR +fn par (#preL: slprop) #postL #preR #postR + {| is_send preL, is_send postL, is_send preR, is_send postR |} (f:unit -> stt unit preL (fun _ -> postL)) (g:unit -> stt unit preR (fun _ -> postR)) requires preL ** preR ensures postL ** postR { - let c = create postL; - fork #(preL ** send c postL) fn _ { + let c = create postL #_; + fork' (preL ** send c postL) fn _ { f (); signal c #postL; }; g (); wait c #postL; } - -let par_stt f g = par_stt' (fun _ -> f) (fun _ -> g) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.Par.fsti b/lib/pulse/lib/Pulse.Lib.Par.fsti index 06447ea3e..921ac1f60 100644 --- a/lib/pulse/lib/Pulse.Lib.Par.fsti +++ b/lib/pulse/lib/Pulse.Lib.Par.fsti @@ -16,14 +16,12 @@ module Pulse.Lib.Par #lang-pulse open Pulse.Lib.Core +open Pulse.Lib.Send +open PulseCore.Observability -val par_stt - (#preL:slprop) - (#postL:slprop) - (#preR:slprop) - (#postR:slprop) - (f:stt unit preL (fun _ -> postL)) - (g:stt unit preR (fun _ -> postR)) -: stt unit - (preL ** preR) - (fun _ -> postL ** postR) \ No newline at end of file +fn par (#preL: slprop) #postL #preR #postR + {| is_send preL, is_send postL, is_send preR, is_send postR |} + (f:unit -> stt unit preL (fun _ -> postL)) + (g:unit -> stt unit preR (fun _ -> postR)) + requires preL ** preR + ensures postL ** postR diff --git a/lib/pulse/lib/Pulse.Lib.Pervasives.fst b/lib/pulse/lib/Pulse.Lib.Pervasives.fst index ad451fb59..ce5ee2480 100644 --- a/lib/pulse/lib/Pulse.Lib.Pervasives.fst +++ b/lib/pulse/lib/Pulse.Lib.Pervasives.fst @@ -18,6 +18,8 @@ module Pulse.Lib.Pervasives #lang-pulse include Pulse.Main include Pulse.Lib.Core +include Pulse.Lib.Inv +include Pulse.Lib.Send include Pulse.Lib.Forall include Pulse.Lib.Array include Pulse.Lib.Reference @@ -148,55 +150,6 @@ fn intro_cond_false (p q:slprop) fold (cond false p q); } - - -fn par (#pf #pg #qf #qg:_) - (f: unit -> stt unit pf (fun _ -> qf)) - (g: unit -> stt unit pg (fun _ -> qg)) - requires pf ** pg - ensures qf ** qg -{ - parallel - requires pf and pg - ensures qf and qg - { f () } - { g () }; - () -} - - - -fn par_atomic (#is #js #pf #pg #qf #qg:_) - (f: unit -> stt_atomic unit #Observable is pf (fun _ -> qf)) - (g: unit -> stt_atomic unit js pg (fun _ -> qg)) - requires pf ** pg - ensures qf ** qg -{ - parallel - requires pf and pg - ensures qf and qg - { f () } - { g () }; - () -} - - - -fn par_atomic_l (#is #pf #pg #qf #qg:_) - (f: unit -> stt_atomic unit #Observable is pf (fun _ -> qf)) - (g: unit -> stt unit pg (fun _ -> qg)) - requires pf ** pg - ensures qf ** qg -{ - parallel - requires pf and pg - ensures qf and qg - { f () } - { g () }; - () -} - - type rust_extraction_attr = | Rust_const_fn | Rust_generics_bounds : list string -> rust_extraction_attr diff --git a/lib/pulse/lib/Pulse.Lib.Reference.fst b/lib/pulse/lib/Pulse.Lib.Reference.fst index 9c727f145..960b06c67 100644 --- a/lib/pulse/lib/Pulse.Lib.Reference.fst +++ b/lib/pulse/lib/Pulse.Lib.Reference.fst @@ -36,6 +36,8 @@ let upd_singleton #a (x y: a) : let pts_to (#a: Type u#a) (r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) = A.pts_to r #p (singleton n) +let is_send_pts_to r n = Tactics.Typeclasses.solve + let pts_to_timeless _ _ _ = () let is_full_ref = A.is_full_array diff --git a/lib/pulse/lib/Pulse.Lib.Reference.fsti b/lib/pulse/lib/Pulse.Lib.Reference.fsti index 35757d8be..e0dd06f36 100644 --- a/lib/pulse/lib/Pulse.Lib.Reference.fsti +++ b/lib/pulse/lib/Pulse.Lib.Reference.fsti @@ -23,6 +23,7 @@ open FStar.Ghost open Pulse.Class.PtsTo open Pulse.Lib.Array.Basic open Pulse.Lib.SmallType +open Pulse.Lib.Send module T = FStar.Tactics val ref ([@@@unused]a:Type) : Type0 @@ -32,6 +33,8 @@ val is_null #a (r : ref a) : b:bool{b <==> r == null #a} val pts_to (#a:Type u#a) ([@@@mkey]r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) : slprop +instance val is_send_pts_to #a r #p n : is_send (pts_to #a r #p n) + [@@pulse_unfold] instance has_pts_to_ref (a:Type u#a) : has_pts_to (ref a) a = { pts_to = (fun r #f v -> pts_to r #f v); diff --git a/lib/pulse/lib/Pulse.Lib.SLPropTable.fst b/lib/pulse/lib/Pulse.Lib.SLPropTable.fst index b11ecf664..bda0b6ad4 100644 --- a/lib/pulse/lib/Pulse.Lib.SLPropTable.fst +++ b/lib/pulse/lib/Pulse.Lib.SLPropTable.fst @@ -13,12 +13,16 @@ let is_table (t:table) (max:nat) : slprop = GT.is_table t max +let placeless_is_table t max = Tactics.Typeclasses.solve + let pts_to ([@@@mkey]t:table) ([@@@mkey]i:nat) (#f:perm) (p:slprop) : slprop = exists* r. slprop_ref_pts_to r p ** GT.pts_to t i #f r +let placeless_pts_to t i #f p = Tactics.Typeclasses.solve + ghost fn create () requires emp diff --git a/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti b/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti index 340b4f600..e19dee0ce 100644 --- a/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti +++ b/lib/pulse/lib/Pulse.Lib.SLPropTable.fsti @@ -9,8 +9,12 @@ instance val non_informative_table: NonInformative.non_informative table val is_table ([@@@mkey]t:table) (max:nat) : slprop +instance val placeless_is_table t max : placeless (is_table t max) + val pts_to ([@@@mkey]t:table) ([@@@mkey]i:nat) (#f:perm) (p:slprop) : slprop +instance val placeless_pts_to t i #f p : placeless (pts_to t i #f p) + ghost fn create () requires emp diff --git a/lib/pulse/lib/Pulse.Lib.Send.fst b/lib/pulse/lib/Pulse.Lib.Send.fst new file mode 100644 index 000000000..493fd340e --- /dev/null +++ b/lib/pulse/lib/Pulse.Lib.Send.fst @@ -0,0 +1,377 @@ +(* + Copyright 2025 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.Lib.Send +open Pulse.Lib.Core +open Pulse.Class.Duplicable +open Pulse.Main +#lang-pulse + +ghost fn placeless_move (p: slprop) {| inst: placeless p |} l1 l2 + requires on l1 p + ensures on l2 p +{ + inst l1 l2 +} + +ghost fn placeless_on_intro (p: slprop) {| placeless p |} l + requires p + ensures on l p +{ + let l0 = loc_get (); + on_intro p; + placeless_move p l0 l; + drop_ (loc l0) +} + +ghost fn placeless_on_elim (p: slprop) {| placeless p |} l + requires on l p + ensures p +{ + let l0 = loc_get (); + placeless_move p l l0; + on_elim p; + drop_ (loc l0) +} + +ghost fn placeless_on (l: loc_id) (p: slprop) : placeless (on l p) = l1 l2 { + on_on_eq l1 l p; rewrite on l1 (on l p) as on l p; + on_on_eq l2 l p; rewrite on l p as on l2 (on l p); +} + +ghost fn ghost_impersonate + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre post: slprop) {| placeless pre, placeless post |} + (f: unit -> stt_ghost unit is (loc l ** pre) (fun _ -> loc l ** post)) + opens is + requires pre + ensures post +{ + on_loc_eq l l; rewrite pure (l == l) as on l (loc l); + placeless_on_intro pre l; + on_star_eq l (loc l) pre; rewrite on l (loc l) ** on l pre as on l (loc l ** pre); + ghost_impersonate_core #is l (loc l ** pre) post fn _ { + f (); + drop_ (loc l) + }; + placeless_on_elim post l; +} + +ghost fn placeless_emp' () : placeless emp = l1 l2 { + ghost_impersonate l2 (on l1 emp) (on l2 emp) fn _ { + drop_ (on l1 emp); + on_intro emp; + } +} +let placeless_emp = placeless_emp' () + +ghost fn placeless_star (a b: slprop) {| placeless a, placeless b |} : placeless (a ** b) = l1 l2 { + on_star_eq l1 a b; rewrite on l1 (a ** b) as on l1 a ** on l1 b; + placeless_move a l1 l2; + placeless_move b l1 l2; + on_star_eq l2 a b; rewrite on l2 a ** on l2 b as on l2 (a ** b); +} + +ghost fn placeless_pure (p: prop) : placeless (pure p) = l1 l2 { + ghost_impersonate l1 (on l1 (pure p)) (on l2 (pure p)) fn _ { + on_elim (pure p); + ghost_impersonate l2 emp (on l2 (pure p)) fn _ { + on_intro (pure p) + } + } +} + +ghost fn on_pure_elim l p + requires on l (pure p) + ensures pure p +{ + placeless_on_elim (pure p) l; +} + +ghost fn placeless_later_credit amt : placeless (later_credit amt) = l1 l2 { + on_later_credit_eq l1 amt; + on_later_credit_eq l2 amt; + rewrite on l1 (later_credit amt) as on l2 (later_credit amt); +} + +ghost fn placeless_equiv a b : placeless (equiv a b) = l1 l2 { + on_equiv_eq l1 a b; + on_equiv_eq l2 a b; + rewrite on l1 (equiv a b) as on l2 (equiv a b); +} + +ghost fn placeless_slprop_ref_pts_to x y : placeless (slprop_ref_pts_to x y) = l1 l2 { + on_slprop_ref_pts_to_eq l1 x y; + on_slprop_ref_pts_to_eq l2 x y; + rewrite on l1 (slprop_ref_pts_to x y) as on l2 (slprop_ref_pts_to x y); +} + +ghost fn placeless_exists' u#a (#a: Type u#a) (p: a -> slprop) {| ((x:a) -> placeless (p x)) |} : + placeless (exists* x. p x) = l1 l2 { + ghost_impersonate l1 (on l1 (exists* x. p x)) (on l2 (exists* x. p x)) fn _ { + on_elim _; with x. assert p x; + ghost_impersonate l2 (p x) (on l2 (exists* x. p x)) fn _ { + on_intro (exists* x. p x) + } + } +} +let placeless_exists = placeless_exists' + +let timeless_in_same_process p = + assert_norm (in_same_process p == (exists* l. loc l ** pure (process_of l == process_of p))) + +ghost fn dup_in_same_process p () : duplicable_f (in_same_process p) = { + unfold in_same_process p; + loc_dup _; + fold in_same_process p; + fold in_same_process p; +} + +instance duplicable_in_same_process p : duplicable (in_same_process p) = + { dup_f = dup_in_same_process p } + +ghost fn on_star_elim #l (p q: slprop) + requires on l (p ** q) + ensures on l p + ensures on l q +{ + ghost_impersonate l (on l (p ** q)) (on l p ** on l q) fn _ { + on_elim (p ** q); + on_intro p; + on_intro q; + } +} + +ghost fn on_star_intro #l (p q: slprop) + requires on l p + requires on l q + ensures on l (p ** q) +{ + ghost_impersonate l (on l p ** on l q) (on l (p ** q)) fn _ { + on_elim p; + on_elim q; + on_intro (p ** q); + } +} + +ghost fn on_exists_elim u#a #l (#a: Type u#a) (p: a -> slprop) + requires on l (exists* x. p x) + ensures exists* x. on l (p x) +{ + ghost_impersonate l (on l (exists* x. p x)) (exists* x. on l (p x)) fn _ { + on_elim (exists* x. p x); + on_intro (p _); + } +} + +ghost fn is_send_across_elim #b (g: loc_id -> b) p {| inst: is_send_across g p |} #l l' + requires on l p + requires pure (g l == g l') + ensures on l' p +{ + inst l l' +} + +ghost fn is_send_elim p {| inst: is_send p |} #l l' + requires on l p + requires pure (process_of l == process_of l') + ensures on l' p +{ + is_send_across_elim process_of p #inst l' +} + +ghost fn is_send_elim_on p {| is_send p |} #l + preserves in_same_process l + requires on l p + ensures p +{ + unfold in_same_process l; + with l0. assert loc l0; + is_send_elim p l0; + on_elim p; + fold in_same_process l; +} + +ghost fn is_send_intro_on p {| is_send p |} l + preserves in_same_process l + requires p + ensures on l p +{ + unfold in_same_process l; + with l0. assert loc l0; + on_intro p; + is_send_elim p l; + fold in_same_process l; +} + +ghost fn is_send_elim_on' p {| is_send p |} #l + preserves loc l + requires on (process_of l) p + ensures p +{ + loc_dup l; + fold in_same_process (process_of l); + is_send_elim_on p #_; + drop_ (in_same_process (process_of l)); +} + +ghost fn is_send_intro_on' p {| is_send p |} l + preserves loc l + requires p + ensures on (process_of l) p +{ + loc_dup l; + fold in_same_process (process_of l); + is_send_intro_on p (process_of l); + drop_ (in_same_process (process_of l)); +} + +ghost fn is_send_across_placeless #b #g p {| placeless p |} : is_send_across #b g p = l l' { + placeless_move p l l' +} + +ghost fn is_send_across_star #b #g p q {| is_send_across #b g p, is_send_across g q |} : is_send_across g (p ** q) = l l' { + on_star_elim p q; + is_send_across_elim g p l'; + is_send_across_elim g q l'; + on_star_intro p q; +} + +ghost fn is_send_across_exists' u#a #b #g (#a: Type u#a) (p: a->slprop) {| ((x:a) -> is_send_across #b g (p x)) |} : + is_send_across g (exists* x. p x) = l l' { + ghost_impersonate l (on l (exists* x. p x)) (on l' (exists* x. p x)) fn _ { + on_elim (exists* x. p x); + with x. assert p x; + on_intro (p x); + is_send_across_elim g (p x) l'; + ghost_impersonate l' (on l' (p x)) (on l' (exists* x. p x)) fn _ { + on_elim (p x); + on_intro (exists* x. p x) + }; + } +} +let is_send_across_exists = is_send_across_exists' + +ghost fn is_send_in_same_process p : is_send (in_same_process p) = l l' { + ghost_impersonate l + (on l (in_same_process p)) + (on l' (in_same_process p)) + fn _ { + on_elim (in_same_process p); + unfold in_same_process p; + loc_gather l #_; + ghost_impersonate l' emp (on l' (in_same_process p)) fn _ { + loc_dup l'; + fold in_same_process p; + on_intro (in_same_process p); + } + } +} + +let on_same_process (p: slprop) = + exists* l. in_same_process l ** on l p + +ghost fn on_same_process_elim p {| is_send p |} + requires on_same_process p + ensures p +{ + unfold on_same_process p; + is_send_elim_on p #_; + drop_ (in_same_process _); +} + +ghost fn on_same_process_intro p + requires p + ensures on_same_process p +{ + let l = loc_get (); + on_intro p; + fold in_same_process l; + fold on_same_process p; +} + +let timeless_on_same_process p = + assert_norm (on_same_process p == (exists* l. in_same_process l ** on l p)) + +ghost fn is_send_on_same_process p : is_send (on_same_process p) = l1 l2 { + ghost_impersonate l1 + (on l1 (on_same_process p)) + (on l2 (on_same_process p)) + fn _ { + on_elim (on_same_process p); + unfold on_same_process p; with l. _; + unfold in_same_process l; with l1'. _; + loc_gather l1 #l1'; + ghost_impersonate l2 + (on l p) + (on l2 (on_same_process p)) + fn _ { + loc_dup l2; fold in_same_process l; + fold on_same_process p; + on_intro (on_same_process p); + } + } +} + +let is_send_tag ([@@@mkey] p: slprop) (inst: is_send p) = emp +let sendable p = exists* inst. is_send_tag p inst ** p + +ghost fn sendable_elim p + requires sendable p + ensures p +{ + unfold sendable p; + drop_ (is_send_tag p _); +} + +ghost fn sendable_intro p {| inst: is_send p |} + requires p + ensures sendable p +{ + fold is_send_tag p inst; + fold sendable p; +} + +ghost fn is_send_sendable p : is_send (sendable p) = l1 l2 { + ghost_impersonate l1 (on l1 (sendable p)) (on l2 (sendable p)) fn _ { + on_elim (sendable p); + unfold sendable p; + with inst. unfold is_send_tag p inst; + let inst = inst; + on_intro p; + is_send_elim p l2; + ghost_impersonate l2 (on l2 p) (on l2 (sendable p)) fn _ { + on_elim p; + fold is_send_tag p inst; + fold sendable p; + on_intro (sendable p) + } + } +} + +inline_for_extraction noextract fn fork' + (pre:slprop) {| is_send pre |} + (f: (unit -> stt unit pre (fun _ -> emp))) + requires pre +{ + let l = loc_get (); + fork_core pre #l fn _ { + fold in_same_process l; + is_send_elim_on pre #_; + f (); + drop_ (in_same_process l) + } +} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.Send.fsti b/lib/pulse/lib/Pulse.Lib.Send.fsti new file mode 100644 index 000000000..47dc7d438 --- /dev/null +++ b/lib/pulse/lib/Pulse.Lib.Send.fsti @@ -0,0 +1,135 @@ +(* + Copyright 2025 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.Lib.Send +open Pulse.Lib.Core +open Pulse.Class.Duplicable +open Pulse.Main +module T = FStar.Tactics.V2 +#lang-pulse + +[@@Tactics.Typeclasses.tcclass; erasable] +type is_send_across (#b:Type0) (g: loc_id -> b) (p: slprop) = + l:loc_id -> l':loc_id { g l == g l' } -> stt_ghost unit emp_inames (on l p) (fun _ -> on l' p) + +irreducible let anywhere (l: loc_id) = () + +[@@Tactics.Typeclasses.tcclass; erasable] +type placeless (p: slprop) = + is_send_across anywhere p + +ghost fn ghost_impersonate + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre post: slprop) {| placeless pre, placeless post |} + (f: unit -> stt_ghost unit is (loc l ** pre) (fun _ -> loc l ** post)) + opens is + requires pre + ensures post + +ghost fn placeless_move (p: slprop) {| placeless p |} l1 l2 + requires on l1 p + ensures on l2 p + +ghost fn placeless_on_intro (p: slprop) {| placeless p |} l + requires p + ensures on l p + +ghost fn placeless_on_elim (p: slprop) {| placeless p |} l + requires on l p + ensures p + +instance val placeless_on (l: loc_id) (p: slprop) : placeless (on l p) +instance val placeless_emp : placeless emp +instance val placeless_star (a b: slprop) {| placeless a, placeless b |} : placeless (a ** b) +instance val placeless_pure (p: prop) : placeless (pure p) +instance val placeless_later_credit amt : placeless (later_credit amt) +instance val placeless_equiv a b : placeless (equiv a b) +instance val placeless_slprop_ref_pts_to x y : placeless (slprop_ref_pts_to x y) +instance val placeless_exists #a (p: a -> slprop) {| ((x:a) -> placeless (p x)) |} : + placeless (exists* x. p x) + +let in_same_process p = exists* l. loc l ** pure (process_of l == process_of p) +val timeless_in_same_process p : Lemma (timeless (in_same_process p)) [SMTPat (timeless (in_same_process p))] +instance val duplicable_in_same_process p : duplicable (in_same_process p) + +[@@Tactics.Typeclasses.tcclass; erasable] +let is_send p = is_send_across process_of p + +ghost fn is_send_across_elim #b (g: loc_id -> b) p {| inst: is_send_across g p |} #l l' + requires on l p + requires pure (g l == g l') + ensures on l' p + +ghost fn is_send_elim p {| inst: is_send p |} #l l' + requires on l p + requires pure (process_of l == process_of l') + ensures on l' p + +ghost fn is_send_elim_on p {| is_send p |} #l + preserves in_same_process l + requires on l p + ensures p + +ghost fn is_send_intro_on p {| is_send p |} l + preserves in_same_process l + requires p + ensures on l p + +ghost fn is_send_elim_on' p {| is_send p |} #l + preserves loc l + requires on (process_of l) p + ensures p + +ghost fn is_send_intro_on' p {| is_send p |} l + preserves loc l + requires p + ensures on (process_of l) p + +instance val is_send_across_placeless #b #g p {| inst: placeless p |} : is_send_across #b g p +instance val is_send_across_star #b #g p q {| is_send_across #b g p, is_send_across #b g q |} : is_send_across g (p ** q) +instance val is_send_across_exists #b #g #a (p: a->slprop) {| ((x:a) -> is_send_across #b g (p x)) |} : + is_send_across g (exists* x. p x) + +instance is_send_placeless p {| inst: placeless p |} : is_send p = is_send_across_placeless p +instance val is_send_in_same_process p : is_send (in_same_process p) +instance is_send_star p q {| ip: is_send p, iq: is_send q |} : is_send (p ** q) = is_send_across_star p q #ip #iq +instance is_send_exists #a (p: a->slprop) {| i: ((x:a) -> is_send (p x)) |} : + is_send (exists* x. p x) = is_send_across_exists p #i + +val on_same_process (p: slprop) : slprop +ghost fn on_same_process_elim p {| is_send p |} + requires on_same_process p + ensures p +ghost fn on_same_process_intro p + requires p + ensures on_same_process p +val timeless_on_same_process (p: timeless_slprop) : + Lemma (timeless (on_same_process p)) [SMTPat (timeless (on_same_process p))] +instance val is_send_on_same_process p : is_send (on_same_process p) + +val sendable (p: slprop) : slprop +ghost fn sendable_elim p + requires sendable p + ensures p +ghost fn sendable_intro p {| is_send p |} + requires p + ensures sendable p +instance val is_send_sendable p : is_send (sendable p) + +inline_for_extraction noextract fn fork' + (pre:slprop) {| is_send pre |} + (f: (unit -> stt unit pre (fun _ -> emp))) + requires pre \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.SpinLock.fst b/lib/pulse/lib/Pulse.Lib.SpinLock.fst index 96578ae15..fd61faf77 100644 --- a/lib/pulse/lib/Pulse.Lib.SpinLock.fst +++ b/lib/pulse/lib/Pulse.Lib.SpinLock.fst @@ -32,6 +32,12 @@ let lock_inv_aux (r:B.box U32.t) (gr:GR.ref U32.t) (v:slprop) : slprop = pure ((i == 0ul ==> p == 1.0R) /\ (i =!= 0ul ==> p == 0.5R)) +instance is_send_if (i: U32.t) (v: slprop) {| inst: is_send v |} : is_send (if i = 0ul then v else emp) = + if i = 0ul then inst else is_send_placeless emp + +instance is_send_lock_inv_aux r gr v {| is_send v |} : is_send (lock_inv_aux r gr v) = + Tactics.Typeclasses.solve + let lock_inv (r:B.box U32.t) (gr:GR.ref U32.t) (v:slprop) : slprop = lock_inv_aux r gr v @@ -43,9 +49,13 @@ type lock = { i : cinv; } +let is_send_tag v (inst: is_send v) = emp + let lock_alive l #p v = inv (iname_of l.i) (cinv_vp l.i (lock_inv l.r l.gr v)) ** active l.i p +instance is_send_lock_alive = Tactics.Typeclasses.solve + let lock_acquired l = pts_to l.gr #0.5R 1ul @@ -54,9 +64,9 @@ fn new_lock (v:slprop) returns l:lock ensures lock_alive l v { - let r = B.alloc 0ul; let gr = GR.alloc 0ul; rewrite v as (if 0ul = 0ul then v else emp); + let r = B.alloc 0ul; fold (lock_inv_aux r gr v); fold (lock_inv r gr v); let i = new_cancellable_invariant (lock_inv r gr v); @@ -68,21 +78,18 @@ fn new_lock (v:slprop) l } - - fn rec acquire (#v:slprop) (#p:perm) (l:lock) preserves lock_alive l #p v ensures v ** lock_acquired l { unfold (lock_alive l #p v); - later_credit_buy 1; let b = - with_invariants (CInv.iname_of l.i) - returns b:bool - ensures later (cinv_vp l.i (lock_inv l.r l.gr v)) ** - active l.i p ** - (if b then v ** pts_to l.gr #0.5R 1ul else emp) { - later_elim _; + with_invariants bool emp_inames (CInv.iname_of l.i) (cinv_vp l.i (lock_inv l.r l.gr v)) + (active l.i p) + (fun b -> + active l.i p ** + (cond b (v ** pts_to l.gr #0.5R 1ul) emp)) + fn _ { unpack_cinv_vp l.i; unfold lock_inv; unfold lock_inv_aux; @@ -102,8 +109,7 @@ fn rec acquire (#v:slprop) (#p:perm) (l:lock) v); let b = true; rewrite (v ** pts_to l.gr #0.5R 1ul) - as (if b then v ** pts_to l.gr #0.5R 1ul else emp); - later_intro (CInv.cinv_vp l.i (lock_inv l.r l.gr v)); + as (cond b (v ** pts_to l.gr #0.5R 1ul) emp); b } else { elim_cond_false _ _ _; @@ -114,16 +120,17 @@ fn rec acquire (#v:slprop) (#p:perm) (l:lock) active l.i p); let b = false; rewrite emp as - (if b then v ** pts_to l.gr #0.5R 1ul else emp); - later_intro (CInv.cinv_vp l.i (lock_inv l.r l.gr v)); + (cond b (v ** pts_to l.gr #0.5R 1ul) emp); b } }; if b { + elim_cond_true b _ _; fold (lock_alive l #p v); fold (lock_acquired l) } else { + elim_cond_false b _ _; fold (lock_alive l #p v); acquire l } @@ -136,27 +143,24 @@ fn release (#v:slprop) (#p:perm) (l:lock) requires lock_acquired l ** v { unfold (lock_alive l #p v); - unfold (lock_acquired l); - later_credit_buy 1; - with_invariants (CInv.iname_of l.i) - returns _:unit - ensures later (cinv_vp l.i (lock_inv l.r l.gr v)) ** - active l.i p { - later_elim _; + with_invariants unit emp_inames (CInv.iname_of l.i) (cinv_vp l.i (lock_inv l.r l.gr v)) + (lock_acquired l ** v ** active l.i p) + (fun _ -> active l.i p) + fn _ { + unfold (lock_acquired l); unpack_cinv_vp l.i; unfold (lock_inv l.r l.gr v); unfold (lock_inv_aux l.r l.gr v); GR.pts_to_injective_eq l.gr; GR.gather l.gr #_ #1ul; with i. assert (pts_to l.gr i); - rewrite (if (i = 0ul) then v else emp) as emp; - write_atomic_box l.r 0ul; + rewrite each i as 1ul; GR.(l.gr := 0ul); + write_atomic_box l.r 0ul; fold (lock_inv_aux l.r l.gr v); fold (lock_inv l.r l.gr v); pack_cinv_vp l.i; - later_intro (cinv_vp l.i (lock_inv l.r l.gr v)); }; fold (lock_alive l #p v) @@ -184,10 +188,10 @@ fn gather (#v:slprop) (#p1 #p2 :perm) (l:lock) ensures lock_alive l #(p1 +. p2) v { unfold (lock_alive l #p1 v); + drop_ (inv (iname_of l.i) _); unfold (lock_alive l #p2 v); CInv.gather #p1 #p2 l.i; fold (lock_alive l #(p1 +. p2) v); - drop_ (inv _ _) } @@ -200,11 +204,12 @@ fn free (#v:slprop) (l:lock) later_credit_buy 1; cancel l.i; unfold (lock_inv l.r l.gr v); - unfold (lock_inv_aux l.r l.gr v); + unfold (lock_inv_aux l.r l.gr v); with i. _; B.free l.r; GR.gather l.gr #_ #1ul; with v. assert l.gr |-> v; rewrite each v as 1ul; // awkward GR.free l.gr; + () } @@ -215,76 +220,12 @@ fn lock_alive_inj requires lock_alive l #p1 v1 ** lock_alive l #p2 v2 ensures lock_alive l #p1 v1 ** lock_alive l #p2 v1 { - unfold (lock_alive l #p1 v1); unfold (lock_alive l #p2 v2); + drop_ (inv _ _); + unfold (lock_alive l #p1 v1); dup_inv (CInv.iname_of l.i) (CInv.cinv_vp l.i (lock_inv l.r l.gr v1)); fold (lock_alive l #p1 v1); fold (lock_alive l #p2 v1); - drop_ (inv _ _); // TODO: we could also prove from, but that requires a significant amount of congruence lemmas about equiv // invariant_name_identifies_invariant (CInv.iname_of l.i) (CInv.iname_of l.i); } - - -let iname_of l = CInv.iname_of l.i -let iname_v_of l v = cinv_vp l.i (lock_inv l.r l.gr v) -let lock_active #p l = active l.i p - - -ghost -fn share_lock_active (#p:perm) (l:lock) - requires lock_active #p l - ensures lock_active #(p /. 2.0R) l ** lock_active #(p /. 2.0R) l -{ - unfold (lock_active #p l); - CInv.share l.i; - fold (lock_active #(p /. 2.0R) l); - fold (lock_active #(p /. 2.0R) l) -} - - - -ghost -fn gather_lock_active (#p1 #p2:perm) (l:lock) - requires lock_active #p1 l ** lock_active #p2 l - ensures lock_active #(p1 +. p2) l -{ - unfold (lock_active #p1 l); - unfold (lock_active #p2 l); - CInv.gather #p1 #p2 l.i; - fold (lock_active #(p1 +. p2) l) -} - - - -ghost -fn elim_inv_and_active_into_alive (l:lock) (v:slprop) (#p:perm) - ensures (inv (iname_of l) (iname_v_of l v) ** lock_active #p l) @==> lock_alive l #p v -{ - intro (inv (iname_of l) (iname_v_of l v) ** lock_active #p l @==> lock_alive l #p v) fn _ - { - rewrite each - iname_of l as CInv.iname_of l.i, - iname_v_of l v as cinv_vp l.i (lock_inv l.r l.gr v); - unfold (lock_active #p l); - fold (lock_alive l #p v) - }; -} - - - -ghost -fn elim_alive_into_inv_and_active (l:lock) (v:slprop) (#p:perm) - requires emp - ensures lock_alive l #p v @==> (inv (iname_of l) (iname_v_of l v) ** lock_active #p l) -{ - intro (lock_alive l #p v @==> inv (iname_of l) (iname_v_of l v) ** lock_active #p l) fn _ - { - unfold (lock_alive l #p v); - fold (lock_active #p l); - rewrite each - CInv.iname_of l.i as iname_of l, - cinv_vp l.i (lock_inv l.r l.gr v) as iname_v_of l v - }; -} - diff --git a/lib/pulse/lib/Pulse.Lib.SpinLock.fsti b/lib/pulse/lib/Pulse.Lib.SpinLock.fsti index 75ba1ca7f..390b5a7ea 100644 --- a/lib/pulse/lib/Pulse.Lib.SpinLock.fsti +++ b/lib/pulse/lib/Pulse.Lib.SpinLock.fsti @@ -29,6 +29,8 @@ val lock_alive (v:slprop) : slprop +instance val is_send_lock_alive l p v {| is_send v |} : is_send (lock_alive l #p v) + val lock_acquired (l:lock) : slprop fn new_lock (v:slprop) @@ -66,26 +68,3 @@ fn lock_alive_inj (l:lock) (#p1 #p2 :perm) (#v1 #v2 :slprop) requires lock_alive l #p1 v1 ** lock_alive l #p2 v2 ensures lock_alive l #p1 v1 ** lock_alive l #p2 v1 - -val iname_of (l:lock) : iname -val iname_v_of (l:lock) (v:slprop) : slprop -val lock_active (#[T.exact (`1.0R)] p:perm) (l:lock) : v:slprop { timeless v } - -ghost -fn share_lock_active (#p:perm) (l:lock) - requires lock_active #p l - ensures lock_active #(p /. 2.0R) l ** lock_active #(p /. 2.0R) l - -ghost -fn gather_lock_active (#p1 #p2:perm) (l:lock) - requires lock_active #p1 l ** lock_active #p2 l - ensures lock_active #(p1 +. p2) l - -ghost -fn elim_inv_and_active_into_alive (l:lock) (v:slprop) (#p:perm) - ensures (inv (iname_of l) (iname_v_of l v) ** lock_active #p l) @==> lock_alive l #p v - -ghost -fn elim_alive_into_inv_and_active (l:lock) (v:slprop) (#p:perm) - requires emp - ensures lock_alive l #p v @==> (inv (iname_of l) (iname_v_of l v) ** lock_active #p l) diff --git a/lib/pulse/lib/Pulse.Lib.Task.fst b/lib/pulse/lib/Pulse.Lib.Task.fst index 2f142ecca..17d5218f1 100644 --- a/lib/pulse/lib/Pulse.Lib.Task.fst +++ b/lib/pulse/lib/Pulse.Lib.Task.fst @@ -23,7 +23,6 @@ open FStar.Tactics open FStar.Preorder open Pulse.Lib.Pledge open Pulse.Lib.Trade -open Pulse.Lib.Shift open Pulse.Class.Duplicable open Pulse.Class.Introducable @@ -82,14 +81,24 @@ let state_res | Done -> post | Claimed -> AR.anchored g_state Claimed +instance is_send_state_res pre post g_state st {| is_send pre, is_send post |} : + is_send (state_res pre post g_state st) = + match st with + | Ready -> Tactics.Typeclasses.solve #(is_send pre) + | Running -> Tactics.Typeclasses.solve #(is_send emp) + | Done -> Tactics.Typeclasses.solve #(is_send post) + | Claimed -> Tactics.Typeclasses.solve #(is_send (AR.anchored g_state Claimed)) + noeq type handle : Type0 = { state : box task_state; g_state : AR.ref task_state p_st anchor_rel; (* these two refs are kept in sync *) } +let is_send_tag v (inst: is_send v) = emp + let up (x: slprop_ref) : slprop = - exists* v. slprop_ref_pts_to x v ** v + exists* v inst. slprop_ref_pts_to x v ** is_send_tag v inst ** v noeq type task_t : Type0 = { @@ -119,25 +128,27 @@ let state_pred let task_type (pre post : slprop) : Type0 = unit -> task_f pre post -let task_thunk_typing_core (t : task_t) (pre post: slprop) : slprop = +let task_thunk_typing_core (t : task_t) (pre post: slprop) inst : slprop = slprop_ref_pts_to t.pre pre ** slprop_ref_pts_to t.post post ** + is_send_tag post inst ** pure (Dyn.dyn_has_ty t.thunk (task_type pre post)) let task_thunk_typing (t : task_t) : slprop = - exists* pre post. task_thunk_typing_core t pre post + exists* pre post inst. task_thunk_typing_core t pre post inst ghost fn task_thunk_typing_dup t requires task_thunk_typing t ensures task_thunk_typing t ** task_thunk_typing t { unfold task_thunk_typing t; - with pre post. assert task_thunk_typing_core t pre post; + with pre post inst. assert task_thunk_typing_core t pre post inst; unfold task_thunk_typing_core t pre post; slprop_ref_share t.pre; slprop_ref_share t.post; - fold task_thunk_typing_core t pre post; - fold task_thunk_typing_core t pre post; + fold is_send_tag post inst; + fold task_thunk_typing_core t pre post inst; + fold task_thunk_typing_core t pre post inst; fold task_thunk_typing t; fold task_thunk_typing t; } @@ -155,6 +166,16 @@ let rec all_state_pred state_pred t.pre t.post t.h ** all_state_pred ts +instance is_send_all_state_pred v_runnable : is_send (all_state_pred v_runnable) = + let rec is_send_all_state_pred v_runnable : is_send (all_state_pred v_runnable) = + match v_runnable with + | [] -> is_send_placeless emp + | t::ts -> + let _: is_send (all_state_pred ts) = is_send_all_state_pred ts in + is_send_star (task_thunk_typing t) (state_pred t.pre t.post t.h ** all_state_pred ts) #_ + #(is_send_star _ _ #_ #_) in + is_send_all_state_pred v_runnable + ghost fn add_one_state_pred (t : task_t) @@ -232,6 +253,8 @@ type pool : Type0 = pool_st let pool_alive (#[exact (`1.0R)] f : perm) (p:pool) : slprop = lock_alive p.lk #(f /. 2.0R) (lock_inv p.runnable p.g_runnable) +let is_send_pool_alive p = Tactics.Typeclasses.solve + let state_res' (post : slprop) ( st : task_state) = match st with | Done -> post @@ -246,6 +269,65 @@ let task_spotted AR.snapshot p.g_runnable v_runnable ** pure (List.memP t v_runnable) +let shift_tag p q extra (inst1: placeless extra) (inst2: duplicable extra) + (f: unit -> stt_ghost unit emp_inames (extra ** p) (fun _ -> q)) = + emp +let shift p q = exists* extra inst1 inst2 f. shift_tag p q extra inst1 inst2 f ** extra + +fn introducable_shift_aux u#a (t: Type u#a) is + hyp extra concl {| inst1 : placeless extra |} {| inst2: duplicable extra |} {| introducable emp_inames (extra ** hyp) concl t |} (k: t) : + stt_ghost unit is extra (fun _ -> shift hyp concl) = { + ghost fn f () norewrite requires extra ** hyp ensures concl { + intro concl #(extra ** hyp) (fun _ -> k); + }; + fold shift_tag hyp concl extra inst1 inst2 f; + fold shift hyp concl; +} + +instance introducable_shift (t: Type u#a) is + hyp extra concl {| placeless extra, duplicable extra |} {| introducable emp_inames (extra ** hyp) concl t |} : + introducable is extra (shift hyp concl) t = + { intro_aux = introducable_shift_aux t is hyp extra concl } + +ghost fn dup_shift p q () : duplicable_f (shift p q) = { + unfold shift p q; + with e i1 i2 f. assert shift_tag p q e i1 i2 f; + fold shift_tag p q e i1 i2 f; + let i2=i2; dup e (); + fold shift p q; + fold shift p q; +} +instance duplicable_shift p q : duplicable (shift p q) = + { dup_f = dup_shift p q } + +ghost fn elim_shift p q + requires p + requires shift p q + ensures q +{ + unfold shift p q; + with e i1 i2 f. assert shift_tag p q e i1 i2 f; + unfold shift_tag p q e i1 i2 f; + let f = f; + f () +} + +ghost fn placeless_shift' p q : placeless (shift p q) = l1 l2 { + ghost_impersonate l1 (on l1 (shift p q)) (on l2 (shift p q)) fn _ { + on_elim (shift p q); + unfold shift p q; + with e i1 i2 f. assert shift_tag p q e i1 i2 f; + on_intro e; + { let i1=i1; i1 l1 l2; }; + ghost_impersonate l2 (on l2 e ** shift_tag p q e i1 i2 f) (on l2 (shift p q)) fn _ { + on_elim e; + fold shift p q; + on_intro (shift p q); + }; + } +} +instance placeless_shift p q : placeless (shift p q) = placeless_shift' p q + let handle_spotted (p : pool) (post : slprop) @@ -256,6 +338,9 @@ let handle_spotted shift (up t.post ** later_credit 1) post ** pure (t.h == h) +instance is_send_handle_spotted p post h : is_send (handle_spotted p post h) = + Tactics.Typeclasses.solve + ghost fn intro_task_spotted (p : pool) @@ -414,11 +499,12 @@ ghost fn shift_up (x: slprop_ref) (y: slprop) ensures shift (up x ** later_credit 1) y { intro (shift (up x ** later_credit 1) y) #(slprop_ref_pts_to x y) fn _ { - unfold up x; + unfold up x; with v inst. _; slprop_ref_gather _ #_ #y; later_elim _; equiv_elim _ _; drop_ (slprop_ref_pts_to _ _); + drop_ (is_send_tag v inst); }; } @@ -430,6 +516,7 @@ fn spawn (p:pool) (#pf:perm) (#pre : slprop) (#post : slprop) + {| pre_inst: is_send pre, post_inst: is_send post |} (f : unit -> task_f pre post) requires pool_alive #pf p ** pre returns h : handle @@ -458,6 +545,7 @@ fn spawn (p:pool) rewrite each post_ref as task.post; dup (slprop_ref_pts_to task.pre pre) (); dup (slprop_ref_pts_to task.post post) (); + fold is_send_tag post post_inst; fold task_thunk_typing_core task pre post; fold task_thunk_typing task; @@ -490,6 +578,7 @@ fn spawn (p:pool) assert (pts_to r_task_st Ready); rewrite each r_task_st as handle.state; + fold is_send_tag pre pre_inst; fold up task.pre; rewrite (up task.pre) as (state_res (up task.pre) (up task.post) gr_task_st Ready); @@ -806,6 +895,7 @@ fn spawn_ (p:pool) (#pf:perm) (#pre : slprop) (#post : slprop) + {| is_send pre, is_send post |} (f : unit -> stt unit (pre) (fun _ -> post)) requires pool_alive #pf p ** pre ensures pool_alive #pf p ** pledge [] (pool_done p) (post) @@ -1079,9 +1169,9 @@ fn perf_work (t : task_t) ensures up t.post { unfold task_thunk_typing t; - with pre post. assert task_thunk_typing_core t pre post; + with pre post inst. assert task_thunk_typing_core t pre post inst; unfold task_thunk_typing_core; - unfold up; + unfold up t.pre; slprop_ref_gather t.pre #_ #pre; later_credit_buy 1; later_elim _; equiv_elim _ _; @@ -1089,7 +1179,8 @@ fn perf_work (t : task_t) undyn pre post t.thunk; fold up t.post; // ???? - drop_ (slprop_ref_pts_to _ _); + with v vinst. assert is_send_tag v vinst; + drop_ (slprop_ref_pts_to _ _ ** is_send_tag v _); } fn put_back_result (p:pool) #f (t : task_t) requires pool_alive #f p ** @@ -1404,7 +1495,7 @@ fn spawn_worker requires pool_alive #f p ensures emp { - fork (fun () -> worker_thread #f p) + fork' (pool_alive #f p) (fun () -> worker_thread #f p) } fn rec spawn_workers diff --git a/lib/pulse/lib/Pulse.Lib.Task.fsti b/lib/pulse/lib/Pulse.Lib.Task.fsti index f930e0f38..35c89163f 100644 --- a/lib/pulse/lib/Pulse.Lib.Task.fsti +++ b/lib/pulse/lib/Pulse.Lib.Task.fsti @@ -19,6 +19,7 @@ module Pulse.Lib.Task open Pulse.Lib.Pervasives open Pulse.Lib.Pledge +open Pulse.Lib.Send module T = FStar.Tactics.V2 inline_for_extraction @@ -27,6 +28,7 @@ let task_f pre post = stt unit pre (fun _ -> post) val handle : Type0 val pool : Type0 val pool_alive (#[T.exact (`1.0R)] f : perm) (p:pool) : slprop +instance val is_send_pool_alive #f p : is_send (pool_alive #f p) val joinable (p: pool) (post: slprop) (h: handle) : slprop @@ -35,6 +37,7 @@ fn spawn (#pf: perm) (#pre: slprop) (#post: slprop) + {| is_send pre, is_send post |} (f : unit -> task_f pre post) requires pool_alive #pf p ** pre returns h : handle @@ -56,6 +59,7 @@ fn spawn_ (#pf : perm) (#pre : slprop) (#post : slprop) + {| is_send pre, is_send post |} (f : unit -> task_f pre post) requires pool_alive #pf p ** pre ensures pool_alive #pf p ** pledge [] (pool_done p) post diff --git a/lib/pulse/lib/Pulse.Lib.WithPure.fst b/lib/pulse/lib/Pulse.Lib.WithPure.fst index 4dd7fb306..461b5b014 100644 --- a/lib/pulse/lib/Pulse.Lib.WithPure.fst +++ b/lib/pulse/lib/Pulse.Lib.WithPure.fst @@ -8,7 +8,7 @@ let with_pure (p : prop) (v : squash p -> slprop) : slprop -= op_exists_Star v += exists* h. v h // Alternative definition: // = exists* v'. tag v' ** pure (p /\ v' == v ()) // much easier to work with, but proving the size wasn't obvious. @@ -19,56 +19,34 @@ let with_pure_timeless : Lemma (requires forall s. timeless (v s)) (ensures timeless (with_pure p v)) [SMTPat (timeless (with_pure p v))] -= () += assert_norm (with_pure p v == (exists* h. v h)) -let eta_exists_aux - (#a : Type0) - (p : a -> slprop) -: slprop_equiv (op_exists_Star p) (op_exists_Star (fun (x:a) -> p x)) -= let aux (x:a) : Lemma (slprop_equiv (p x) (p x)) = - Squash.return_squash (slprop_equiv_refl (p x)) - in - Classical.forall_intro aux; - slprop_equiv_exists p (fun x -> p x) () - -let uneta_exists_aux - (#a : Type0) - (p : a -> slprop) -: slprop_equiv (op_exists_Star (fun (x:a) -> p x)) (op_exists_Star p) -= let aux (x:a) : Lemma (slprop_equiv (p x) (p x)) = - Squash.return_squash (slprop_equiv_refl (p x)) - in - Classical.forall_intro aux; - slprop_equiv_exists (fun x -> p x) p () - - -ghost -fn eta_exists - (a : Type0) - (p : a -> slprop) - requires op_exists_Star p - ensures op_exists_Star (fun (x:a) -> p x) +ghost fn on_with_pure_elim l (p: prop) (v: squash p -> slprop) + requires on l (with_pure p v) + ensures with_pure p (fun _ -> on l (v ())) { - rewrite op_exists_Star p - as op_exists_Star (fun (x:a) -> p x) - by apply (`eta_exists_aux); + ghost_impersonate l (on l (with_pure p v)) (with_pure p (fun _ -> on l (v ()))) fn _ { + on_elim (with_pure p v); + unfold with_pure p v; + with h. assert v h; + let h' = h; + rewrite v h as v (); + on_intro (v ()); + } } - - -ghost -fn uneta_exists - (a : Type0) - (p : a -> slprop) - requires op_exists_Star (fun (x:a) -> p x) - ensures op_exists_Star p +ghost fn on_with_pure_intro l (p: prop) (v: squash p -> slprop) + requires with_pure p (fun _ -> on l (v ())) + ensures on l (with_pure p v) { - rewrite op_exists_Star (fun (x:a) -> p x) - as op_exists_Star p - by apply (`uneta_exists_aux); + ghost_impersonate l (with_pure p (fun _ -> on l (v ()))) (on l (with_pure p v)) fn _ { + on_elim _; + fold with_pure p v; + on_intro (with_pure p v); + } } - +let is_send_across_with_pure p v #_ = Tactics.Typeclasses.solve ghost fn intro_with_pure @@ -79,8 +57,6 @@ fn intro_with_pure ensures with_pure p v { assert (v ()); - assert (exists* s. v s); - uneta_exists _ v; fold (with_pure p v); } @@ -109,7 +85,6 @@ fn elim_with_pure ensures v () { unfold (with_pure p v); - eta_exists _ v; with s. assert (v s); squash_single_coerce p v s; () diff --git a/lib/pulse/lib/Pulse.Lib.WithPure.fsti b/lib/pulse/lib/Pulse.Lib.WithPure.fsti index a8577c0db..20da46d7b 100644 --- a/lib/pulse/lib/Pulse.Lib.WithPure.fsti +++ b/lib/pulse/lib/Pulse.Lib.WithPure.fsti @@ -1,6 +1,7 @@ module Pulse.Lib.WithPure #lang-pulse open Pulse.Lib.Core +open Pulse.Lib.Send open Pulse.Main val with_pure @@ -14,6 +15,21 @@ val with_pure_timeless : Lemma (requires forall s. timeless (v s)) (ensures timeless (with_pure p v)) [SMTPat (timeless (with_pure p v))] + +ghost fn on_with_pure_elim l (p: prop) (v: squash p -> slprop) + requires on l (with_pure p v) + ensures with_pure p (fun _ -> on l (v ())) + +ghost fn on_with_pure_intro l (p: prop) (v: squash p -> slprop) + requires with_pure p (fun _ -> on l (v ())) + ensures on l (with_pure p v) + +instance val is_send_across_with_pure #b #g (p:prop) v {| (x:squash p -> is_send_across #b g (v x)) |} : is_send_across g (with_pure p v) +instance placeless_with_pure (p:prop) v {| inst: (x:squash p -> placeless (v x)) |} : placeless (with_pure p v) = + is_send_across_with_pure p v #inst +instance is_send_with_pure (p:prop) v {| inst: (x:squash p -> is_send (v x)) |} : is_send (with_pure p v) = + is_send_across_with_pure p v #inst + ghost fn intro_with_pure (p : prop) diff --git a/lib/pulse/lib/class/Pulse.Class.Duplicable.fst b/lib/pulse/lib/class/Pulse.Class.Duplicable.fst index 473c7d53f..6422e906c 100644 --- a/lib/pulse/lib/class/Pulse.Class.Duplicable.fst +++ b/lib/pulse/lib/class/Pulse.Class.Duplicable.fst @@ -18,8 +18,3 @@ module Pulse.Class.Duplicable #lang-pulse open Pulse.Lib.Core - -instance duplicable_inv (i : iname) (p : slprop) - : duplicable (inv i p) = { - dup_f = (fun () -> dup_inv i p); -} diff --git a/lib/pulse/lib/class/Pulse.Class.Duplicable.fsti b/lib/pulse/lib/class/Pulse.Class.Duplicable.fsti index 164372eec..2079f1687 100644 --- a/lib/pulse/lib/class/Pulse.Class.Duplicable.fsti +++ b/lib/pulse/lib/class/Pulse.Class.Duplicable.fsti @@ -30,5 +30,3 @@ class duplicable (p : slprop) = { let dup (p : slprop) {| d : duplicable p |} () : stt_ghost unit emp_inames p (fun _ -> p ** p) = d.dup_f () - -instance val duplicable_inv (i : iname) (p : slprop) : duplicable (inv i p) diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst index 00d854aa8..46b9f574a 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst +++ b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fst @@ -18,21 +18,23 @@ module Pulse.Lib.Pledge #lang-pulse open Pulse.Lib.Pervasives -open Pulse.Lib.Trade +open Pulse.Lib.SendableTrade module GR = Pulse.Lib.GhostReference let pledge is f v = pure (is_finite is) ** trade #is f (f ** v) +let is_send_pledge is f v = Tactics.Typeclasses.solve + fn introducable_pledge_aux u#a (t: Type u#a) (is: inames) (is': fin_inames) - (f v extra: slprop) {| inst: introducable is' (extra ** f) (f ** v) t |} (x:t) : + (f v extra: slprop) {| is_send extra |} {| inst: introducable is' (extra ** f) (f ** v) t |} (x:t) : stt_ghost unit is extra (fun _ -> pledge is' f v) = { intro #is (trade #is' f (f ** v)) #extra (fun _ -> x); fold pledge is' f v; } instance introducable_pledge (t: Type u#a) is (is': fin_inames) - f v extra {| introducable is' (extra ** f) (f ** v) t |} : + f v extra {| is_send extra |} {| introducable is' (extra ** f) (f ** v) t |} : introducable is extra (pledge is' f v) t = { intro_aux = introducable_pledge_aux t is is' f v extra } @@ -56,7 +58,7 @@ fn pledge_sub_inv (is1:inames) (is2:fin_inames { inames_subset is1 is2 })(f:slpr } ghost -fn return_pledge (f v : slprop) +fn return_pledge (f v : slprop) {| is_send v |} requires v ensures pledge emp_inames f v { @@ -67,7 +69,7 @@ fn return_pledge (f v : slprop) let call #t #is #req #ens (h: unit -> stt_ghost is t req (fun x -> ens x)) = h ghost -fn make_pledge (is:fin_inames) (f:slprop) (v:slprop) (extra:slprop) +fn make_pledge (is:fin_inames) (f:slprop) (v:slprop) (extra:slprop) {| is_send extra |} (k: unit -> pledge_f #is f #extra v) requires extra ensures pledge is f v @@ -107,7 +109,7 @@ fn squash_pledge (is:inames) (f:slprop) (v1:slprop) ghost fn bind_pledge (#is:inames) (#f:slprop) (#v1:slprop) (#v2:slprop) - (extra : slprop) + (extra : slprop) {| is_send extra |} (#is_k:inames { inames_subset is_k is }) (k:unit -> bind_pledge_f #is #is_k f #extra v1 v2) requires pledge is f v1 ** extra @@ -125,13 +127,13 @@ fn bind_pledge (#is:inames) (#f:slprop) (#v1:slprop) (#v2:slprop) ghost fn bind_pledge' (#is:inames) (#f:slprop) (#v1:slprop) (#v2:slprop) - (extra : slprop) + (extra : slprop) {| is_send extra |} (#is_k:inames { inames_subset is_k is }) (k:unit -> bind_pledge_f' #is #is_k f #extra v1 v2) requires pledge is f v1 ** extra ensures pledge is f v2 { - bind_pledge #is #f #v1 #v2 extra #is_k fn _ { + bind_pledge #is #f #v1 #v2 extra #_ #is_k fn _ { call k () }; } @@ -204,20 +206,23 @@ fn squash_pledge' } -// -// This proof below requires inv_p to be big ... -// - (* 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 + | false, false -> pledge is f (sendable v1 ** sendable v2) + | false, true -> sendable v1 + | true, false -> sendable v2 | true, true -> emp +instance is_send_split_switch is b1 b2 f v1 v2 : is_send (split_switch is b1 b2 f v1 v2) = + match b1, b2 with + | false, false -> Tactics.Typeclasses.solve #(is_send (pledge is f (sendable v1 ** sendable v2))) + | false, true -> Tactics.Typeclasses.solve #(is_send (sendable v1)) + | true, false -> Tactics.Typeclasses.solve #(is_send (sendable v2)) + | true, true -> Tactics.Typeclasses.solve #(is_send emp) + let inv_p' (is:inames) (f v1 v2 : slprop) (r1 r2 : GR.ref bool) (b1 b2 : bool) = (r1 |-> Frac 0.5R b1) ** (r2 |-> Frac 0.5R b2) @@ -252,7 +257,8 @@ fn do_elim_body_l assert (r1 |-> false); r1 := true; rewrite emp ** split_switch is false true f v1 v2 - as split_switch is true true f v1 v2 ** v1; + as split_switch is true true f v1 v2 ** sendable v1; + sendable_elim v1; (* This should just disappear when we start normalizing the context. *) @@ -274,9 +280,9 @@ fn do_elim_body_l assert (r1 |-> false); rewrite split_switch is false false f v1 v2 - as pledge is f (v1 ** v2); + as pledge is f (sendable v1 ** sendable v2); - redeem_pledge is f (v1 ** v2); + redeem_pledge is f (sendable v1 ** sendable v2); r1 := true; fold (split_switch is true false f v1 v2); @@ -285,7 +291,8 @@ fn do_elim_body_l fold (inv_p' is f v1 v2 r1 r2 true false); fold inv_p; - assert (f ** v1 ** inv_p is f v1 v2 r1 r2); + assert (f ** sendable v1 ** inv_p is f v1 v2 r1 r2); + sendable_elim v1; drop_ (r1 |-> Frac 0.5R true); } } @@ -300,12 +307,13 @@ fn elim_body_l1 { open Pulse.Lib.GhostReference; assert (pure (not (mem_inv is i))); - with_invariants i - { - later_elim _; - do_elim_body_l #is #f v1 v2 r1 r2 (); - later_intro (inv_p is f v1 v2 r1 r2); - }; + with_invariants_g unit is + i (inv_p is f v1 v2 r1 r2) + (f ** (r1 |-> Frac 0.5R false)) + (fun _ -> f ** v1) + fn _ { + do_elim_body_l #is #f v1 v2 r1 r2 (); + }; } ghost @@ -321,8 +329,7 @@ fn flip_invp unfold inv_p'; (* This is now true with PulseCore. *) - let _ = elim_slprop_equiv (slprop_equiv_comm v1 v2); - assert (pure (v1 ** v2 == v2 ** v1)); + let _ = elim_slprop_equiv (slprop_equiv_comm (sendable v1) (sendable v2)); rewrite split_switch is b1 b2 f v1 v2 as split_switch is b2 b1 f v2 v1; @@ -342,18 +349,20 @@ fn elim_body_r1 { open Pulse.Lib.GhostReference; assert (pure (not (mem_inv is i))); - with_invariants i - { - later_elim _; + with_invariants_g unit is + i (inv_p is f v1 v2 r1 r2) + (f ** (r2 |-> Frac 0.5R false)) + (fun _ -> f ** v2) + fn _ { flip_invp is f v1 v2 r1 r2; do_elim_body_l #is #f v2 v1 r2 r1 (); flip_invp is f v2 v1 r2 r1; - later_intro (inv_p is f v1 v2 r1 r2); }; } ghost fn ghost_split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) + {| is_send v1, is_send v2 |} // requires pledge is f (v1 ** v2) // returns r : (e : inames_elem { not (mem_inv (inames_names is) (snd e)) }) // ensures pledge (add_one r is) f v1 ** pledge (add_one r is) f v2 @@ -367,6 +376,11 @@ fn ghost_split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) let r2 = GR.alloc false; GR.share r1; GR.share r2; + intro (pledge is f (sendable v1 ** sendable v2)) #(pledge is f (v1 ** v2)) fn _ { + redeem_pledge _ _ _; + sendable_intro v1 #_; + sendable_intro v2 #_; + }; fold split_switch is false false f v1 v2; fold (inv_p' is f v1 v2 r1 r2 false false); fold inv_p; @@ -401,12 +415,13 @@ fn ghost_split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) } fn split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) + {| is_send v1, is_send v2 |} requires pledge is f (v1 ** v2) returns i : iname ensures pledge (add_inv is i) f v1 ** pledge (add_inv is i) f v2 ** pure (not (mem_inv is i)) { later_credit_buy 2; - let i = ghost_split_pledge #is #f v1 v2; + let i = ghost_split_pledge #is #f v1 v2 #_ #_; i } diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fsti b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fsti index 5e62a37a8..760a8aca0 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fsti +++ b/lib/pulse/lib/pledge/Pulse.Lib.Pledge.fsti @@ -25,8 +25,10 @@ module T = FStar.Tactics val pledge (is:inames) (f:slprop) (v:slprop) : slprop +instance val is_send_pledge is f v : is_send (pledge is f v) + instance val introducable_pledge (t: Type u#a) is (is': fin_inames) - f v extra {| introducable is' (extra ** f) (f ** v) t |} : + f v extra {| is_send extra |} {| introducable is' (extra ** f) (f ** v) t |} : introducable is extra (pledge is' f v) t ghost @@ -44,7 +46,7 @@ fn pledge_sub_inv (is1:inames) (is2:fin_inames { inames_subset is1 is2 }) (f v:s (* Anything that holds now holds in the future too. *) ghost -fn return_pledge (f v:slprop) +fn return_pledge (f v:slprop) {| is_send v |} requires v ensures pledge emp_inames f v @@ -53,7 +55,7 @@ let pledge_f (#[T.exact (`emp_inames)] is: inames) (f: slprop) (#[T.exact (`emp) stt_ghost unit is (f ** extra) (fun _ -> f ** v) ghost -fn make_pledge (is:fin_inames) (f:slprop) (v:slprop) (extra:slprop) +fn make_pledge (is:fin_inames) (f:slprop) (v:slprop) (extra:slprop) {| is_send extra |} (k: unit -> pledge_f #is f #extra v) requires extra ensures pledge is f v @@ -79,7 +81,7 @@ let bind_pledge_f (#[T.exact (`emp_inames)] is) (#[T.exact (`emp_inames)] is_k: // Unclear how useful/convenient this is ghost fn bind_pledge (#is:inames) (#f:slprop) (#v1:slprop) (#v2:slprop) - (extra : slprop) + (extra : slprop) {| is_send extra |} (#is_k:inames { inames_subset is_k is }) (k:unit -> bind_pledge_f #is #is_k f #extra v1 v2) requires pledge is f v1 ** extra @@ -95,7 +97,7 @@ let bind_pledge_f' (#[T.exact (`emp_inames)] is) (#[T.exact (`emp_inames)] is_k: ghost fn bind_pledge' (#is:inames) (#f:slprop) (#v1:slprop) (#v2:slprop) - (extra : slprop) + (extra : slprop) {| is_send extra |} (#is_k:inames { inames_subset is_k is }) (k:unit -> bind_pledge_f' #is #is_k f #extra v1 v2) requires pledge is f v1 ** extra @@ -143,13 +145,13 @@ fn squash_pledge' ensures pledge is f v1 ghost -fn ghost_split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) +fn ghost_split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) {| is_send v1, is_send v2 |} requires pledge is f (v1 ** v2) ** later_credit 2 returns i : iname ensures pledge (add_inv is i) f v1 ** pledge (add_inv is i) f v2 ** pure (not (mem_inv is i)) // This is not ghost as it buys the later credits. -fn split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) +fn split_pledge (#is:inames) (#f:slprop) (v1:slprop) (v2:slprop) {| is_send v1, is_send v2 |} requires pledge is f (v1 ** v2) returns i : iname ensures pledge (add_inv is i) f v1 ** pledge (add_inv is i) f v2 ** pure (not (mem_inv is i)) diff --git a/lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fst b/lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fst new file mode 100644 index 000000000..da6c1feef --- /dev/null +++ b/lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fst @@ -0,0 +1,196 @@ +(* + Copyright 2025 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.Lib.SendableTrade +#lang-pulse + +open Pulse.Lib.Pervasives + + +let trade_elim_exists (is:inames) (hyp extra concl:slprop) (inst: is_send extra) (f: unit -> trade_f #is hyp #extra concl) : slprop = + emp + +let trade (#is:inames) (hyp concl:slprop) = + exists* extra inst f. extra ** trade_elim_exists is hyp extra concl inst f + +ghost fn is_send_trade #is (p1 p2: slprop) : is_send (trade #is p1 p2) = l l' { + ghost_impersonate l (on l (trade #is p1 p2)) (on l' (trade #is p1 p2)) fn _ { + on_elim (trade #is p1 p2); + unfold trade #is p1 p2; with extra inst f. _; + on_intro extra; + is_send_elim extra #inst l'; + ghost_impersonate l' (on l' extra ** trade_elim_exists is p1 extra p2 inst f) + (on l' (trade #is p1 p2)) fn _ { + on_elim extra; + fold trade #is p1 p2; + on_intro (trade #is p1 p2); + } + } +} + +ghost +fn intro_trade + (#[T.exact (`emp_inames)]is:inames) + (hyp concl extra:slprop) {| inst: is_send extra |} + (f_elim: unit -> trade_f #is hyp #extra concl) + requires extra + ensures trade #is hyp concl +{ + fold (trade_elim_exists is hyp extra concl inst f_elim); + assert (extra ** trade_elim_exists is hyp extra concl inst f_elim); + fold (trade #is hyp concl) +} + +fn introducable_trade_aux u#a (t: Type u#a) is is' + hyp extra concl {| is_send extra |} {| introducable is' (extra ** hyp) concl t |} (k: t) : + stt_ghost unit is extra (fun _ -> trade #is' hyp concl) = { + intro_trade #is' hyp concl extra fn _ { + intro #is' concl #(extra ** hyp) (fun _ -> k); + } +} + +instance introducable_trade (t: Type u#a) is is' + hyp extra concl {| is_send extra |} {| introducable is' (extra ** hyp) concl t |} : + introducable is extra (trade #is' hyp concl) t = + { intro_aux = introducable_trade_aux t is is' hyp extra concl } + +instance introducable_trade' (t: Type u#a) is + hyp extra concl {| is_send extra |} {| introducable emp_inames (extra ** hyp) concl t |} : + introducable is extra (hyp @==> concl) t = + { intro_aux = introducable_trade_aux t is emp_inames hyp extra concl } + +let sqeq (p : Type) (_ : squash p) : erased p = + FStar.IndefiniteDescription.elim_squash #p () + +let psquash (a:Type u#a) : prop = squash a + +ghost +fn pextract (a:Type u#5) (_:squash a) + requires emp + returns i:a + ensures emp +{ + let pf = elim_pure_explicit (psquash a); + let pf : squash a = FStar.Squash.join_squash pf; + let i = sqeq a pf; + let i = reveal i; + i +} + + + +// ghost +// fn deconstruct_trade (is:inames) (hyp concl: slprop) +// requires trade #is hyp concl +// returns res:(extra:slprop & is_send extra & trade_elim_t is hyp (reveal extra) concl) +// ensures (let (| extra, inst, _ |) = res in extra) +// { +// unfold (trade #is hyp concl); +// with extra inst. assert (extra ** trade_elim_exists is hyp extra concl inst); +// unfold (trade_elim_exists is hyp (reveal extra) concl); +// let pf : squash (psquash (trade_elim_t is hyp (reveal extra) concl)) = +// elim_pure_explicit (psquash (trade_elim_t is hyp (reveal extra) concl)); +// let pf : squash (trade_elim_t is hyp (reveal extra) concl) = +// FStar.Squash.join_squash pf; +// let f: trade_elim_t is hyp extra concl = pextract (trade_elim_t is hyp (reveal extra) concl) pf; +// ((| extra, inst, f |) <: +// (extra:slprop & is_send extra & trade_elim_t is hyp (reveal extra) concl)) +// // let res = +// // (| (extra <: erased slprop), f |) <: (p:erased slprop & trade_elim_t is hyp (reveal p) concl); +// // rewrite (reveal extra) as (reveal (dfst res)); +// // res +// } + +let call #t #is #req #ens (h: unit -> stt_ghost is t req (fun x -> ens x)) = h + +ghost +fn elim_trade + (#[T.exact (`emp_inames)]is:inames) + (hyp concl:slprop) + requires trade #is hyp concl ** hyp + ensures concl + opens is +{ + unfold trade #is hyp concl; + with extra inst f. assert trade_elim_exists is hyp extra concl inst f; + unfold trade_elim_exists is hyp extra concl inst f; + let f = f; + call f () +} + +ghost +fn trade_sub_inv + (#is1:inames) + (#is2:inames { inames_subset is1 is2 }) + (hyp concl:slprop) + requires trade #is1 hyp concl + ensures trade #is2 hyp concl +{ + intro (trade #is2 hyp concl) #(trade #is1 hyp concl) fn _ { + elim_trade #is1 hyp concl + }; +} + + +ghost +fn trade_map + (#is : inames) + (p q r : slprop) + (f : unit -> stt_ghost unit emp_inames q (fun _ -> r)) + requires trade #is p q + ensures trade #is p r +{ + intro (trade #is p r) #(trade #is p q) fn _ + { + elim_trade #is _ _; + f (); + }; +} + + +ghost +fn trade_compose + (#is : inames) + (p q r : slprop) + requires trade #is p q ** trade #is q r + ensures trade #is p r +{ + intro (trade #is p r) #(trade #is p q ** trade #is q r) fn _ + { + elim_trade #is p _; + elim_trade #is _ _; + }; +} + +ghost +fn eq_as_trade + (p1 p2 : slprop) + requires pure (p1 == p2) + ensures p2 @==> p1 +{ + intro (p2 @==> p1) fn _{ rewrite p2 as p1 } +} + +ghost +fn rewrite_with_trade + (p1 p2 : slprop) + requires p1 ** pure (p1 == p2) + ensures p2 ** (p2 @==> p1) +{ + eq_as_trade p1 p2; + rewrite p1 as p2; + (); +} diff --git a/lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fsti b/lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fsti new file mode 100644 index 000000000..eb0c17806 --- /dev/null +++ b/lib/pulse/lib/pledge/Pulse.Lib.SendableTrade.fsti @@ -0,0 +1,96 @@ +(* + Copyright 2025 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.Lib.SendableTrade +#lang-pulse + +open Pulse.Lib.Pervasives +open Pulse.Class.Introducable + +module T = FStar.Tactics + +[@@erasable] +let trade_f (#[T.exact (`emp_inames)] is: inames) (hyp: slprop) (#[T.exact (`emp)] extra: slprop) (concl: slprop) = + stt_ghost unit is (requires extra ** hyp) (ensures fun _ -> concl) + +val trade + (#[T.exact (`emp_inames)] is:inames) + ([@@@mkey] hyp:slprop) + ([@@@mkey] concl:slprop) + : slprop + +(* Specialized to no inames *) +unfold +let ( @==> ) : + (hyp:slprop) -> + (concl:slprop) -> + slprop + = trade #emp_inames + +instance val is_send_trade #is (p1 p2: slprop) : is_send (trade #is p1 p2) +instance is_send_trade' (p1 p2: slprop) : is_send (p1 @==> p2) = is_send_trade p1 p2 + +ghost +fn intro_trade + (#[T.exact (`emp_inames)]is:inames) + (hyp concl extra:slprop) {| is_send extra |} + (f_elim: unit -> trade_f #is hyp #extra concl) + requires extra + ensures trade #is hyp concl + +instance val introducable_trade (t: Type u#a) is is' + hyp extra concl {| is_send extra |} {| introducable is' (extra ** hyp) concl t |} : + introducable is extra (trade #is' hyp concl) t + +instance val introducable_trade' (t: Type u#a) is + hyp extra concl {| is_send extra |} {| introducable emp_inames (extra ** hyp) concl t |} : + introducable is extra (hyp @==> concl) t + +val elim_trade + (#[T.exact (`emp_inames)] is:inames) + (hyp concl:slprop) +: stt_ghost unit is + (trade #is hyp concl ** hyp) + (fun _ -> concl) + +ghost +fn trade_sub_inv + (#is1:inames) + (#is2:inames { inames_subset is1 is2 }) + (hyp concl:slprop) + requires trade #is1 hyp concl + ensures trade #is2 hyp concl + +ghost +fn trade_map + (#is : inames) + (p q r : slprop) + (f : unit -> stt_ghost unit emp_inames q (fun _ -> r)) + requires trade #is p q + ensures trade #is p r + +ghost +fn trade_compose + (#is : inames) + (p q r : slprop) + requires trade #is p q ** trade #is q r + ensures trade #is p r + +ghost +fn rewrite_with_trade + (p1 p2 : slprop) + requires p1 ** pure (p1 == p2) + ensures p2 ** (p2 @==> p1) \ No newline at end of file diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst index 66b065d81..92a5438cf 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst +++ b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fst @@ -184,3 +184,26 @@ fn rewrite_with_trade rewrite p1 as p2; (); } + +ghost +fn is_send_across_trade #b #g #is + (p1 p2: slprop) {| i1: is_send_across #b g p1, i2: is_send_across g p2 |} + : is_send_across g (trade #is p1 p2) = l1 l2 { + ghost_impersonate l2 (on l1 (trade #is p1 p2)) (on l2 (trade #is p1 p2)) fn _ { + loc_dup l2; + intro (trade #is p1 p2) #(on l1 (trade #is p1 p2) ** loc l2) fn _ { + on_intro p1; + i1 l2 l1; + ghost_impersonate #is l1 (on l1 p1 ** on l1 (trade #is p1 p2)) (on l1 p2) fn _ { + on_elim p1; + on_elim (trade #is p1 p2); + elim_trade #is _ _; + on_intro p2 + }; + i2 l1 l2; + on_elim p2; + drop_ (loc l2); + }; + on_intro (trade #is p1 p2); + }; +} diff --git a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti index 94ee13f06..447f246bc 100644 --- a/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti +++ b/lib/pulse/lib/pledge/Pulse.Lib.Trade.fsti @@ -99,3 +99,10 @@ fn rewrite_with_trade (p1 p2 : slprop) requires p1 ** pure (p1 == p2) ensures p2 ** (p2 @==> p1) + +instance val is_send_across_trade #b #g #is (p1 p2: slprop) {| is_send_across #b g p1, is_send_across g p2 |} : is_send_across g (trade #is p1 p2) + +instance placeless_trade #is (p1 p2: slprop) {| i1: placeless p1, i2: placeless p2 |} : placeless (trade #is p1 p2) = is_send_across_trade p1 p2 #i1 #i2 +instance placeless_trade' (p1 p2: slprop) {| placeless p1, placeless p2 |} : placeless (p1 @==> p2) = placeless_trade p1 p2 +instance is_send_trade #is (p1 p2: slprop) {| i1: is_send p1, i2: is_send p2 |} : is_send (trade #is p1 p2) = is_send_across_trade p1 p2 #i1 #i2 +instance is_send_trade' (p1 p2: slprop) {| is_send p1, is_send p2 |} : is_send (p1 @==> p2) = is_send_trade p1 p2 \ No newline at end of file diff --git a/pulse2rust/src/Pulse2Rust.Extract.fst b/pulse2rust/src/Pulse2Rust.Extract.fst index 86d167ec3..0a83889bd 100644 --- a/pulse2rust/src/Pulse2Rust.Extract.fst +++ b/pulse2rust/src/Pulse2Rust.Extract.fst @@ -456,9 +456,9 @@ let rec lb_init_and_def (g:env) (lb:S.mllb) extract_mlty g ty, extract_mlexpr g init - | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name pe}, _)}, [_; init; len]), + | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name pe}, _)}, [_; init; len; _; _]), Some ([], S.MLTY_Named ([ty], pt)) - when S.string_of_mlpath pe = "Pulse.Lib.Array.Core.mask_alloc" && + when S.string_of_mlpath pe = "Pulse.Lib.Array.Core.mask_alloc_with_vis" && S.string_of_mlpath pt = "Pulse.Lib.Array.Core.array" -> let init = extract_mlexpr g init in let len = extract_mlexpr g len in @@ -675,8 +675,8 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = let e2 = extract_mlexpr g e2 in mk_call (mk_expr_path_singl vec_new_fn) [e1; e2] - | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, [_; e1; e2]) - when S.string_of_mlpath p = "Pulse.Lib.Array.Core.mask_alloc" -> + | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, [_; e1; e2; _; _]) + when S.string_of_mlpath p = "Pulse.Lib.Array.Core.mask_alloc_with_vis" -> fail_nyi (Format.fmt1 "mlexpr %s" (S.mlexpr_to_string e)) diff --git a/share/pulse/examples/CustomSyntax.fst b/share/pulse/examples/CustomSyntax.fst index 296a5dccc..a8e315142 100644 --- a/share/pulse/examples/CustomSyntax.fst +++ b/share/pulse/examples/CustomSyntax.fst @@ -17,6 +17,7 @@ module CustomSyntax #lang-pulse open Pulse.Lib.Pervasives +open Pulse.Lib.Par module U32 = FStar.UInt32 assume val p : slprop @@ -220,18 +221,10 @@ fn test_par (r1 r2:ref U32.t) pts_to r1 1ul ** pts_to r2 1ul { - parallel - requires (pts_to r1 'n1) - and (pts_to r2 'n2) - ensures (pts_to r1 1ul) - and (pts_to r2 1ul) - { - r1 := 1ul - } - { - r2 := 1ul - }; - () + par #(requires r1 |-> 'n1) #(ensures r1 |-> 1ul) + #(requires r2 |-> 'n2) #(ensures r2 |-> 1ul) + fn _ { r1 := 1ul } + fn _ { r2 := 1ul }; } diff --git a/share/pulse/examples/Dekker.fst b/share/pulse/examples/Dekker.fst index 10bbe9e05..5e934374f 100644 --- a/share/pulse/examples/Dekker.fst +++ b/share/pulse/examples/Dekker.fst @@ -96,17 +96,12 @@ ensures (ra |-> Frac 0.5R true) ** //a is true (ga |-> Frac 0.5R b) //g is set to the return value ensures - (if b then p else emp) //and if this returns true then we have the resource p + (cond b p emp) //and if this returns true then we have the resource p { - later_credit_buy 1; - with_invariants i - returns _:unit - ensures - later (dekker_inv ra rb ga gb p) ** - (ra |-> Frac 0.5R true) ** - (ga |-> Frac 0.5R false) - { - later_elim _; + with_invariants unit emp_inames i (dekker_inv ra rb ga gb p) + (ra |-> Frac 0.5R false ** live ga #0.5R) + (fun _ -> ra |-> Frac 0.5R true ** ga |-> Frac 0.5R false) + fn _ { unfold dekker_inv; R.gather ra; write_atomic ra true; // x := true @@ -114,18 +109,18 @@ ensures GR.gather ga; GR.share ga; fold (dekker_inv ra rb ga gb p); - later_intro (dekker_inv ra rb ga gb p); }; - later_credit_buy 1; - with_invariants i - { - later_elim _; + with_invariants bool emp_inames i (dekker_inv ra rb ga gb p) + (ra |-> Frac 0.5R true ** ga |-> Frac 0.5R false) + (fun b -> (ra |-> Frac 0.5R true) ** (ga |-> Frac 0.5R b) ** + (cond b p emp)) + fn _ { unfold dekker_inv; R.gather ra; R.share ra; if (read_atomic rb) { fold (dekker_inv ra rb ga gb); - later_intro (dekker_inv _ _ _ _ _); + fold cond false p emp; false } else @@ -136,7 +131,8 @@ ensures GR.share ga; intro_cond_true emp p; fold (dekker_inv ra rb ga gb p); - later_intro (dekker_inv _ _ _ _ _); + // later_intro (dekker_inv _ _ _ _ _); + fold cond true p emp; true } }; diff --git a/share/pulse/examples/Example.StructPCM.fst b/share/pulse/examples/Example.StructPCM.fst index b8135352c..356370751 100644 --- a/share/pulse/examples/Example.StructPCM.fst +++ b/share/pulse/examples/Example.StructPCM.fst @@ -20,6 +20,7 @@ module Example.StructPCM open FStar.PCM open Pulse open Pulse.Lib.PCMReference +open Pulse.Lib.Par module G = FStar.Ghost module PCM = FStar.PCM @@ -148,13 +149,9 @@ fn upd_par #a #b (r:ref a b) (x1 x2:a) (y1 y2:b) ensures pcm_pts_to r (XY x2 y2) { share r; - parallel - requires pcm_pts_to r (X x1) and - pcm_pts_to r (Y y1) - ensures pcm_pts_to r (X x2) and - pcm_pts_to r (Y y2) - { upd_x r x1 x2 } - { upd_y r y1 y2 }; + par + (fun _ -> upd_x r x1 x2) + (fun _ -> upd_y r y1 y2); gather r } diff --git a/share/pulse/examples/Invariant.fst b/share/pulse/examples/Invariant.fst index 7c44bd21c..ede073c08 100644 --- a/share/pulse/examples/Invariant.fst +++ b/share/pulse/examples/Invariant.fst @@ -34,33 +34,23 @@ fn g (i:iname) ensures r ** inv i p opens [i] { - with_invariants i { - later_elim _; + with_invariants_a unit emp_inames i p q (fun _ -> r) fn _ { f (); - later_intro p; } } -#push-options "--fuel 0" -(* Does it work without fuel? Requires the iname_list coercion -to normalize away. *) - atomic fn g2 (i:iname) requires inv i p ** q ** later_credit 1 ensures r ** inv i p opens [i] { - with_invariants i { - later_elim _; + with_invariants_a unit emp_inames i p q (fun _ -> r) fn _ { f (); - later_intro p; } } -#pop-options - assume val f_ghost () : stt_ghost unit emp_inames (p ** q) (fun _ -> p ** r) @@ -70,10 +60,8 @@ fn g_ghost (i:iname) ensures (r ** inv i p) opens [i] { - with_invariants i { - later_elim _; + with_invariants_g unit emp_inames i p q (fun _ -> r) fn _ { f_ghost (); - later_intro p; } } @@ -116,33 +104,24 @@ fn test2 () { let r = Box.alloc #int 0; let i = new_invariant (exists* v. Box.pts_to r v); - with_invariants i - returns _:unit - ensures later (exists* v. pts_to r v) - opens [i] { - later_elim_timeless _; - atomic_write_int r 1; - later_intro (exists* v. pts_to r v); + with_invariants unit emp_inames i (exists* v. Box.pts_to r v) emp (fun _ -> emp) fn _ { + atomic_write_int r 1; }; drop_ (inv i _) } // Fails as the with_invariants block is not atomic/ghost -[@@expect_failure] +[@@expect_failure [228]] fn test3 () requires emp ensures emp { - let r = alloc #int 0; + let r = Box.alloc 0; let i = new_invariant (exists* v. pts_to r v); - with_invariants i - returns _:unit - ensures later (exists* v. pts_to r v) { - later_elim_storable _; - r := 1; - later_intro (exists* v. pts_to r v); + with_invariants unit emp_inames i (exists* v. pts_to r v) emp (fun _ -> emp) fn _ { + r := 1; }; drop_ (inv i _) } @@ -166,10 +145,11 @@ fn test3 () atomic fn t0 () (i:iname) requires inv i emp + requires later_credit 1 ensures inv i emp opens [i] { - with_invariants i { + with_invariants_a unit emp_inames i emp emp (fun _ -> emp) fn _ { () } } @@ -190,15 +170,16 @@ fn basic_ghost () (* Using invariants while claiming not to. *) -[@@expect_failure] +[@@expect_failure [19]] atomic fn t1 () + requires later_credit 1 requires inv i emp ensures inv i emp opens [] { - with_invariants i { + with_invariants_a unit emp_inames i emp emp (fun _ -> emp) fn _ { () } } @@ -208,11 +189,12 @@ fn t1 () atomic fn t3 () + requires later_credit 1 requires inv i emp ensures inv i emp opens [i; i2] { - with_invariants i { + with_invariants_a unit emp_inames i emp emp (fun _ -> emp) fn _ { () } } @@ -226,9 +208,7 @@ fn t2 () ensures emp { let j = new_invariant emp; - with_invariants j - returns _:unit - ensures later emp { + with_invariants unit emp_inames j emp emp (fun _ -> emp) fn _ { () }; drop_ (inv j _); @@ -249,16 +229,11 @@ fn test_returns0 (i:iname) (b:bool) opens [i] { unfold folded_inv i; - with_invariants i - returns _:unit - ensures later p ** q { - later_elim _; + with_invariants_a unit emp_inames i p emp (fun _ -> q) fn _ { if b { p_to_q (); - later_intro p; } else { ghost_p_to_q (); - later_intro p; } }; fold folded_inv i @@ -273,12 +248,8 @@ fn test_returns1 (i:iname) opens [i] { unfold folded_inv i; - with_invariants i - returns _:unit - ensures later p ** q { - later_elim _; + with_invariants_g unit emp_inames i p emp (fun _ -> q) fn _ { ghost_p_to_q (); - later_intro p; }; fold folded_inv i } @@ -298,12 +269,8 @@ fn test_returns2 (i:iname) opens [i] { unfold folded_inv i; - with_invariants i - returns _:unit - ensures later pp ** q { - later_elim _; + with_invariants_g unit emp_inames i p emp (fun _ -> q) fn _ { ghost_p_to_q (); - later_intro pp; }; fold folded_inv i } diff --git a/share/pulse/examples/MSort.Parallel.fst b/share/pulse/examples/MSort.Parallel.fst index 14f78a6e3..df4bfb1f3 100644 --- a/share/pulse/examples/MSort.Parallel.fst +++ b/share/pulse/examples/MSort.Parallel.fst @@ -6,6 +6,7 @@ module S = FStar.Seq module SZ = FStar.SizeT open MSort.SeqLemmas open MSort.Base +open Pulse.Lib.Par fn @@ -30,13 +31,12 @@ msort with s1. assert (pts_to_range a (SZ.v lo) (SZ.v mid) s1); with s2. assert (pts_to_range a (SZ.v mid) (SZ.v hi) s2); - parallel - requires pts_to_range a (SZ.v lo) (SZ.v mid) (reveal s1) - and pts_to_range a (SZ.v mid) (SZ.v hi) (reveal s2) - ensures pts_to_range a (SZ.v lo) (SZ.v mid) (sort (reveal s1)) - and pts_to_range a (SZ.v mid) (SZ.v hi) (sort (reveal s2)) - { msort a lo mid s1; } - { msort a mid hi s2; }; + par #(requires pts_to_range a (SZ.v lo) (SZ.v mid) (reveal s1)) + #(ensures pts_to_range a (SZ.v lo) (SZ.v mid) (sort (reveal s1))) + #(requires pts_to_range a (SZ.v mid) (SZ.v hi) (reveal s2)) + #(ensures pts_to_range a (SZ.v mid) (SZ.v hi) (sort (reveal s2))) + fn _ { msort a lo mid s1; } + fn _ { msort a mid hi s2; }; merge_impl a lo mid hi () (sort s1) (sort s2); } diff --git a/share/pulse/examples/PledgeArith.fst b/share/pulse/examples/PledgeArith.fst index 274650f19..efd2b8b0e 100644 --- a/share/pulse/examples/PledgeArith.fst +++ b/share/pulse/examples/PledgeArith.fst @@ -28,7 +28,7 @@ fn pledge_return_now (f:slprop) (r : ref int) requires pts_to r 123 ensures pledge emp_inames f (pts_to r 123) { - return_pledge f (pts_to r 123); // ideally automated + return_pledge f (pts_to r 123) #_; // ideally automated } diff --git a/share/pulse/examples/PulseCorePaper.S2.Lock.fst b/share/pulse/examples/PulseCorePaper.S2.Lock.fst index 75627db89..727c9d90f 100644 --- a/share/pulse/examples/PulseCorePaper.S2.Lock.fst +++ b/share/pulse/examples/PulseCorePaper.S2.Lock.fst @@ -61,14 +61,12 @@ fn release (#p:slprop) (l:lock) requires protects l p ** p ensures protects l p { - later_credit_buy 1; - with_invariants l.i - { - later_elim _; + with_invariants unit emp_inames l.i (lock_inv l.r p) + p (fun _ -> emp) + fn _ { with v. assert l.r |-> v; drop_ (maybe (v = 0ul) _); Pulse.Lib.Primitives.write_atomic_box l.r 0ul; - later_intro (lock_inv l.r p); } } @@ -77,27 +75,22 @@ fn rec acquire #p (l:lock) requires protects l p ensures protects l p ** p { - later_credit_buy 1; - let retry = with_invariants l.i - returns retry:bool - ensures later (lock_inv l.r p) ** (if retry then emp else p) - { - later_elim _; + let retry = + with_invariants bool emp_inames l.i (lock_inv l.r p) + emp (fun retry -> cond retry emp p) + fn _ { 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); + rewrite p as cond false emp p; false } else { - later_intro (lock_inv l.r p); + rewrite emp as cond true emp p; true } }; + unfold cond; if retry { acquire l } } diff --git a/share/pulse/examples/Quicksort.Parallel.fst b/share/pulse/examples/Quicksort.Parallel.fst index 393f22fb1..9a70afefa 100644 --- a/share/pulse/examples/Quicksort.Parallel.fst +++ b/share/pulse/examples/Quicksort.Parallel.fst @@ -18,6 +18,7 @@ module Quicksort.Parallel #lang-pulse open Pulse.Lib.Pervasives +open Pulse.Lib.Par module A = Pulse.Lib.Array open Quicksort.Base @@ -35,14 +36,13 @@ fn rec quicksort (a: A.array int) (lo: nat) (hi:(hi:nat{lo <= hi})) (lb rb: eras 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); - parallel - requires (A.pts_to_range a lo r._1 s1 ** pure (pure_pre_quicksort a lo r._1 lb pivot s1)) - and (A.pts_to_range a r._2 hi s3 ** pure (pure_pre_quicksort a r._2 hi pivot rb s3)) - ensures (exists* s. (A.pts_to_range a lo r._1 s ** pure (pure_post_quicksort a lo r._1 lb pivot s1 s))) - and (exists* s. (A.pts_to_range a r._2 hi s ** pure (pure_post_quicksort a r._2 hi pivot rb s3 s))) - { quicksort a lo r._1 lb pivot; } - { quicksort a r._2 hi pivot rb; }; - (); + par + #(requires (A.pts_to_range a lo r._1 s1 ** pure (pure_pre_quicksort a lo r._1 lb pivot s1))) + #(ensures (exists* s. (A.pts_to_range a lo r._1 s ** pure (pure_post_quicksort a lo r._1 lb pivot s1 s)))) + #(requires A.pts_to_range a r._2 hi s3 ** pure (pure_pre_quicksort a r._2 hi pivot rb s3)) + #(ensures exists* s. (A.pts_to_range a r._2 hi s ** pure (pure_post_quicksort a r._2 hi pivot rb s3 s))) + fn _ { quicksort a lo r._1 lb pivot; } + fn _ { quicksort a r._2 hi pivot rb; }; with s1'. assert (A.pts_to_range a lo r._1 s1'); with s3'. assert (A.pts_to_range a r._2 hi s3'); @@ -78,13 +78,13 @@ fn rec autostop_quicksort (a: A.array int) (lo: nat) (hi:(hi:nat{lo <= hi})) (lb /\ permutation s0 (Seq.append s1 (Seq.append s2 s3)) /\ between_bounds s2 pivot pivot) { - parallel - requires (A.pts_to_range a lo r._1 s1 ** pure (pure_pre_quicksort a lo r._1 lb pivot s1)) - and (A.pts_to_range a r._2 hi s3 ** pure (pure_pre_quicksort a r._2 hi pivot rb s3)) - ensures (exists* s. (A.pts_to_range a lo r._1 s ** pure (pure_post_quicksort a lo r._1 lb pivot s1 s))) - and (exists* s. (A.pts_to_range a r._2 hi s ** pure (pure_post_quicksort a r._2 hi pivot rb s3 s))) - { autostop_quicksort a lo r._1 lb pivot; } - { autostop_quicksort a r._2 hi pivot rb; }; + par + #(requires A.pts_to_range a lo r._1 s1 ** pure (pure_pre_quicksort a lo r._1 lb pivot s1)) + #(ensures exists* s. (A.pts_to_range a lo r._1 s ** pure (pure_post_quicksort a lo r._1 lb pivot s1 s))) + #(requires A.pts_to_range a r._2 hi s3 ** pure (pure_pre_quicksort a r._2 hi pivot rb s3)) + #(ensures exists* s. (A.pts_to_range a r._2 hi s ** pure (pure_post_quicksort a r._2 hi pivot rb s3 s))) + fn _ { autostop_quicksort a lo r._1 lb pivot; } + fn _ { autostop_quicksort a r._2 hi pivot rb; }; () } else { // else run sequentially diff --git a/share/pulse/examples/Quicksort.Task.fst b/share/pulse/examples/Quicksort.Task.fst index 4533637ca..b23958975 100644 --- a/share/pulse/examples/Quicksort.Task.fst +++ b/share/pulse/examples/Quicksort.Task.fst @@ -53,10 +53,10 @@ 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); + T.spawn_ p #(f /. 2.0R) (fun () -> t_quicksort p #(f /. 2.0R) a lo p31 #lb #pivot #s1); 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); + 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 p31 s1 lb pivot) (A.pts_to_range a p31 p32 s2); @@ -91,7 +91,7 @@ fn rec t_quicksort return_pledge (T.pool_done p) ( T.pool_alive #f p ** quicksort_post a lo hi s0 lb rb - ); + ) #_; } } diff --git a/share/pulse/examples/by-example/ParallelIncrement.fst b/share/pulse/examples/by-example/ParallelIncrement.fst index 950acfd2d..5ee7a9434 100644 --- a/share/pulse/examples/by-example/ParallelIncrement.fst +++ b/share/pulse/examples/by-example/ParallelIncrement.fst @@ -21,6 +21,7 @@ open Pulse.Lib.Pervasives module L = Pulse.Lib.SpinLock module GR = Pulse.Lib.GhostReference module R = Pulse.Lib.Reference +open Pulse.Lib.Par fn increment (#p:perm) @@ -142,17 +143,17 @@ ensures pts_to x ('i + 2) with pred. assert (L.lock_alive lock #1.0R (exists* v. pts_to x v ** pred v)); L.share lock; - parallel - requires pts_to left #0.5R 0 ** - L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v) - and pts_to right #0.5R 0 ** - L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v) - ensures pts_to left #0.5R 1 ** - L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v) - and pts_to right #0.5R 1 ** - L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v) - { increment_f2 x lock (step left true) } - { increment_f2 x lock (step right false) }; + par + #(requires pts_to left #0.5R 0 ** + L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v)) + #(ensures pts_to left #0.5R 1 ** + L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v)) + #(requires pts_to right #0.5R 0 ** + L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v)) + #(ensures pts_to right #0.5R 1 ** + L.lock_alive lock #0.5R (exists* v. pts_to x v ** pred v)) + fn _ { increment_f2 x lock (step left true) } + fn _ { increment_f2 x lock (step right false) }; L.gather lock; L.acquire lock; @@ -186,15 +187,13 @@ fn atomic_increment_f2 requires inv l (pts_to_refine x pred) ** qpred 'i ensures inv l (pts_to_refine x pred) ** qpred ('i + 1) { - later_credit_buy 1; - with_invariants l { - later_elim _; + with_invariants unit emp_inames l (pts_to_refine x pred) (qpred 'i) (fun _ -> qpred ('i + 1)) + fn _ { unfold pts_to_refine; with v. _; atomic_increment x; f v 'i; fold pts_to_refine x pred; - later_intro (pts_to_refine x pred); } } @@ -215,9 +214,12 @@ requires (pred (v + 1) ** qpred (vq + 1) ** pts_to x (v + 1))) ensures inv l (pts_to_refine x pred) ** qpred ('i + 1) { - later_credit_buy 1; - with_invariants l { - later_elim _; + with_invariants unit emp_inames l (pts_to_refine x pred) + (qpred 'i ** (forall* v vq. + (pred v ** qpred vq ** pts_to x (v + 1)) @==> + (pred (v + 1) ** qpred (vq + 1) ** pts_to x (v + 1)))) + (fun _ -> qpred ('i + 1)) + fn _ { unfold pts_to_refine; with v. _; atomic_increment x; @@ -228,7 +230,6 @@ ensures inv l (pts_to_refine x pred) ** qpred ('i + 1) (pred (v + 1) ** qpred (vq + 1) ** pts_to x (v + 1))) 'i; I.elim _ _; fold pts_to_refine x pred; - later_intro (pts_to_refine x pred); } } @@ -250,14 +251,16 @@ requires ((exists* v. pts_to x v ** pred v) @==> invp) ensures inv l invp ** qpred ('i + 1) { - later_credit_buy 1; - with_invariants l { - later_elim _; + with_invariants unit emp_inames l invp + (qpred 'i ** + (invp @==> (exists* v. pts_to x v ** pred v)) ** + ((exists* v. pts_to x v ** pred v) @==> invp)) + (fun _ -> qpred ('i + 1)) + fn _ { I.elim invp _; atomic_increment x; f _ 'i; I.elim (exists* v. pts_to x v ** pred v) invp; - later_intro invp; } } @@ -304,15 +307,12 @@ ensures inv l invp ** qpred ('i + 1) returns v:int ensures inv l invp { - later_credit_buy 1; - with_invariants l { - later_elim _; + with_invariants int emp_inames l invp emp (fun _ -> emp) fn _ { elim_inv (); with i. _; let v = atomic_read x; rewrite (pts_to x v) as (pts_to x i); intro_inv (); - later_intro invp; v } }; @@ -328,15 +328,11 @@ ensures inv l invp ** qpred ('i + 1) rewrite each (!continue) as true; // FIXME: rewrites_to goes the wrong direction? elim_cond_true _ _ _; let v = read (); - later_credit_buy 1; let next = - with_invariants l - returns b1:bool - ensures later invp - ** cond b1 (qpred 'i) (qpred ('i + 1)) - ** pts_to continue true - { - later_elim _; + with_invariants bool emp_inames l invp + (qpred 'i) + (fun b1 -> cond b1 (qpred 'i) (qpred ('i + 1))) + fn _ { elim_inv (); with vv. assert pure (vv == !x); let b = cas x v (v + 1); @@ -346,7 +342,6 @@ ensures inv l invp ** qpred ('i + 1) f vv 'i; intro_inv (); fold (cond false (qpred 'i) (qpred ('i + 1))); - later_intro invp; false } else @@ -354,7 +349,6 @@ ensures inv l invp ** qpred ('i + 1) unfold cond; intro_inv (); fold (cond true (qpred 'i) (qpred ('i + 1))); - later_intro invp; true } }; @@ -383,14 +377,14 @@ fn atomic_increment_f6 requires inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) ** qpred 'i ** C.active c p ensures inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) ** qpred ('i + 1) ** C.active c p { - later_credit_buy 1; - with_invariants (C.iname_of c) { - later_elim _; + with_invariants unit emp_inames (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) + (qpred 'i ** C.active c p) + (fun _ -> qpred ('i + 1) ** C.active c p) + fn _ { C.unpack_cinv_vp c; atomic_increment x; f _ 'i; C.pack_cinv_vp #(exists* v. pts_to x v ** pred v) c; - later_intro (C.cinv_vp c (exists* v. pts_to x v ** pred v)); } } @@ -451,21 +445,21 @@ ensures pts_to x ('i + 2) with pred. assert (inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))); dup_inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)); - parallel - requires pts_to left #0.5R 0 ** - C.active c 0.5R ** - inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) - and pts_to right #0.5R 0 ** - C.active c 0.5R ** - inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) - ensures pts_to left #0.5R 1 ** - C.active c 0.5R ** - inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) - and pts_to right #0.5R 1 ** - C.active c 0.5R ** - inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)) - { atomic_increment_f6 x c (step left true) } - { atomic_increment_f6 x c (step right false) }; + par + #(requires pts_to left #0.5R 0 ** + C.active c 0.5R ** + inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))) + #(ensures pts_to left #0.5R 1 ** + C.active c 0.5R ** + inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))) + #(requires pts_to right #0.5R 0 ** + C.active c 0.5R ** + inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))) + #(ensures pts_to right #0.5R 1 ** + C.active c 0.5R ** + inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))) + fn _ { atomic_increment_f6 x c (step left true) } + fn _ { atomic_increment_f6 x c (step right false) }; C.gather c; drop_ (inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))); diff --git a/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst b/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst index 102a3ab6d..0e17a4bab 100644 --- a/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst +++ b/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst @@ -45,20 +45,6 @@ ensures inv i (owns r) } //end create_invariant$ -//update_ref_atomic0$ -[@@expect_failure] -atomic -fn update_ref_atomic (r:ref U32.t) (i:iname) (v:U32.t) -requires inv i (owns r) -ensures inv i (owns r) -{ - with_invariants i { //later (owns r) - unfold owns; //cannot prove owns; only later (owns r) - } -} -//end update_ref_atomic0$ - - //update_ref_atomic$ atomic fn update_ref_atomic (r:ref U32.t) (i:iname) (v:U32.t) @@ -66,34 +52,16 @@ requires inv i (owns r) ** later_credit 1 ensures inv i (owns r) opens [i] { - with_invariants i { //later (owns r) ** later_credit 1 - later_elim _; //ghost step: owns r + with_invariants_a unit emp_inames i (owns r) emp (fun _ -> emp) + fn _ { // owns r unfold owns; //ghost step; exists* u. pts_to r u write_atomic r v; //atomic step; pts_to r v fold owns; //ghost step; owns r - later_intro (owns r) //ghost step: later (owns r) } // inv i (owns r) } //end update_ref_atomic$ -//update_ref_atomic_alt$ -atomic -fn update_ref_atomic_alt (r:ref U32.t) (i:iname) (v:U32.t) -requires inv i (owns r) -ensures inv i (owns r) -opens [i] -{ - with_invariants i { //later (owns r) ** later_credit 1 - later_elim_timeless _; //owns r - unfold owns; //ghost step; exists* u. pts_to r u - write_atomic r v; //atomic step; pts_to r v - fold owns; //ghost step; owns r - later_intro (owns r) //later (owns r) - } // inv i (owns r) -} -//end update_ref_atomic_alt$ - - +[@@allow_ambiguous] ghost fn pts_to_dup_impossible u#a (#a: Type u#a) (x:ref a) requires pts_to x 'v ** pts_to x 'u @@ -106,20 +74,24 @@ ensures pts_to x 'v ** pts_to x 'u ** pure False //double_open_bad$ -[@@expect_failure] -fn double_open_bad (r:ref U32.t) (i:inv (owns r)) -requires emp +[@@expect_failure [19]] +fn double_open_bad (r:ref U32.t) (i:iname) +requires inv i (owns r) ensures pure False { - with_invariants i { - with_invariants i { - unfold owns; - unfold owns; - pts_to_dup_impossible r; - fold owns; - fold owns - } - } + dup (inv i (owns r)) (); + later_credit_buy 1; + with_invariants unit emp_inames i (owns r) (inv i (owns r) ** later_credit 1) (fun _ -> pure False) fn _ { + with_invariants_a unit emp_inames i (owns r) (owns r) (fun _ -> pure False) fn _ { + unfold owns; with v. _; + unfold owns; with u. _; + pts_to_dup_impossible r; + drop_ (r |-> u); + fold owns r; + }; + rewrite inv i (owns r) as owns r; + }; + drop_ (inv i (owns r)); } //end double_open_bad$ @@ -134,12 +106,12 @@ ensures inv i (owns r) //end update_ref$ //update_ref_fail$ -[@@expect_failure] +[@@expect_failure [228]] fn update_ref_fail (r:ref U32.t) (i:iname) (v:U32.t) requires inv i (owns r) ensures inv i (owns r) { - with_invariants i { + with_invariants unit emp_inames i (owns r) emp (fun _ -> emp) fn _ { unfold owns; r := v; //not atomic fold owns; @@ -162,11 +134,11 @@ fn intro_readable (r:ref U32.t) (p:perm) (v:U32.t) ghost fn split_readable (r:ref U32.t) (i:iname) requires inv i (readable r) +requires later_credit 1 ensures inv i (readable r) ** readable r opens [i] { - with_invariants i { - later_elim_timeless _; + with_invariants_g unit emp_inames i (readable r) emp (fun _ -> readable r) fn _ { unfold readable; with p v. assert (pts_to r #p v); share r; @@ -175,7 +147,6 @@ opens [i] // fold readable; intro_readable r (p /. 2.0R) _; intro_readable r (p /. 2.0R) _; - later_intro (readable r) }; } //end split_readable$ \ No newline at end of file diff --git a/share/pulse/examples/by-example/PulseTutorial.DoubleIncrement.fst b/share/pulse/examples/by-example/PulseTutorial.DoubleIncrement.fst index 6337cda7a..6d306f5f4 100644 --- a/share/pulse/examples/by-example/PulseTutorial.DoubleIncrement.fst +++ b/share/pulse/examples/by-example/PulseTutorial.DoubleIncrement.fst @@ -37,14 +37,14 @@ requires MR.snapshot mr v0 //and the value pf m,r ensures inv i (inv_core x mr) //x and mr are still related ensures exists* v1. MR.snapshot mr v1 ** pure (v1 >= v0 + 1) //and value of mr is at least one more than it was before { - with_invariants i { //open the invariant i, so we can use it - later_elim_timeless _; //a technicality opening invariants of this type + with_invariants unit emp_inames i (inv_core x mr) (MR.snapshot mr v0) + (fun _ -> exists* v1. MR.snapshot mr v1 ** pure (v1 >= v0 + 1)) + fn _ { //open the invariant i, so we can use it MR.recall_snapshot mr; //Ghost step: this tells us that v0 <= current value of x drop_ (MR.snapshot mr v0); //we don't need the snapshot of v0 anymore let res = incr_atomic x; //to the actual increment MR.update mr res; //Ghost step: update the ghost reference to the new value MR.take_snapshot mr #1.0R res; //Take a new snapshot of the ghost reference at the current value - later_intro (inv_core x mr); //a technicality to reintroduce the invariant } } diff --git a/share/pulse/examples/by-example/PulseTutorial.Intro.fst b/share/pulse/examples/by-example/PulseTutorial.Intro.fst index f17b98060..4b2214e0b 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Intro.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Intro.fst @@ -17,22 +17,21 @@ module PulseTutorial.Intro #lang-pulse open Pulse.Lib.Pervasives +open Pulse.Lib.Par fn par (#p #q #r #s:_) + {| is_send p, is_send q, is_send r, is_send s |} (f: (unit -> stt unit p (fun _ -> q))) (g: (unit -> stt unit r (fun _ -> s))) requires p ** r ensures q ** s { - parallel - requires p and r - ensures q and s - { f () } - { g () }; - () + par #p #q #r #s + fn _ { f () } + fn _ { g () } } @@ -63,8 +62,8 @@ fn par_incr (x y:ref int) requires pts_to x 'i ** pts_to y 'j ensures pts_to x ('i + 1) ** pts_to y ('j + 1) { - par (fun _ -> incr x) - (fun _ -> incr y) + par (fun _ -> incr x #'i) + (fun _ -> incr y #'j) } //end par_incr$ diff --git a/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareable.fst b/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareable.fst index 5d54dd2b5..0d4388ceb 100644 --- a/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareable.fst +++ b/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareable.fst @@ -1,6 +1,7 @@ module PulseTutorial.MonotonicCounterShareable #lang-pulse open Pulse.Lib.Pervasives +open Pulse.Lib.Par open FStar.Preorder module MR = Pulse.Lib.MonotonicGhostRef module B = Pulse.Lib.Box @@ -19,10 +20,14 @@ inline_for_extraction let dup_f (inv: int -> slprop) = noeq type ctr = { inv: int -> slprop; + is_send_inv: (i:int -> is_send (inv i)); next: next_f inv; dup: dup_f inv; } +instance is_send_ctr_inv (c: ctr) i : is_send (c.inv i) = + c.is_send_inv i + let next c #i = c.next i let dup c #i = c.dup i let increases : preorder int = fun x y -> b2t (x <= y) @@ -44,10 +49,10 @@ ensures c.inv 0 fold (inv_core x mr); let ii = new_invariant (inv_core x mr); with inv. assert pure (inv == (fun (i: int) -> - Pulse.Lib.Core.inv ii (inv_core x mr) ** MR.snapshot mr i)); + Pulse.Lib.Inv.inv ii (inv_core x mr) ** MR.snapshot mr i)); fn next (#_:unit) : next_f inv = i { - with_invariants ii { - later_elim_timeless _; + with_invariants int emp_inames ii (inv_core x mr) (MR.snapshot mr i) + (fun j -> MR.snapshot mr j ** pure (i < j)) fn _ { unfold inv_core; let res = incr_atomic_box x; MR.recall_snapshot mr; @@ -55,7 +60,6 @@ ensures c.inv 0 drop_ (MR.snapshot mr i); MR.take_snapshot mr #1.0R res; fold (inv_core); - later_intro (inv_core x mr); res } }; @@ -64,7 +68,7 @@ ensures c.inv 0 MR.dup_snapshot mr; dup_inv ii _; }; - let c = { inv; next; dup }; + let c = { inv; next; dup; is_send_inv = (fun i -> Tactics.Typeclasses.solve) }; rewrite inv 0 as (c.inv 0); c } diff --git a/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareableFreeable.fst b/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareableFreeable.fst index 8fb789f8c..5815ea704 100644 --- a/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareableFreeable.fst +++ b/share/pulse/examples/by-example/PulseTutorial.MonotonicCounterShareableFreeable.fst @@ -2,6 +2,7 @@ module PulseTutorial.MonotonicCounterShareableFreeable #lang-pulse open Pulse.Lib.Pervasives open FStar.Preorder +open Pulse.Lib.Par module MR = Pulse.Lib.MonotonicGhostRef module B = Pulse.Lib.Box module CI = Pulse.Lib.CancellableInvariant @@ -24,12 +25,16 @@ let destroy_f (inv: perm -> int -> slprop) = i:erased int -> stt unit (inv 1.0R noeq type ctr = { inv: perm -> int -> slprop; + is_send_inv: (p:perm -> i:int -> is_send (inv p i)); next: next_f inv; share: share_f inv; gather: gather_f inv; destroy: destroy_f inv; } +instance is_send_ctr_inv (c: ctr) p i : is_send (c.inv p i) = + c.is_send_inv p i + let next c #p #i = c.next p i let share c #p #i = c.share p i let destroy c #i = c.destroy i @@ -64,12 +69,13 @@ ensures c.inv 1.0R 0 let ii = CI.new_cancellable_invariant (inv_core x mr); with inv. assert pure (inv == (fun p (i:int) -> - Pulse.Lib.Core.inv (iname_of ii) (cinv_vp ii (inv_core x mr)) ** CI.active ii p ** MR.snapshot mr i)); + Pulse.Lib.Inv.inv (iname_of ii) (cinv_vp ii (inv_core x mr)) ** CI.active ii p ** MR.snapshot mr i)); fn next (#_: unit) : next_f inv = p i { - later_credit_buy 1; - with_invariants (iname_of ii) { - later_elim _; + with_invariants int emp_inames (iname_of ii) (cinv_vp ii (inv_core x mr)) + (CI.active ii p ** MR.snapshot mr i) + (fun j -> CI.active ii p ** MR.snapshot mr j ** pure (i < j)) + fn _ { unpack_cinv_vp ii; unfold inv_core; let res = incr_atomic_box x; @@ -79,7 +85,6 @@ ensures c.inv 1.0R 0 MR.take_snapshot mr #1.0R res; fold (inv_core); pack_cinv_vp ii; - later_intro (cinv_vp ii (inv_core x mr)); res } }; @@ -95,7 +100,7 @@ ensures c.inv 1.0R 0 fn gather (#_: unit) : gather_f inv = p q i j { CI.gather #p #q ii; drop_ (MR.snapshot mr j); - drop_ (Pulse.Lib.Core.inv (iname_of ii) (cinv_vp ii (inv_core x mr))); + drop_ (Pulse.Lib.Inv.inv (iname_of ii) (cinv_vp ii (inv_core x mr))); }; fn destroy (#_: unit) : destroy_f inv = i { @@ -107,7 +112,7 @@ ensures c.inv 1.0R 0 drop_ (MR.snapshot mr _); }; - let c = { inv; next; share; gather; destroy }; + let c = { inv; next; share; gather; destroy; is_send_inv = Tactics.Typeclasses.solve }; rewrite inv 1.0R 0 as (c.inv 1.0R 0); c @@ -128,7 +133,7 @@ ensures emp { let c = new_counter (); share c; - par (do_something c #_ #_) (do_something c #_ #_); + par (do_something c #(1.0R/.2.0R) #0) (do_something c #(1.0R/.2.0R) #0); gather c; rewrite each (1.0R /. 2.0R +. 1.0R /. 2.0R) as 1.0R; destroy c diff --git a/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst b/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst index f75ebe77e..4a870b804 100644 --- a/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst +++ b/share/pulse/examples/by-example/PulseTutorial.PCMParallelIncrement.fst @@ -5,6 +5,7 @@ module MS = Pulse.Lib.PCM.MonoidShares module GPR = Pulse.Lib.GhostPCMReference module CI = Pulse.Lib.CancellableInvariant module R = Pulse.Lib.Reference +open Pulse.Lib.Par // For this example: we assume we have an atomic operation // to increment a ref nat @@ -360,17 +361,41 @@ ensures (CI.cinv_vp i (contributions n initial gs r)) opens [CI.iname_of i] //we used the invariant { - with_invariants (CI.iname_of i) - { - later_elim _; + with_invariants_a unit emp_inames (CI.iname_of i) (CI.cinv_vp i (contributions n initial gs r)) + (can_give gs 1 ** CI.active i p) + (fun _ -> has_given gs 1 ** CI.active i p) + fn _ { CI.unpack_cinv_vp i; incr_core gs r; CI.pack_cinv_vp i; - later_intro (CI.cinv_vp i (contributions n initial gs r)); } } +fn par_atomic (#is #js #pf #pg #qf #qg:_) + // {| is_send pf, is_send pg, is_send qf, is_send qg |} + (f: unit -> stt_atomic unit #Observable is pf (fun _ -> qf)) + (g: unit -> stt_atomic unit js pg (fun _ -> qg)) + requires pf ** pg + ensures qf ** qg +{ + admit (); // is_send + par #pf #qf #pg #qg + fn _ { f () } + fn _ { g () } +} +fn par_atomic_l (#is #pf #pg #qf #qg:_) + // {| is_send pf, is_send pg, is_send qf, is_send qg |} + (f: unit -> stt_atomic unit #Observable is pf (fun _ -> qf)) + (g: unit -> stt unit pg (fun _ -> qg)) + requires pf ** pg + ensures qf ** qg +{ + admit (); // is_send + par #pf #qf #pg #qg + fn _ { f () } + fn _ { g () } +} // First, a simple variant to increment a reference in parallel in two threads, // the classic Owicki-Gries example @@ -434,9 +459,9 @@ ensures (CI.cinv_vp ci (contributions capacity initial gs r)) opens [CI.iname_of ci] { - with_invariants (CI.iname_of ci) - { - later_elim _; + with_invariants_g unit emp_inames (CI.iname_of ci) (CI.cinv_vp ci (contributions capacity initial gs r)) + (CI.active ci p) (fun _ -> has_given gs 0 ** CI.active ci p) + fn _ { CI.unpack_cinv_vp ci; unfold contributions; with u. assert (owns_tank_units gs.to_give u); @@ -444,7 +469,6 @@ opens [CI.iname_of ci] fold (has_given gs 0); fold (contributions capacity initial gs r); CI.pack_cinv_vp #(contributions capacity initial gs r) ci; - later_intro (CI.cinv_vp ci (contributions capacity initial gs r)); } } diff --git a/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst b/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst index 0589e4020..2c0e85cd2 100644 --- a/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst +++ b/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst @@ -17,22 +17,19 @@ module PulseTutorial.ParallelIncrement #lang-pulse open Pulse.Lib.Pervasives +open Pulse.Lib.Par module L = Pulse.Lib.SpinLock module GR = Pulse.Lib.GhostReference //par$ fn par (#pf #pg #qf #qg:_) + {| is_send pf, is_send pg, is_send qf, is_send qg |} (f: unit -> stt unit pf (fun _ -> qf)) (g: unit -> stt unit pg (fun _ -> qg)) requires pf ** pg ensures qf ** qg { - parallel - requires pf and pg - ensures qf and qg - { f () } - { g () }; - () + par f g } //end par$ @@ -48,7 +45,7 @@ ensures pts_to x ('i + 1) ** pts_to y ('j + 1) let v = !x; x := v + 1; }; - par (fun _ -> incr x) (fun _ -> incr y); + par (fun _ -> incr x #'i) (fun _ -> incr y #'j); } @@ -74,7 +71,7 @@ fn attempt (x:ref int) requires pts_to x 'i ensures exists* v. pts_to x v { - let l = L.new_lock (exists* v. pts_to x v); + let l = L.new_lock (exists* (v: int). pts_to x v); fn incr () requires L.lock_alive l #0.5R (exists* v. pts_to x v) ensures L.lock_alive l #0.5R (exists* v. pts_to x v) @@ -166,8 +163,8 @@ ensures pts_to x ('i + 2) fold (lock_inv x 'i left right); let lock = L.new_lock (lock_inv x 'i left right); L.share lock; - par (fun _ -> incr_left x lock) - (fun _ -> incr_right x lock); + par (fun _ -> incr_left x #0.5R #left #right #'i lock #0) + (fun _ -> incr_right x #0.5R #left #right #'i lock #0); L.gather lock; L.acquire lock; L.free lock; @@ -255,8 +252,8 @@ ensures pts_to x ('i + 2) } }; L.share lock; - par (fun _ -> incr x lock (step left true)) - (fun _ -> incr x lock (step right false)); + par (fun _ -> incr x #0.5R lock (step left true) #0) + (fun _ -> incr x #0.5R lock (step right false) #0); L.gather lock; L.acquire lock; L.free lock; @@ -318,13 +315,15 @@ ensures inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) ** returns v:int ensures inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) ** C.active c p { - with_invariants (C.iname_of c) - { - later_elim _; + with_invariants_a int emp_inames (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) + (C.active c p) (fun _ -> C.active c p) fn _ { + // with_invariants (C.iname_of c) (C) + // { + // later_elim _; C.unpack_cinv_vp #p c; let v = atomic_read x; C.pack_cinv_vp #(exists* v. pts_to x v ** refine v) c; - later_intro (C.cinv_vp c (exists* v. pts_to x v ** refine v)); + // later_intro (C.cinv_vp c (exists* v. pts_to x v ** refine v)); v } }; @@ -342,16 +341,15 @@ ensures inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) ** rewrite each (!continue) as true; // FIXME: rewrites_to goes in the wrong direction later_credit_buy 1; let v = read (); - later_credit_buy 1; - let next = - with_invariants (C.iname_of c) - returns b1:bool - ensures later (C.cinv_vp c (exists* v. pts_to x v ** refine v)) - ** cond b1 (aspec 'i) (aspec ('i + 1)) + let next = + with_invariants bool emp_inames + (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) + (C.active c p ** pts_to continue true ** + cond (!continue) (aspec 'i) (aspec ('i + 1))) + (fun b1 -> cond b1 (aspec 'i) (aspec ('i + 1)) ** pts_to continue true - ** C.active c p - { - later_elim _; + ** C.active c p) + fn _ { C.unpack_cinv_vp c; unfold cond; with vv. assert x |-> vv; @@ -362,7 +360,6 @@ ensures inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) ** f vv 'i; C.pack_cinv_vp #(exists* v. pts_to x v ** refine v) c; fold (cond false (aspec 'i) (aspec ('i + 1))); - later_intro (C.cinv_vp c (exists* v. pts_to x v ** refine v)); false } else @@ -370,7 +367,6 @@ ensures inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** refine v)) ** unfold cond; C.pack_cinv_vp #(exists* v. pts_to x v ** refine v) c; fold (cond true (aspec 'i) (aspec ('i + 1))); - later_intro (C.cinv_vp c (exists* v. pts_to x v ** refine v)); true } }; @@ -430,8 +426,8 @@ ensures pts_to x ('i + 2) C.share c; with pred. assert (inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v))); dup_inv (C.iname_of c) (C.cinv_vp c (exists* v. pts_to x v ** pred v)); - par (fun _ -> incr_atomic x c (step left true)) - (fun _ -> incr_atomic x c (step right false)); + par (fun _ -> incr_atomic x #0.5R c (step left true) #0) + (fun _ -> incr_atomic x #0.5R c (step right false) #0); C.gather c; later_credit_buy 1; @@ -626,17 +622,16 @@ fn incr_pcm (r:ref int) (#n:erased int) L.share l; - parallel - requires L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** - t1_perm ghost_r 0 true and - L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** - t1_perm ghost_r 0 false - ensures L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** - t1_perm ghost_r (add_one 0) true and - L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** - t1_perm ghost_r (add_one 0) false - { incr_pcm_t r ghost_r l true } - { incr_pcm_t r ghost_r l false }; + par #(requires L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** + t1_perm ghost_r 0 true) + #(requires L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** + t1_perm ghost_r 0 false) + #(ensures L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** + t1_perm ghost_r (add_one 0) true) + #(ensures L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** + t1_perm ghost_r (add_one 0) false) + fn _ { incr_pcm_t r ghost_r l true } + fn _ { incr_pcm_t r ghost_r l false }; L.gather l; L.acquire l; @@ -731,19 +726,17 @@ fn incr_pcm_abstract (r:ref int) let l = L.new_lock (exists* v. pts_to r v ** lock_inv_ghost ghost_r v); L.share l; - parallel - requires L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** - GPR.pts_to ghost_r (half 0, None) and - L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** - GPR.pts_to ghost_r (None, half 0) - - ensures L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** - GPR.pts_to ghost_r (half (add_one 0), None) and - L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** - GPR.pts_to ghost_r (None, half (add_one 0)) - - { incr_pcm_t_abstract r l t1 } - { incr_pcm_t_abstract r l t2 }; + par + #(requires L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** + GPR.pts_to ghost_r (half 0, None)) + #(requires L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** + GPR.pts_to ghost_r (None, half 0)) + #(ensures L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** + GPR.pts_to ghost_r (half (add_one 0), None)) + #(ensures L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** + GPR.pts_to ghost_r (None, half (add_one 0))) + fn _ { incr_pcm_t_abstract r l t1 } + fn _ { incr_pcm_t_abstract r l t2 }; L.gather l; L.acquire l; diff --git a/share/pulse/examples/by-example/PulseTutorial.SpinLock.fst b/share/pulse/examples/by-example/PulseTutorial.SpinLock.fst index a71bee46f..7ed7cd42c 100644 --- a/share/pulse/examples/by-example/PulseTutorial.SpinLock.fst +++ b/share/pulse/examples/by-example/PulseTutorial.SpinLock.fst @@ -80,13 +80,9 @@ ensures lock_alive l p ** p //acquire_body$ { unfold lock_alive; - later_credit_buy 1; let b = - with_invariants l.i - returns b:bool - ensures later (lock_inv l.r p) ** maybe b p - opens [l.i] { - later_elim _; + with_invariants bool emp_inames l.i (lock_inv l.r p) + emp (fun b -> maybe b p) fn _ { unfold lock_inv; with vv. assert l.r |-> vv; let b = cas_box l.r 0ul 1ul; @@ -97,7 +93,6 @@ ensures lock_alive l p ** p fold (maybe false p); rewrite (maybe false p) as (maybe (1ul = 0ul) p); fold (lock_inv l.r p); - later_intro (lock_inv l.r p); true } else @@ -105,7 +100,6 @@ ensures lock_alive l p ** p elim_cond_false _ _ _; fold (lock_inv l.r p); fold (maybe false p); - later_intro (lock_inv l.r p); false } }; @@ -121,18 +115,12 @@ requires lock_alive l p ** p ensures lock_alive l p { unfold lock_alive; - later_credit_buy 1; - with_invariants l.i - returns _:unit - ensures later (lock_inv l.r p) - opens [l.i] { - later_elim _; + with_invariants unit emp_inames l.i (lock_inv l.r p) p (fun _ -> emp) fn _ { unfold lock_inv; write_atomic_box l.r 0ul; drop_ (maybe _ _); //maybe release without acquire fold (maybe (0ul = 0ul) p); fold (lock_inv l.r p); - later_intro (lock_inv l.r p); }; fold lock_alive } diff --git a/share/pulse/examples/parallel/ParallelFor.fst b/share/pulse/examples/parallel/ParallelFor.fst index 6ada98edb..0c7a6c25f 100644 --- a/share/pulse/examples/parallel/ParallelFor.fst +++ b/share/pulse/examples/parallel/ParallelFor.fst @@ -227,8 +227,8 @@ fn rec redeem_range fn parallel_for - (pre : (nat -> slprop)) - (post : (nat -> slprop)) + (pre : (nat -> slprop)) {| (x:nat -> is_send (pre x)) |} + (post : (nat -> slprop)) {| (x:nat -> is_send (post x)) |} (f : (i:nat -> stt unit (pre i) (fun () -> (post i)))) (n : pos) requires on_range pre 0 n @@ -280,8 +280,8 @@ spawning sequentially. *) fn parallel_for_alt - (pre : (nat -> slprop)) - (post : (nat -> slprop)) + (pre : (nat -> slprop)) {| (x:nat -> is_send (pre x)) |} + (post : (nat -> slprop)) {| (x:nat -> is_send (post x)) |} (f : (i:nat -> stt unit (pre i) (fun () -> (post i)))) (n : pos) requires on_range pre 0 n @@ -378,8 +378,8 @@ fn rec funfold fn parallel_for_wsr - (pre : (nat -> slprop)) - (post : (nat -> slprop)) + (pre : (nat -> slprop)) {| (x:nat -> is_send (pre x)) |} + (post : (nat -> slprop)) {| (x:nat -> is_send (post x)) |} (full_pre : (nat -> slprop)) (full_post : (nat -> slprop)) (f : (i:nat -> stt unit (pre i) (fun () -> post i))) @@ -407,8 +407,8 @@ val frame_stt_left fn rec h_for_task (p:pool) (e:perm) - (pre : (nat -> slprop)) - (post : (nat -> slprop)) + (pre : (nat -> slprop)) {| (x:nat -> is_send (pre x)) |} + (post : (nat -> slprop)) {| (x:nat -> is_send (post x)) |} (f : (i:nat -> stt unit (pre i) (fun () -> post i))) (lo hi : nat) (_:unit) @@ -421,7 +421,7 @@ fn rec h_for_task for_loop pre post emp (fun i -> frame_stt_left emp (f i)) lo hi; - return_pledge (pool_done p) (on_range post lo hi) + return_pledge (pool_done p) (on_range post lo hi) #_ } else { let mid = (hi+lo)/2; assert (pure (lo <= mid /\ mid <= hi)); @@ -482,8 +482,8 @@ val wait_pool fn parallel_for_hier - (pre : (nat -> slprop)) - (post : (nat -> slprop)) + (pre : (nat -> slprop)) {| (x:nat -> is_send (pre x)) |} + (post : (nat -> slprop)) {| (x:nat -> is_send (post x)) |} (f : (i:nat -> stt unit (pre i) (fun () -> (post i)))) (n : pos) requires on_range pre 0 n diff --git a/share/pulse/examples/parallel/Promises.Examples3.fst b/share/pulse/examples/parallel/Promises.Examples3.fst index 83d0b02cc..578683135 100644 --- a/share/pulse/examples/parallel/Promises.Examples3.fst +++ b/share/pulse/examples/parallel/Promises.Examples3.fst @@ -35,6 +35,11 @@ let inv_p : timeless_slprop = ** pure (v_claimed ==> v_done) ** pure (v_done ==> Some? v_res) +instance is_send_if a b c {| ib: is_send b, ic: is_send c |} : is_send (if a then b else c) = + if a then ib else ic + +instance is_send_inv_p : is_send inv_p = Tactics.Typeclasses.solve + (* Explicit introduction for inv_p, sometimes needed to disambiguate. *) ghost @@ -61,15 +66,18 @@ let goal : slprop = -atomic +ghost fn proof (i : iname) (_:unit) requires inv i inv_p ** pts_to done #0.5R true ** pts_to claimed #0.5R false + requires later_credit 1 ensures inv i inv_p ** pts_to done #0.5R true ** goal opens [i] { - with_invariants i { - later_elim_timeless _; + with_invariants_g unit emp_inames i inv_p + (pts_to done #0.5R true ** pts_to claimed #0.5R false) + (fun _ -> pts_to done #0.5R true ** goal) + fn _ { unfold inv_p; with (v_done : bool) v_res (v_claimed : bool). assert (pts_to done #0.5R v_done @@ -116,8 +124,6 @@ fn proof drop_ (pts_to claimed #0.5R true); - later_intro inv_p; - () } } @@ -146,24 +152,25 @@ fn setup (_:unit) fold inv_p; let i = new_invariant inv_p; + later_credit_buy 1; intro (pledge (add_inv emp_inames i) (pts_to done #0.5R true) goal) - #(inv i inv_p ** pts_to claimed #0.5R false) fn _ { - //cheating: (proof i) is atomic, not ghost - admit() + #(inv i inv_p ** pts_to claimed #0.5R false ** later_credit 1) + fn _ { + proof i (); + drop_ (inv i inv_p); }; i } - -[@@expect_failure] // block is not atomic/ghost +let pretend_atomic pre post (k: unit -> stt unit pre (fun _ -> post)) = + as_atomic pre _ (k ()) fn worker (i : iname) (_:unit) requires inv i inv_p ** pts_to done #0.5R false ensures inv i inv_p ** pts_to done #0.5R true { - with_invariants i { - later_elim_storable _; + with_invariants unit emp_inames i inv_p (pts_to done #0.5R false) (fun _ -> pts_to done #0.5R true) fn _ { unfold inv_p; with v_done v_res v_claimed. assert (pts_to done #0.5R v_done @@ -194,8 +201,10 @@ fn worker (i : iname) (_:unit) to not have a lock for this. It would be two with_invariant steps. *) - res := Some 42; - done := true; + pretend_atomic (live res ** live done) (res |-> Some 42 ** done |-> true) fn _ { + res := Some 42; + done := true; + }; share #_ res; diff --git a/share/pulse/examples/parallel/TaskPool.Examples.fst b/share/pulse/examples/parallel/TaskPool.Examples.fst index eaa49d659..3cdb0a3ca 100644 --- a/share/pulse/examples/parallel/TaskPool.Examples.fst +++ b/share/pulse/examples/parallel/TaskPool.Examples.fst @@ -23,6 +23,9 @@ open Pulse.Lib.Task assume val qsv : nat -> slprop +[@@Tactics.Typeclasses.tcinstance] +assume +val is_send_qsv n : is_send (qsv n) assume val qsc : n:nat -> stt unit emp (fun _ -> qsv n) @@ -111,7 +114,6 @@ fn qs12_par (#e:perm) (p:pool) () } - fn qsh_par (n:nat) requires emp returns _:unit @@ -119,7 +121,7 @@ fn qsh_par (n:nat) { let p = setup_pool 42; share_alive p _; - spawn_ p (fun () -> qs12_par p); + spawn_ p (fun () -> qs12_par #(1.0R/.2.0R) p); spawn_ p (fun () -> qsc 3); spawn_ p (fun () -> qsc 4); join_pledge #emp_inames #(pool_done p) (qsv 3) (qsv 4); diff --git a/src/checker/Pulse.Checker.Par.fst b/src/checker/Pulse.Checker.Par.fst deleted file mode 100644 index db45c806c..000000000 --- a/src/checker/Pulse.Checker.Par.fst +++ /dev/null @@ -1,66 +0,0 @@ -(* - 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.Par - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Checker.Pure -open Pulse.Checker.Base -open Pulse.Checker.Prover -open Pulse.Checker.Comp - -module T = FStar.Tactics.V2 -module MT = Pulse.Typing.Metatheory - -#push-options "--z3rlimit_factor 4 --split_queries no" -let check - (g:env) - (pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (post_hint:post_hint_opt g) - (res_ppname:ppname) - (t:st_term{Tm_Par? t.term}) - (check:check_t) -: T.Tac (checker_result_t g pre post_hint) -= let g = push_context "check_par" t.range g in - let Tm_Par {pre1=preL; body1=eL; post1=postL; - pre2=preR; body2=eR; post2=postR} = t.term in - let (| preL, preL_typing |) = check_tot_term g preL tm_slprop in - let (| preR, preR_typing |) = check_tot_term g preR tm_slprop in - - let postL_hint = intro_post_hint g EffectAnnotSTT None postL in - let (| eL, cL, eL_typing |) = - let ppname = mk_ppname_no_range "_par_l" in - let r = check g preL preL_typing (PostHint postL_hint) ppname eL in - apply_checker_result_k r ppname - in - let cL_typing = MT.st_typing_correctness eL_typing in - - let postR_hint = intro_post_hint g EffectAnnotSTT None postR in - let (| eR, cR, eR_typing |) = - let ppname = mk_ppname_no_range "_par_r" in - let r = check g preR preR_typing (PostHint postR_hint) ppname eR in - apply_checker_result_k r ppname - in - let cR_typing = MT.st_typing_correctness eR_typing in - - let x = fresh g in - assume (comp_u cL == comp_u cR); - let d = T_Par _ _ _ _ _ x cL_typing cR_typing eL_typing eR_typing in - let (|_,d|) = match_comp_res_with_post_hint d post_hint in - prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) post_hint t.range -#pop-options diff --git a/src/checker/Pulse.Checker.WithInv.fst b/src/checker/Pulse.Checker.WithInv.fst deleted file mode 100644 index 4a7692beb..000000000 --- a/src/checker/Pulse.Checker.WithInv.fst +++ /dev/null @@ -1,513 +0,0 @@ -(* - 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.WithInv - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Checker.Pure -open Pulse.Checker.Base -open Pulse.Checker.Prover.Normalize -open Pulse.Checker.Comp -open Pulse.Show -open FStar.Pprint -open Pulse.PP - -module T = FStar.Tactics.V2 -module RT = FStar.Reflection.Typing - -let rt_recheck (gg:env) (#g:T.env) (#e:T.term) (#ty: T.typ) () : T.Tac (RT.tot_typing g e ty) = - match T.core_check_term g e ty T.E_Total with - | Some tok, _ -> RT.T_Token _ _ _ () - | None, _ -> T.fail "Checker.WithInv: rt_recheck failed" // fixme add a range - -let recheck (#g:env) (#e:term) (#ty: typ) () : T.Tac (tot_typing g e ty) = - core_check_tot_term g e ty - -let remove_iname (inames i:term) -: term -= wr - (Pulse.Reflection.Util.remove_inv_tm - inames - i) - (Pulse.RuntimeUtils.range_of_term inames) - -let add_iname (inames i:term) -: term -= wr - (tm_add_inv inames i) - (Pulse.RuntimeUtils.range_of_term inames) - -module RU = Pulse.RuntimeUtils -let all_inames = - wr Pulse.Syntax.Pure.tm_all_inames FStar.Range.range_0 -let all_inames_typing (g:env) -: tot_typing g all_inames tm_inames -= RU.magic() - -let remove_iname_typing - (g:env) (#inames #i:term) - (_:tot_typing g inames tm_inames) - (_:tot_typing g i tm_iname) -: tot_typing g (remove_iname inames i) tm_inames -= RU.magic() - -let add_iname_typing - (g:env) (#inames #i:term) - (_:tot_typing g inames tm_inames) - (_:tot_typing g i tm_iname) -: tot_typing g (add_iname inames i) tm_inames -= RU.magic() - -let tm_inames_subset_typing - (g:env) (#i #j:term) - (_:tot_typing g i tm_inames) - (_:tot_typing g j tm_inames) -: tot_typing g (tm_inames_subset i j) tm_prop -= RU.magic() - -let disjointness_remove_i_i (g:env) (inames i:term) -: T.Tac (Pulse.Typing.prop_validity g (inv_disjointness (remove_iname inames i) i)) -= RU.magic() - -let add_remove_inverse (g:env) - (inames i:term) - (inames_typing:tot_typing g inames tm_inames) - (i_typing:tot_typing g i tm_iname) -: T.Tac - (prop_validity g (tm_inames_subset (add_iname (remove_iname inames i) i) inames)) -= let typing - : tot_typing g - (tm_inames_subset - (add_iname - (remove_iname inames i) - i) - inames) - tm_prop - = let remove_typing = remove_iname_typing g inames_typing i_typing in - let add_typing = add_iname_typing g remove_typing i_typing in - tm_inames_subset_typing g - add_typing - inames_typing - in - match Pulse.Checker.Pure.try_check_prop_validity g _ typing with - | None -> - fail_doc g None [ - text "Failed to prove that only the following invariants are opened"; - prefix 4 1 (text "Inferred the following invariants were opened: ") - (pp (add_iname - (remove_iname inames i) - i)) ^/^ - prefix 4 1 (text "But expected to only open: ") (pp inames) - ] - - | Some tok -> tok - -// -// Find i -~- p in pre, where pre is well-typed -// -let rec find_inv (#g:env) (#pre:term) (pre_typing :tot_typing g pre tm_slprop) (i:term) - : T.Tac (option (p:term & - frame:term & - tot_typing g (tm_inv i p) tm_slprop & - tot_typing g frame tm_slprop & - slprop_equiv g (tm_star (tm_inv i p) frame) pre)) = - - match inspect_term pre with - | Tm_Inv i' p -> - if eq_tm i i' - then let frame = tm_emp in - let tm_inv_typing = magic () in - let frame_typing = magic () in - let d_eq = magic () in - Some (| p, frame, tm_inv_typing, frame_typing, d_eq |) - else None - - | Tm_Star l r -> begin - match find_inv #g #l (magic ()) i with - | Some res -> - let (| p, frame, _, _, _ |) = res in - Some (| p, tm_star frame r, magic (), magic (), magic () |) - | None -> - match find_inv #g #r (magic ()) i with - | Some res -> - let (| p, frame, _, _, _ |) = res in - Some (| p, tm_star l frame, magic (), magic (), magic () |) - | _ -> None - end - - | _ -> None - -let find_inv_post (#g:env) (x:var { lookup g x == None}) - (u:universe) - (ret_ty:term) - (post:term) - (ret_ty_typing:universe_of g ret_ty u) - (post_typing:tot_typing (push_binding g x ppname_default ret_ty) (open_term post x) tm_slprop) - (i:term) - - : T.Tac (option (p:term & - frame:term & - tot_typing g (tm_inv i p) tm_slprop & - tot_typing (push_binding g x ppname_default ret_ty) (open_term frame x) tm_slprop & - slprop_equiv (push_binding g x ppname_default ret_ty) - (tm_star (tm_inv i p) (open_term frame x)) - (open_term post x))) = - - let post_opened = open_term_nv post (ppname_default, x) in - let (| post_opened, post_equiv, post_typing |) = - normalize_slprop_welltyped (push_binding g x ppname_default ret_ty) post_opened post_typing - in - let res = find_inv post_typing i in - match res with - | None -> None - | Some (| p, frame, inv_typing, frame_typing, d_eq |) -> - let frame_typing : tot_typing _ frame tm_slprop = frame_typing in - assume (open_term (close_term frame x) x == frame); - let tm_inv_typing : tot_typing g (tm_inv i p) tm_slprop = recheck () in - Some (| p, close_term frame x, tm_inv_typing, frame_typing, VE_Trans _ _ _ _ d_eq (VE_Sym _ _ _ post_equiv) |) - -let atomic_or_ghost_with_inames_and_pre_post - (c:comp { C_STAtomic? c \/ C_STGhost? c}) - (inames pre post:term) = - match c with - | C_STAtomic _ obs s -> - C_STAtomic inames obs { s with pre; post } - | C_STGhost _ s -> - C_STGhost inames { s with pre; post } - -// -// Given a post that may have a later p in it, -// the function transforms it into inv i p ** -// -// As with find_inv, it is doing structural matching for now -// -// The function also needs to return typing of the transformed postcondition -// Should be easy to construct structurally, given that we have post typing -// and i typing in hand -// -let rec __withinv_post (#g:env) (#p:term) (#i:term) (#post:term) - (p_typing:tot_typing g p tm_slprop) - (i_typing:tot_typing g i tm_iname) - (post_typing:tot_typing g post tm_slprop) - - : T.Tac (option (post':term & - tot_typing g post' tm_slprop)) = - - if eq_tm post (tm_later p) - then Some (| tm_inv i p, magic () |) // i:iname, p:slprop, get typing of inv i p - else match inspect_term post with - | Tm_Star l r -> - let res = __withinv_post #g #p #i #l p_typing i_typing (RU.magic ()) in - begin - match res with - | Some (| l', _ |) -> Some (| tm_star l' r, magic () |) - | None -> - begin - let res = __withinv_post #g #p #i #r p_typing i_typing (magic ()) in - match res with - | Some (| r', _ |) -> Some (| tm_star l r', magic () |) - | None -> None - end - end - | _ -> None - -let withinv_post (#g:env) (#p:term) (#i:term) (#post:term) - (p_typing:tot_typing g p tm_slprop) - (i_typing:tot_typing g i tm_iname) - (post_typing:tot_typing g post tm_slprop) - - : T.Tac (option (post':term & - tot_typing g post' tm_slprop)) = - let (| p, _, p_typing |) = normalize_slprop_welltyped g p p_typing in - let (| post, _, post_typing |) = normalize_slprop_welltyped g post post_typing in - __withinv_post #g #p #i #post p_typing i_typing post_typing - -#push-options "--fuel 0 --ifuel 0" -#restart-solver -let mk_post_hint g returns_inv i p (ph:post_hint_opt g) rng -: T.Tac (q:post_hint_for_env g { PostHint? ph ==> q == PostHint?.v ph }) -= // - // post_hint for the with_invariants block - // - let post_hint : (q:post_hint_for_env g { PostHint? ph ==> q == PostHint?.v ph }) = - match returns_inv, ph with - | None, PostHint post -> post - | Some (_, post, _), PostHint q -> - fail_doc g (Some rng) - [ doc_of_string "Fatal: multiple annotated postconditions on with_invariant"; - prefix 4 1 (text "First postcondition:") (pp post); - prefix 4 1 (text "Second postcondition:") (pp q) ] - | Some (b, post, opens), _ -> - // - // The with_invariants block is annotated with an ensures - // For something like inv i p, the ensures only has p in it - // So get inside and change that p to inv i p - // - // First typecheck the annotated ensures - // - let post_hint = Pulse.Checker.Base.intro_post_hint g - (EffectAnnotAtomicOrGhost { opens }) - (Some b.binder_ty) - post in - begin - let x = fresh g in - assume (x == Ghost.reveal post_hint.x); - let g_x = push_binding g x ppname_default post_hint.ret_ty in - let res = withinv_post - #g_x - #p #i #(open_term_nv post_hint.post (v_as_nv x)) - (RU.magic ()) // weakening of p typing - (RU.magic ()) // weakening of i typing - post_hint.post_typing_src - in - match res with - | None -> - fail_doc g (Some (FStar.Reflection.range_of_term post)) [ - prefix 2 1 (text "Cannot find invariant") - (pp (tm_later p)) ^/^ - text "in the with_invariants annotated postcondition." - ] - | Some (| post', post'_typing |) -> - let post'_closed = close_term post' x in - assume (open_term (post'_closed) x == post'); - assume (freevars post_hint.post == freevars post'); - { post_hint with - post = post'_closed; - post_typing_src = post'_typing; - post_typing = post_typing_as_abstraction #_ #x #_ #post'_closed post'_typing } - end - | _, _ -> - fail g (Some rng) "Fatal: no post hint on with_invariant" - in - post_hint - -#push-options "--z3rlimit_factor 25 --split_queries no" -#restart-solver -let check0 - (g:env) - (pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (post_hint:post_hint_opt g) - (res_ppname:ppname) - (t:st_term{Tm_WithInv? t.term}) - (check:check_t) -: T.Tac (checker_result_t g pre post_hint) -= let Tm_WithInv {name=i; returns_inv; body} = t.term in - let (| i, _ |) = check_tot_term g i tm_iname in - let i_range = Pulse.RuntimeUtils.range_of_term i in - let res = find_inv pre_typing i in - if None? res then - fail_doc g (Some i_range) [ - prefix 2 1 (text "Cannot find invariant resource for iname ") (pp i) ^/^ - prefix 2 1 (text " in the precondition ") (pp pre) - ]; - - let Some (| p, pre_frame, _, pre_frame_typing, d_pre_frame_eq |) = res in - - let post_hint = mk_post_hint g returns_inv i p post_hint t.range in - - (* Checking the body seems to change its range, so store the original one - for better errors. *) - let body_range = body.range in - - let pre_body : slprop = tm_star (tm_later p) pre_frame in - // - // we know tm_inv i p is well-typed, - // so p is well-typed - // and frame is well-typed - // therefore tm_star is well-typed - // - let pre_body_typing : tot_typing g pre_body tm_slprop = RU.magic () in - - let x = fresh g in - assume (fresh_wrt x g (freevars post_hint.post)); - let g' = (push_binding g x ppname_default post_hint.ret_ty) in - let post_hint_ret_ty_typing - : universe_of g post_hint.ret_ty post_hint.u = recheck () in - let post_hint_post_typing - : tot_typing g' - (open_term_nv post_hint.post (ppname_default, x)) - tm_slprop - = recheck () - in - - let res = find_inv_post #g - x - post_hint.u - post_hint.ret_ty - post_hint.post - post_hint_ret_ty_typing - post_hint_post_typing - i in - - if None? res then - fail_doc g (Some i_range) [ - prefix 2 1 (text "Cannot find invariant resource for iname ") (pp i) ^/^ - prefix 2 1 (text " in the postcondition ") (pp post_hint.post) - ]; - - - let Some (| p', post_frame, _, post_frame_typing, d_post_frame_equiv |) = res in - if not (eq_tm p p') - then fail g (Some i_range) - (FStar.Printf.sprintf "Inconsistent slprops for iname %s in pre (%s) and post (%s)" - (show i) (show p) (show p')); - assert (p == p'); - let post_body = tm_star (tm_later p) post_frame in - allow_invert post_hint.effect_annot; - let (| opens, opens_typing |) - : t:term & tot_typing g t tm_inames - = match post_hint.effect_annot with - | EffectAnnotSTT -> - (| all_inames, all_inames_typing g |) - | EffectAnnotGhost { opens } - | EffectAnnotAtomic { opens } - | EffectAnnotAtomicOrGhost { opens } -> - (| opens, (post_hint_typing g post_hint x).effect_annot_typing |) - in - let opens_remove_i = remove_iname opens i in - let effect_annot = - match post_hint.effect_annot with - | EffectAnnotSTT - | EffectAnnotAtomic _ -> - EffectAnnotAtomic { opens=opens_remove_i } - | EffectAnnotGhost _ -> - EffectAnnotGhost { opens=opens_remove_i } - | EffectAnnotAtomicOrGhost _ -> - EffectAnnotAtomicOrGhost { opens=opens_remove_i } in - let effect_annot_typing - : effect_annot_typing g effect_annot - = remove_iname_typing g #opens #i opens_typing (RU.magic ()) // from inversion of tm_inv_typing - in - - assume (fresh_wrt x g (freevars post_body)); - let post_hint_body : post_hint_for_env g = { post_hint with - effect_annot; - effect_annot_typing; - g; - ty_typing = post_hint_ret_ty_typing; - post = post_body; - x; - post_typing_src=RU.magic (); - post_typing=RU.magic (); - } in - - let (| body, c_body, body_typing |) = - let ppname = mk_ppname_no_range "with_inv_body" in - let r = check g pre_body pre_body_typing (PostHint post_hint_body) ppname body in - apply_checker_result_k r ppname - in - - assert (comp_inames c_body == opens_remove_i); - assert (comp_pre c_body == tm_star (tm_later p) pre_frame); - assert (comp_post c_body == tm_star (tm_later p) post_frame); - - let c_out = atomic_or_ghost_with_inames_and_pre_post c_body - (tm_add_inv (comp_inames c_body) i) - pre - post_hint.post in - - let tok = disjointness_remove_i_i g opens i in - - let tm = wtag (Some (ctag_of_comp_st c_out)) (Tm_WithInv {name=i;body;returns_inv=None}) in - let d : st_typing _ tm c_out = - let c = atomic_or_ghost_with_inames_and_pre_post - c_body - (comp_inames c_body) - pre_frame - post_frame in - let c_out_eq = atomic_or_ghost_with_inames_and_pre_post - c_body - (tm_add_inv (comp_inames c_body) i) - (tm_star (tm_inv i p) pre_frame) - (tm_star (tm_inv i p) post_frame) in - - assert (add_frame_later_l c p == c_body); - assert (comp_with_inv c i p == c_out_eq); - let d : st_typing _ _ c_out_eq = - T_WithInv _ i p _ c (RU.magic ()) (RU.magic ()) body_typing tok in - let d_pre_eq : slprop_equiv g (comp_pre c_out_eq) (comp_pre c_out) = d_pre_frame_eq in - let d_post_eq : slprop_equiv (push_binding g x ppname_default post_hint.ret_ty) - (tm_star (tm_inv i p) (open_term post_frame x)) - (open_term post_hint.post x) = d_post_frame_equiv in - assume (open_term (tm_inv i p) x == tm_inv i p); - assert (comp_post c_out_eq == tm_star (tm_inv i p) post_frame); - assume (open_term (comp_post c_out_eq) x == - tm_star (tm_inv i p) (open_term post_frame x)); - let d_post_eq : slprop_equiv (push_binding g x ppname_default post_hint.ret_ty) - (open_term (comp_post c_out_eq) x) - (open_term (comp_post c_out) x) = d_post_eq in - assert (comp_res c_out_eq == comp_res c_out); - assume (~ (x `Set.mem` freevars (comp_post c_out_eq))); - assume (~ (x `Set.mem` freevars (comp_post c_out))); - let d_st_equiv : st_equiv _ c_out_eq c_out = - ST_SLPropEquiv _ c_out_eq c_out x (RU.magic ()) - (RU.magic ()) - (RU.magic ()) - (RT.Rel_refl _ _ RT.R_Eq) - d_pre_eq - d_post_eq in - let d : st_typing _ _ c_out = Pulse.Typing.Combinators.t_equiv d d_st_equiv in - d - in - match post_hint.effect_annot with - | EffectAnnotGhost _ - | EffectAnnotAtomic _ - | EffectAnnotAtomicOrGhost _ -> - let tok : prop_validity g (tm_inames_subset (comp_inames c_out) opens) = - add_remove_inverse g opens i opens_typing (RU.magic ()) - in - let (| c_out_opens, d_sub_c |) : (c_out_opens:comp & st_sub _ c_out c_out_opens) = - match c_out with - | C_STAtomic add_inv obs st -> - (| C_STAtomic opens obs st, - STS_AtomicInvs _ st add_inv opens obs obs tok |) - | C_STGhost add_inv st -> - (| C_STGhost opens st, - STS_GhostInvs _ st add_inv opens tok |) in - let d : st_typing _ _ c_out_opens = T_Sub _ _ _ _ d d_sub_c in - checker_result_for_st_typing (| _, _, d |) res_ppname - - | EffectAnnotSTT -> - let d = T_Lift _ _ _ _ d (Lift_STAtomic_ST _ c_out) in - checker_result_for_st_typing (| _, _, d |) res_ppname -#pop-options - -(* Would be good to generalize this and expose it elsewhere. *) -let norm_and_check - (g:env) - (pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (post_hint:post_hint_opt g) - (res_ppname:ppname) - (t:st_term{Tm_WithInv? t.term}) - (check:check_t) -: T.Tac (checker_result_t g pre post_hint) -= let (| pre', pre_equiv, pre'_typing |) = normalize_slprop_welltyped g pre pre_typing in - let r = check0 g pre' pre'_typing post_hint res_ppname t check in - checker_result_t_equiv_ctxt _ _ _ _ (VE_Sym _ _ _ pre_equiv) r - -let check - (g:env) - (pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (post_hint:post_hint_opt g) - (res_ppname:ppname) - (t:st_term{Tm_WithInv? t.term}) - (check:check_t) -: T.Tac (checker_result_t g pre post_hint) -= norm_and_check g pre pre_typing post_hint res_ppname t check diff --git a/src/checker/Pulse.Checker.fst b/src/checker/Pulse.Checker.fst index 7f0dc29a8..e698846f5 100644 --- a/src/checker/Pulse.Checker.fst +++ b/src/checker/Pulse.Checker.fst @@ -40,11 +40,9 @@ module WithLocal = Pulse.Checker.WithLocal module WithLocalArray = Pulse.Checker.WithLocalArray module While = Pulse.Checker.While module Exists = Pulse.Checker.Exists -module Par = Pulse.Checker.Par module Admit = Pulse.Checker.Admit module Return = Pulse.Checker.Return module Rewrite = Pulse.Checker.Rewrite -module WithInv = Pulse.Checker.WithInv module PCP = Pulse.Checker.Pure let terms_to_string (t:list term) @@ -390,9 +388,6 @@ let rec check | Tm_WithLocalArray _ -> WithLocalArray.check g pre pre_typing post_hint res_ppname t check - | Tm_Par _ -> - Par.check g pre pre_typing post_hint res_ppname t check - | Tm_IntroPure _ -> Pulse.Checker.IntroPure.check g pre pre_typing post_hint res_ppname t @@ -405,9 +400,6 @@ let rec check | Tm_Rewrite _ -> Rewrite.check g pre pre_typing post_hint res_ppname t - | Tm_WithInv _ -> - WithInv.check g pre pre_typing post_hint res_ppname t check - | Tm_PragmaWithOptions { options; body } -> RU.push_options(); RU.set_options options; diff --git a/src/checker/Pulse.Elaborate.Core.fst b/src/checker/Pulse.Elaborate.Core.fst index 76f00922a..8aad7705c 100644 --- a/src/checker/Pulse.Elaborate.Core.fst +++ b/src/checker/Pulse.Elaborate.Core.fst @@ -258,25 +258,6 @@ let rec elab_st_typing (#g:env) let body = elab_st_typing body_typing in mk_nu_while inv (mk_abs bool_tm R.Q_Explicit post) cond body - | T_Par _ eL cL eR cR _ _ _ eL_typing eR_typing -> - let ru = comp_u cL in - let raL = comp_res cL in - let raR = comp_res cR in - let rpreL = comp_pre cL in - let rpostL = comp_post cL in - let rpreR = comp_pre cR in - let rpostR = comp_post cR in - let reL = elab_st_typing eL_typing in - let reR = elab_st_typing eR_typing in - mk_par ru - raL - raR - rpreL - (mk_abs raL R.Q_Explicit rpostL) - rpreR - (mk_abs raR R.Q_Explicit rpostR) - reL reR - | T_Rewrite _ p q _ _ -> mk_rewrite p q @@ -311,9 +292,6 @@ let rec elab_st_typing (#g:env) | T_Unreachable .. -> `("IOU: elab_st_typing of T_Unreachable") - | T_WithInv .. -> - `("IOU: elab_st_typing of T_WithInv") - and elab_br (#g:env) (#c:comp_st) (#sc_u:universe) (#sc_ty:typ) (#sc:term) diff --git a/src/checker/Pulse.Extract.Main.fst b/src/checker/Pulse.Extract.Main.fst index 98b8794af..ab1c1e8c1 100644 --- a/src/checker/Pulse.Extract.Main.fst +++ b/src/checker/Pulse.Extract.Main.fst @@ -216,18 +216,12 @@ let rec simplify_st_term (g:env) (e:st_term) : T.Tac st_term = let body = simplify_st_term g body in { e with term = Tm_NuWhile { invariant; condition; body } } - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - let body1 = simplify_st_term g body1 in - let body2 = simplify_st_term g body2 in - { e with term = Tm_Par { pre1; body1; post1; pre2; body2; post2 } } - | Tm_WithLocal { binder; initializer; body } -> ret (Tm_WithLocal { binder; initializer; body = with_open binder body }) | Tm_WithLocalArray { binder; initializer; length; body } -> ret (Tm_WithLocalArray { binder; initializer; length; body = with_open binder body }) - | Tm_WithInv {body} | Tm_PragmaWithOptions { body } -> simplify_st_term g body @@ -311,11 +305,6 @@ let rec erase_ghost_subterms (g:env) (p:st_term) : T.Tac st_term = let body = erase_ghost_subterms g body in ret (Tm_NuWhile { invariant; condition; body }) - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - let body1 = erase_ghost_subterms g body1 in - let body2 = erase_ghost_subterms g body2 in - ret (Tm_Par { pre1; body1; post1; pre2; body2; post2 }) - | Tm_WithLocal { binder; initializer; body } -> let body = open_erase_close g binder body in ret (Tm_WithLocal { binder; initializer; body }) @@ -331,9 +320,6 @@ let rec erase_ghost_subterms (g:env) (p:st_term) : T.Tac st_term = | Tm_ProofHintWithBinders _ -> T.fail "erase_ghost_subterms: Unexpected constructor: ProofHintWithBinders should have been desugared away" - | Tm_WithInv { name; body; returns_inv } -> - ret (Tm_WithInv { name; body = erase_ghost_subterms g body; returns_inv }) - | Tm_PragmaWithOptions { options; body } -> ret (Tm_PragmaWithOptions { options; body=erase_ghost_subterms g body }) @@ -478,14 +464,6 @@ let rec extract_dv g (p:st_term) : T.Tac R.term = [mk_abs (unit_binder "while_cond") condition, R.Q_Explicit; mk_abs (unit_binder "while_body") body, R.Q_Explicit]) - | Tm_Par { body1; body2 } -> - let body1 = extract_dv g body1 in - let body2 = extract_dv g body2 in - ECL.mk_meta_monadic - (R.mk_app (R.pack_ln (R.Tv_FVar (R.pack_fv ["Pulse"; "Lib"; "Dv"; "par"]))) - [mk_abs (unit_binder "par_b1") body1, R.Q_Explicit; - mk_abs (unit_binder "par_b2") body2, R.Q_Explicit]) - | Tm_WithLocal { binder; initializer; body } -> let b' = extract_dv_binder binder None in let allocator = R.mk_app (R.pack_ln (R.Tv_UInst (R.pack_fv ["Pulse"; "Lib"; "Reference"; "alloc"]) [u0])) @@ -516,7 +494,6 @@ let rec extract_dv g (p:st_term) : T.Tac R.term = ECL.mk_meta_monadic (R.mk_app (R.pack_ln (R.Tv_FVar (R.pack_fv ["Pulse"; "Lib"; "Dv"; "unreachable"]))) [comp_res c, R.Q_Explicit; unit_tm, R.Q_Explicit]) - | Tm_WithInv { body } | Tm_PragmaWithOptions { body } -> extract_dv g body end diff --git a/src/checker/Pulse.Lib.Core.Typing.fst b/src/checker/Pulse.Lib.Core.Typing.fst index f07d75937..f172ba15d 100644 --- a/src/checker/Pulse.Lib.Core.Typing.fst +++ b/src/checker/Pulse.Lib.Core.Typing.fst @@ -29,8 +29,6 @@ let return_stt_ghost_noeq_typing _ _ _ = admit () let while_typing _ _ _ = admit () -let par_typing _ _ _ _ _ _ _ _ _ = admit () - let exists_inversion _ = admit () let elim_exists_typing _ _ _ = admit () let intro_exists_typing _ _ _ = admit () diff --git a/src/checker/Pulse.Lib.Core.Typing.fsti b/src/checker/Pulse.Lib.Core.Typing.fsti index c0e3a3e17..853399348 100644 --- a/src/checker/Pulse.Lib.Core.Typing.fsti +++ b/src/checker/Pulse.Lib.Core.Typing.fsti @@ -180,29 +180,6 @@ let par_post (u:universe) (aL aR:term) (postL postR:term) (x:var) : term = let post = mk_star postL postR in RT.subst_term post [ RT.ND x 0 ] -val par_typing - (#g:env) - (#u:universe) - (#aL #aR:term) - (#preL #postL:term) - (#preR #postR:term) - (#eL #eR:term) - (x:var{None? (RT.lookup_bvar g x)}) - (aL_typing:RT.tot_typing g aL (pack_ln (Tv_Type u))) - (aR_typing:RT.tot_typing g aR (pack_ln (Tv_Type u))) - (preL_typing:RT.tot_typing g preL slprop_tm) - (postL_typing:RT.tot_typing g postL (mk_arrow (aL, Q_Explicit) slprop_tm)) - (preR_typing:RT.tot_typing g preR slprop_tm) - (postR_typing:RT.tot_typing g postR (mk_arrow (aR, Q_Explicit) slprop_tm)) - (eL_typing:RT.tot_typing g eL (mk_stt_comp u aL preL postL)) - (eR_typing:RT.tot_typing g eR (mk_stt_comp u aR preR postR)) - - : GTot (RT.tot_typing g - (mk_par u aL aR preL postL preR postR eL eR) - (mk_stt_comp u (mk_tuple2 u u aL aR) - (mk_star preL preR) - (mk_abs (mk_tuple2 u u aL aR) Q_Explicit (par_post u aL aR postL postR x)))) - val exists_inversion (#g:env) (#u:universe) diff --git a/src/checker/Pulse.Reflection.Util.fst b/src/checker/Pulse.Reflection.Util.fst index cdbfae01b..746f83ee0 100644 --- a/src/checker/Pulse.Reflection.Util.fst +++ b/src/checker/Pulse.Reflection.Util.fst @@ -603,19 +603,6 @@ let mk_sub_stt_ghost (u:R.universe) (a pre1 pre2 post1 post2 e:R.term) = let t = pack_ln (R.Tv_App t (`(), Q_Explicit)) in pack_ln (R.Tv_App t (e, Q_Explicit)) -let mk_par (u:R.universe) (aL aR preL postL preR postR eL eR:R.term) = - let open R in - let lid = ["Pulse"; "Lib"; "Par"; "par_stt"] in - let t = pack_ln (Tv_UInst (R.pack_fv lid) [u]) in - let t = pack_ln (Tv_App t (aL, Q_Implicit)) in - let t = pack_ln (Tv_App t (aR, Q_Implicit)) in - let t = pack_ln (Tv_App t (preL, Q_Implicit)) in - let t = pack_ln (Tv_App t (postL, Q_Implicit)) in - let t = pack_ln (Tv_App t (preR, Q_Implicit)) in - let t = pack_ln (Tv_App t (postR, Q_Implicit)) in - let t = pack_ln (Tv_App t (eL, Q_Explicit)) in - pack_ln (Tv_App t (eR, Q_Explicit)) - let tm_rewrite_tactic_t = let open R in let fv = R.pack_fv (mk_pulse_lib_core_lid "rewrite_tactic_t") in diff --git a/src/checker/Pulse.Soundness.Par.fst b/src/checker/Pulse.Soundness.Par.fst deleted file mode 100644 index 4c3c1cc51..000000000 --- a/src/checker/Pulse.Soundness.Par.fst +++ /dev/null @@ -1,114 +0,0 @@ -(* - 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.Soundness.Par - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module R = FStar.Reflection.V2 - -module PReflUtil = Pulse.Reflection.Util -module WT = Pulse.Lib.Core.Typing - - -#push-options "--z3rlimit_factor 4 --fuel 4 --ifuel 1" -let par_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Par? d}) - (soundness: soundness_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let T_Par _ eL cL eR cR x cL_typing cR_typing eL_typing eR_typing = d in - - let uL = comp_u cL in - let uR = comp_u cR in - let raL = comp_res cL in - let raR = comp_res cR in - let rpreL = comp_pre cL in - let rpostL = mk_abs raL R.Q_Explicit (comp_post cL) in - let rpreR = comp_pre cR in - let rpostR = mk_abs raR R.Q_Explicit (comp_post cR) in - let reL = elab_st_typing eL_typing in - let reR = elab_st_typing eR_typing in - - let reL_typing - : RT.tot_typing _ reL (elab_comp cL) = - soundness g eL cL eL_typing in - - let reR_typing - : RT.tot_typing _ reR (elab_comp cR) = - soundness g eR cR eR_typing in - - let (raL_typing, rpreL_typing, rpostL_typing) - : (RT.tot_typing _ raL (R.pack_ln (R.Tv_Type uL)) & - RT.tot_typing _ rpreL slprop_tm & - RT.tot_typing _ rpostL (mk_arrow (raL, R.Q_Explicit) slprop_tm)) = - - inversion_of_stt_typing g cL (Comp.comp_typing_soundness g cL _ cL_typing) in - - let (raR_typing, rpreR_typing, rpostR_typing) - : (RT.tot_typing _ raR (R.pack_ln (R.Tv_Type uR)) & - RT.tot_typing _ rpreR slprop_tm & - RT.tot_typing _ rpostR (mk_arrow (raR, R.Q_Explicit) slprop_tm)) = - - inversion_of_stt_typing g cR (Comp.comp_typing_soundness g cR _ cR_typing) in - - let aL = comp_res cL in - let aR = comp_res cR in - let postL = comp_post cL in - let postR = comp_post cR in - let x_tm = term_of_no_name_var x in - let rx_tm = RT.var_as_term x in - - elab_open_commute' postL (mk_fst uL uR aL aR x_tm) 0; - elab_open_commute' postR (mk_snd uL uR aL aR x_tm) 0; - - let post_body_eq : RT.equiv (RT.extend_env (elab_env g) x _) - (mk_star (R.pack_ln (R.Tv_App rpostL (PReflUtil.mk_fst uL uR raL raR rx_tm, R.Q_Explicit))) - (R.pack_ln (R.Tv_App rpostR (PReflUtil.mk_snd uL uR raL raR rx_tm, R.Q_Explicit)))) - (tm_star (open_term' postL (mk_fst uL uR aL aR x_tm) 0) - (open_term' postR (mk_snd uL uR aL aR x_tm) 0)) - = assume (RT.ln' postL 0); - assume (RT.ln (mk_fst uL uR aL aR x_tm)); - assume (RT.ln' postR 0); - assume (RT.ln (mk_snd uL uR aL aR x_tm)); - mk_star_equiv _ _ _ _ _ - (RT.Rel_beta _ raL _ postL _) - (RT.Rel_beta _ raR _ postR _) in - - let post_eq - : RT.equiv (elab_env g) - (mk_abs _ R.Q_Explicit _) - (mk_abs _ R.Q_Explicit _) - = RT.equiv_abs_close _ _ x post_body_eq in - assume (uL == uR); //TODO: we should simplify Par to remove the result type altogether - let d = WT.par_typing x raL_typing raR_typing rpreL_typing rpostL_typing - rpreR_typing rpostR_typing - reL_typing reR_typing in - - RT.T_Sub _ _ _ _ d - (RT.Relc_typ _ _ _ _ _ - (RT.Rel_equiv _ _ _ _ (elab_stt_equiv _ c _ _ (RT.Rel_refl _ _ _) post_eq))) -#pop-options diff --git a/src/checker/Pulse.Soundness.Par.fsti b/src/checker/Pulse.Soundness.Par.fsti deleted file mode 100644 index b02c3f662..000000000 --- a/src/checker/Pulse.Soundness.Par.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - 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.Soundness.Par - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val par_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Par? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.fst b/src/checker/Pulse.Soundness.fst index 54a5de8f6..5dd88b8c9 100644 --- a/src/checker/Pulse.Soundness.fst +++ b/src/checker/Pulse.Soundness.fst @@ -32,7 +32,6 @@ module Return = Pulse.Soundness.Return module Exists = Pulse.Soundness.Exists module While = Pulse.Soundness.While module Admit = Pulse.Soundness.Admit -module Par = Pulse.Soundness.Par module WithLocal = Pulse.Soundness.WithLocal module WithLocalArray = Pulse.Soundness.WithLocalArray module Rewrite = Pulse.Soundness.Rewrite @@ -289,9 +288,6 @@ let rec soundness (g:stt_env) While.while_soundness d soundness | T_NuWhile .. -> admit() - - | T_Par .. -> - Par.par_soundness d soundness | T_WithLocal .. -> WithLocal.withlocal_soundness d soundness @@ -307,8 +303,6 @@ let rec soundness (g:stt_env) | T_Unreachable .. -> RU.magic() | T_Sub .. -> Sub.sub_soundness d soundness - - | T_WithInv .. -> RU.magic() // IOU #pop-options let soundness_lemma diff --git a/src/checker/Pulse.Syntax.Base.fst b/src/checker/Pulse.Syntax.Base.fst index bff550276..fd2744797 100644 --- a/src/checker/Pulse.Syntax.Base.fst +++ b/src/checker/Pulse.Syntax.Base.fst @@ -238,15 +238,6 @@ let rec eq_st_term (t1 t2:st_term) eq_st_term cond1 cond2 && eq_st_term body1 body2 - | Tm_Par {pre1=preL1; body1=eL1; post1=postL1; pre2=preR1; body2=eR1; post2=postR1 }, - Tm_Par {pre1=preL2; body1=eL2; post1=postL2; pre2=preR2; body2=eR2; post2=postR2 } -> - eq_tm preL1 preL2 && - eq_st_term eL1 eL2 && - eq_tm postL1 postL2 && - eq_tm preR1 preR2 && - eq_st_term eR1 eR2 && - eq_tm postR1 postR2 - | Tm_WithLocal { binder=x1; initializer=e1; body=b1 }, Tm_WithLocal { binder=x2; initializer=e2; body=b2 } -> eq_tm x1.binder_ty x2.binder_ty && @@ -284,16 +275,6 @@ let rec eq_st_term (t1 t2:st_term) eq_list eq_binder bs1 bs2 && eq_st_term t1 t2 - | Tm_WithInv {name=name1; returns_inv=r1; body=body1}, - Tm_WithInv {name=name2; returns_inv=r2; body=body2} -> - eq_tm name1 name2 && - eq_opt (fun (b1, r1, is1) (b2, r2, is2) -> - eq_tm b1.binder_ty b2.binder_ty && - eq_tm r1 r2 && - eq_tm is1 is2) r1 r2 - && - eq_st_term body1 body2 - | Tm_PragmaWithOptions { options=o1; body=b1 }, Tm_PragmaWithOptions { options=o2; body=b2 } -> o1 = o2 && eq_st_term b1 b2 diff --git a/src/checker/Pulse.Syntax.Base.fsti b/src/checker/Pulse.Syntax.Base.fsti index 62696477a..787a6f358 100644 --- a/src/checker/Pulse.Syntax.Base.fsti +++ b/src/checker/Pulse.Syntax.Base.fsti @@ -272,14 +272,6 @@ type st_term' = condition:st_term; body:st_term; } - | Tm_Par { - pre1:term; - body1:st_term; - post1:term; - pre2:term; - body2:st_term; - post2:term; - } | Tm_WithLocal { binder:binder; initializer:term; @@ -311,11 +303,6 @@ type st_term' = binders:list binder; t:st_term } - | Tm_WithInv { - name : term; // invariant name is an F* term that is an Tm_fvar or Tm_name - body : st_term; - returns_inv : option (binder & slprop & term); // returns _:t ensures p opens is - } | Tm_PragmaWithOptions { options: string; body: st_term diff --git a/src/checker/Pulse.Syntax.Builder.fst b/src/checker/Pulse.Syntax.Builder.fst index 935399126..3bfe2ec70 100644 --- a/src/checker/Pulse.Syntax.Builder.fst +++ b/src/checker/Pulse.Syntax.Builder.fst @@ -48,8 +48,6 @@ let tm_elim_exists p = Tm_ElimExists { p } let tm_intro_exists p witnesses = Tm_IntroExists { p; witnesses } let tm_while invariant condition condition_var body = Tm_While { invariant; condition; condition_var; body } let tm_nuwhile invariant condition body = Tm_NuWhile { invariant; condition; body } -let tm_par pre1 body1 post1 pre2 body2 post2 = Tm_Par { pre1; body1; post1; pre2; body2; post2 } -let tm_with_inv name body returns_inv = Tm_WithInv { name; body; returns_inv } let tm_add_inv names n r = tm_add_inv names n let tm_with_local binder initializer body = Tm_WithLocal { binder; initializer; body } let tm_with_local_array binder initializer length body = Tm_WithLocalArray { binder; initializer; length; body } diff --git a/src/checker/Pulse.Syntax.Naming.fst b/src/checker/Pulse.Syntax.Naming.fst index 8a8bc2b4a..41202a869 100644 --- a/src/checker/Pulse.Syntax.Naming.fst +++ b/src/checker/Pulse.Syntax.Naming.fst @@ -198,14 +198,6 @@ let rec close_open_inverse_st' (t:st_term) admit(); // need map dec fusion () - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - close_open_inverse' pre1 x i; - close_open_inverse_st' body1 x i; - close_open_inverse' post1 x (i + 1); - close_open_inverse' pre2 x i; - close_open_inverse_st' body2 x i; - close_open_inverse' post2 x (i + 1) - | Tm_WithLocal { binder; initializer; body } -> close_open_inverse' binder.binder_ty x i; close_open_inverse' initializer x i; @@ -234,17 +226,6 @@ let rec close_open_inverse_st' (t:st_term) close_open_inverse_proof_hint_type' hint_type x (i + n); close_open_inverse_st' t x (i + n) - | Tm_WithInv { name; body; returns_inv } -> ( - close_open_inverse' name x i; - close_open_inverse_st' body x i; - match returns_inv with - | None -> () - | Some (b, r, is) -> - close_open_inverse' b.binder_ty x i; - close_open_inverse' r x (i + 1); - close_open_inverse' is x i - ) - | Tm_PragmaWithOptions { body } -> close_open_inverse_st' body x i #pop-options diff --git a/src/checker/Pulse.Syntax.Naming.fsti b/src/checker/Pulse.Syntax.Naming.fsti index 8e57c5326..4646b73d1 100644 --- a/src/checker/Pulse.Syntax.Naming.fsti +++ b/src/checker/Pulse.Syntax.Naming.fsti @@ -129,13 +129,6 @@ let rec freevars_st (t:st_term) freevars invariant ++ freevars_st condition ++ freevars_st body - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - (freevars pre1 ++ - freevars_st body1 ++ - freevars post1) ++ - (freevars pre2 ++ - freevars_st body2 ++ - freevars post2) | Tm_WithLocal { binder; initializer; body } -> freevars binder.binder_ty ++ @@ -165,16 +158,6 @@ let rec freevars_st (t:st_term) freevars_proof_hint hint_type ++ freevars_st t - | Tm_WithInv { name; body; returns_inv } -> - freevars name ++ - freevars_st body ++ - freevars_opt - (fun (b, r, is) -> - freevars b.binder_ty ++ - freevars r ++ - freevars is) - returns_inv - | Tm_PragmaWithOptions { body } -> freevars_st body @@ -332,14 +315,6 @@ let rec ln_st' (t:st_term) (i:int) ln_st' condition i && ln_st' body i - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - ln' pre1 i && - ln_st' body1 i && - ln' post1 (i + 1) && - ln' pre2 i && - ln_st' body2 i && - ln' post2 (i + 1) - | Tm_WithLocal { binder; initializer; body } -> ln' binder.binder_ty i && ln' initializer i && @@ -367,16 +342,6 @@ let rec ln_st' (t:st_term) (i:int) ln_proof_hint' hint_type (i + n) && ln_st' t (i + n) - | Tm_WithInv { name; body; returns_inv } -> - ln' name i && - ln_st' body i && - ln_opt' - (fun (b, r, is) i -> - ln' b.binder_ty i && - ln' r (i + 1) && - ln' is i) - returns_inv i - | Tm_PragmaWithOptions { body } -> ln_st' body i @@ -596,14 +561,6 @@ let rec subst_st_term (t:st_term) (ss:subst) condition = subst_st_term condition ss; body = subst_st_term body ss } - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - Tm_Par { pre1=subst_term pre1 ss; - body1=subst_st_term body1 ss; - post1=subst_term post1 (shift_subst ss); - pre2=subst_term pre2 ss; - body2=subst_st_term body2 ss; - post2=subst_term post2 (shift_subst ss) } - | Tm_WithLocal { binder; initializer; body } -> Tm_WithLocal { binder = subst_binder binder ss; initializer = subst_term initializer ss; @@ -636,19 +593,6 @@ let rec subst_st_term (t:st_term) (ss:subst) hint_type=subst_proof_hint hint_type ss; t = subst_st_term t ss } - | Tm_WithInv { name; body; returns_inv } -> - let name = subst_term name ss in - let body = subst_st_term body ss in - let returns_inv = - match returns_inv with - | None -> None - | Some (b, r, is) -> - Some (subst_binder b ss, - subst_term r (shift_subst ss), - subst_term is ss) - in - Tm_WithInv { name; body; returns_inv } - | Tm_PragmaWithOptions { options; body } -> Tm_PragmaWithOptions { options; body=subst_st_term body ss } diff --git a/src/checker/Pulse.Syntax.Printer.fst b/src/checker/Pulse.Syntax.Printer.fst index 78393e393..246bd7288 100644 --- a/src/checker/Pulse.Syntax.Printer.fst +++ b/src/checker/Pulse.Syntax.Printer.fst @@ -368,15 +368,6 @@ let rec st_term_to_string' (level:string) (t:st_term) (st_term_to_string' (indent level) body) level - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - sprintf "par (<%s> (%s) <%s) (<%s> (%s) <%s)" - (term_to_string pre1) - (st_term_to_string' level body1) - (term_to_string post1) - (term_to_string pre2) - (st_term_to_string' level body2) - (term_to_string post2) - | Tm_Rewrite { t1; t2; tac_opt } -> sprintf "rewrite %s as %s (with %s)" (term_to_string t1) @@ -444,19 +435,6 @@ let rec st_term_to_string' (level:string) (t:st_term) in sprintf "%s %s %s; %s" with_prefix ht p (st_term_to_string' level t) - - | Tm_WithInv { name; body; returns_inv } -> - sprintf "with_inv %s %s %s" - (term_to_string name) - (st_term_to_string' level body) - (match returns_inv with - | None -> "" - | Some (b, t, is) -> - sprintf "\nreturns %s\nensures %s\nopens %s" - (binder_to_string b) - (term_to_string t) - (term_to_string is)) - | Tm_PragmaWithOptions { options; body } -> sprintf "#set-options \"%s\" {\n%s\n%s}" options (st_term_to_string' (indent level) body) level @@ -521,14 +499,12 @@ let tag_of_st_term (t:st_term) = | Tm_IntroExists _ -> "Tm_IntroExists" | Tm_While _ -> "Tm_While" | Tm_NuWhile _ -> "Tm_NuWhile" - | Tm_Par _ -> "Tm_Par" | Tm_WithLocal _ -> "Tm_WithLocal" | Tm_WithLocalArray _ -> "Tm_WithLocalArray" | Tm_Rewrite _ -> "Tm_Rewrite" | Tm_Admit _ -> "Tm_Admit" | Tm_Unreachable _ -> "Tm_Unreachable" | Tm_ProofHintWithBinders _ -> "Tm_ProofHintWithBinders" - | Tm_WithInv _ -> "Tm_WithInv" | Tm_PragmaWithOptions _ -> "Tm_PragmaWithOptions" let tag_of_comp (c:comp) : T.Tac string = @@ -553,7 +529,6 @@ let rec print_st_head (t:st_term) | Tm_NuWhile _ -> "NuWhile" | Tm_Admit _ -> "Admit" | Tm_Unreachable _ -> "Unreachable" - | Tm_Par _ -> "Par" | Tm_Rewrite _ -> "Rewrite" | Tm_WithLocal _ -> "WithLocal" | Tm_WithLocalArray _ -> "WithLocalArray" @@ -562,7 +537,6 @@ let rec print_st_head (t:st_term) | Tm_IntroExists _ -> "IntroExists" | Tm_ElimExists _ -> "ElimExists" | Tm_ProofHintWithBinders _ -> "AssertWithBinders" - | Tm_WithInv _ -> "WithInv" | Tm_PragmaWithOptions _ -> "PragmaWithOptions" and print_head (t:term) = @@ -585,7 +559,6 @@ let rec print_skel (t:st_term) = | Tm_NuWhile _ -> "NuWhile" | Tm_Admit _ -> "Admit" | Tm_Unreachable _ -> "Unreachable" - | Tm_Par _ -> "Par" | Tm_Rewrite _ -> "Rewrite" | Tm_WithLocal _ -> "WithLocal" | Tm_WithLocalArray _ -> "WithLocalArray" @@ -594,7 +567,6 @@ let rec print_skel (t:st_term) = | Tm_IntroExists _ -> "IntroExists" | Tm_ElimExists _ -> "ElimExists" | Tm_ProofHintWithBinders _ -> "AssertWithBinders" - | Tm_WithInv _ -> "WithInv" | Tm_PragmaWithOptions _ -> "PragmaWithOptions" let decl_to_string (d:decl) : T.Tac string = diff --git a/src/checker/Pulse.Typing.FV.fst b/src/checker/Pulse.Typing.FV.fst index 6459d5616..4a6b979c0 100644 --- a/src/checker/Pulse.Typing.FV.fst +++ b/src/checker/Pulse.Typing.FV.fst @@ -184,14 +184,6 @@ let rec freevars_close_st_term' (t:st_term) (x:var) (i:index) freevars_close_st_term' condition x i; freevars_close_st_term' body x i - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - freevars_close_term' pre1 x i; - freevars_close_st_term' body1 x i; - freevars_close_term' post1 x (i + 1); - freevars_close_term' pre2 x i; - freevars_close_st_term' body2 x i; - freevars_close_term' post2 x (i + 1) - | Tm_Rewrite { t1; t2; tac_opt } -> freevars_close_term' t1 x i; freevars_close_term' t2 x i; @@ -220,17 +212,6 @@ let rec freevars_close_st_term' (t:st_term) (x:var) (i:index) freevars_close_proof_hint' hint_type x (i + n); freevars_close_st_term' t x (i + n) - | Tm_WithInv { name; body; returns_inv } -> ( - freevars_close_term' name x i; - freevars_close_st_term' body x i; - match returns_inv with - | None -> () - | Some (b, r, is) -> - freevars_close_term' b.binder_ty x i; - freevars_close_term' r x (i + 1); - freevars_close_term' is x i - ) - | Tm_PragmaWithOptions { body } -> freevars_close_st_term' body x i #pop-options @@ -673,28 +654,6 @@ fun d cb -> assert (freevars (open_term' inv tm_false 0) `Set.subset` freevars inv) #pop-options -#push-options "--z3rlimit 40 --fuel 3 --ifuel 2" -#restart-solver // avoiding z3 crash on 4.13.3 -let st_typing_freevars_par : st_typing_freevars_case T_Par? = -fun d cb -> - match d with - | T_Par _ _ cL _ cR x _ _ eL_typing eR_typing -> - let x_tm = term_of_no_name_var x in - let uL = comp_u cL in - let uR = comp_u cR in - let aL = comp_res cL in - let aR = comp_res cR in - cb eL_typing; - cb eR_typing; - freevars_mk_fst uL uR aL aR x_tm; - freevars_mk_snd uL uR aL aR x_tm; - freevars_open_term (comp_post cL) (Pulse.Typing.mk_fst uL uR aL aR x_tm) 0; - freevars_open_term (comp_post cR) (Pulse.Typing.mk_snd uL uR aL aR x_tm) 0; - freevars_close_term (tm_star (open_term' (comp_post cL) (Pulse.Typing.mk_fst uL uR aL aR x_tm) 0) - (open_term' (comp_post cR) (Pulse.Typing.mk_snd uL uR aL aR x_tm) 0)) x 0; - freevars_mk_tuple2 uL uR aL aR -#pop-options - let st_typing_freevars_rewrite : st_typing_freevars_case T_Rewrite? = fun d cb -> match d with @@ -786,8 +745,6 @@ let rec st_typing_freevars st_typing_freevars_while d st_typing_freevars | T_NuWhile .. -> st_typing_freevars_nuwhile d st_typing_freevars - | T_Par .. -> - st_typing_freevars_par d st_typing_freevars | T_Rewrite .. -> st_typing_freevars_rewrite d st_typing_freevars | T_WithLocal .. -> @@ -798,8 +755,6 @@ let rec st_typing_freevars st_typing_freevars_admit d st_typing_freevars | T_Unreachable _ c c_typing _ -> st_typing_freevars_unreachable d st_typing_freevars - | T_WithInv .. -> - admit () // IOU | T_Sub _ _ _ _ d_t d_sub -> st_typing_freevars d_t; st_sub_freevars d_sub \ No newline at end of file diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst index 9389b5de1..2b3983bd0 100644 --- a/src/checker/Pulse.Typing.LN.fst +++ b/src/checker/Pulse.Typing.LN.fst @@ -259,14 +259,6 @@ let rec open_st_term_ln' (e:st_term) open_st_term_ln' condition x i; open_st_term_ln' body x i - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - open_term_ln' pre1 x i; - open_st_term_ln' body1 x i; - open_term_ln' post1 x (i + 1); - open_term_ln' pre2 x i; - open_st_term_ln' body2 x i; - open_term_ln' post2 x (i + 1) - | Tm_Rewrite { t1; t2 } -> open_term_ln' t1 x i; open_term_ln' t2 x i @@ -296,17 +288,6 @@ let rec open_st_term_ln' (e:st_term) open_proof_hint_ln hint_type x (i + n); open_st_term_ln' t x (i + n) - | Tm_WithInv { name; body; returns_inv } -> ( - open_term_ln' name x i; - open_st_term_ln' body x i; - match returns_inv with - | None -> () - | Some (b, r, is) -> - open_term_ln' b.binder_ty x i; - open_term_ln' r x (i + 1); - open_term_ln' is x i - ) - | Tm_PragmaWithOptions { body } -> open_st_term_ln' body x i @@ -492,14 +473,6 @@ let rec ln_weakening_st (t:st_term) (i j:int) map_opt_lemma_2 ln_weakening_comp c.elaborated (i + 1) (j + 1); ln_weakening_st body (i + 1) (j + 1) - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - ln_weakening pre1 i j; - ln_weakening_st body1 i j; - ln_weakening post1 (i + 1) (j + 1); - ln_weakening pre2 i j; - ln_weakening_st body2 i j; - ln_weakening post2 (i + 1) (j + 1) - | Tm_Rewrite { t1; t2 } -> ln_weakening t1 i j; ln_weakening t2 i j @@ -525,17 +498,6 @@ let rec ln_weakening_st (t:st_term) (i j:int) ln_weakening_proof_hint hint_type (i + n) (j + n); ln_weakening_st t (i + n) (j + n) - | Tm_WithInv { name; body; returns_inv } -> ( - ln_weakening name i j; - ln_weakening_st body i j; - match returns_inv with - | None -> () - | Some (b, r, is) -> - ln_weakening b.binder_ty i j; - ln_weakening r (i + 1) (j + 1); - ln_weakening is i j - ) - | Tm_PragmaWithOptions { body } -> ln_weakening_st body i j @@ -702,15 +664,6 @@ let rec open_term_ln_inv_st' (t:st_term) map_opt_lemma_2 open_comp_ln_inv' c.elaborated x (i + 1); open_term_ln_inv_st' body x (i + 1) - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' pre1 x i; - open_term_ln_inv_st' body1 x i; - open_term_ln_inv' post1 x (i + 1); - open_term_ln_inv' pre2 x i; - open_term_ln_inv_st' body2 x i; - open_term_ln_inv' post2 x (i + 1) - | Tm_Rewrite { t1; t2 } -> FStar.Pure.BreakVC.break_vc(); open_term_ln_inv' t1 x i; @@ -744,18 +697,6 @@ let rec open_term_ln_inv_st' (t:st_term) open_proof_hint_ln_inv hint_type x (i + n); open_term_ln_inv_st' t x (i + n) - | Tm_WithInv { name; body; returns_inv } -> ( - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' name x i; - open_term_ln_inv_st' body x i; - match returns_inv with - | None -> () - | Some (b, r, is) -> - open_term_ln_inv' b.binder_ty x i; - open_term_ln_inv' r x (i + 1); - open_term_ln_inv' is x i - ) - | Tm_PragmaWithOptions { body } -> open_term_ln_inv_st' body x i #pop-options @@ -918,15 +859,6 @@ let rec close_st_term_ln' (t:st_term) (x:var) (i:index) map_opt_lemma_2 close_comp_ln' c.elaborated x (i + 1); close_st_term_ln' body x (i + 1) - | Tm_Par { pre1; body1; post1; pre2; body2; post2 } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' pre1 x i; - close_st_term_ln' body1 x i; - close_term_ln' post1 x (i + 1); - close_term_ln' pre2 x i; - close_st_term_ln' body2 x i; - close_term_ln' post2 x (i + 1) - | Tm_Rewrite { t1; t2 } -> FStar.Pure.BreakVC.break_vc(); close_term_ln' t1 x i; @@ -959,18 +891,6 @@ let rec close_st_term_ln' (t:st_term) (x:var) (i:index) let n = L.length binders in close_proof_hint_ln hint_type x (i + n); close_st_term_ln' t x (i + n) - - | Tm_WithInv { name; body; returns_inv } -> ( - FStar.Pure.BreakVC.break_vc(); - close_term_ln' name x i; - close_st_term_ln' body x i; - match returns_inv with - | None -> () - | Some (ret_ty, returns_post, ret_is) -> - close_term_ln' ret_ty.binder_ty x i; - close_term_ln' returns_post x (i + 1); - close_term_ln' ret_is x i - ) | Tm_PragmaWithOptions { body } -> close_st_term_ln' body x i @@ -1161,35 +1081,6 @@ let comp_par_ln (cL : comp{C_ST? cL}) (cR : comp{C_ST? cR}) (x : var) () #pop-options -#push-options "--fuel 1 --ifuel 1 --z3rlimit_factor 10 --split_queries no --z3cliopt 'smt.qi.eager_threshold=100'" -let st_typing_ln_par - (#g:_) (#t:_) (#c:_) - (d:st_typing g t c{T_Par? d}) - (cb : (#g:_ -> #t:_ -> #c:_ -> d':st_typing g t c{d' << d} -> Lemma (ensures ln_st t /\ ln_c c))) - : Lemma - (ensures ln_st t /\ ln_c c) - (decreases d) -= - let T_Par _ _ cL _ cR x _ _ eL_typing eR_typing = d in - let x_tm = term_of_no_name_var x in - let u = comp_u cL in - let aL = comp_res cL in - let aR = comp_res cR in - cb eL_typing; - cb eR_typing; - ln_mk_fst u aL aR x_tm (-1); - ln_mk_snd u aL aR x_tm (-1); - open_term_ln_inv' (comp_post cL) (Pulse.Typing.mk_fst u u aL aR x_tm) 0; - close_term_ln' (open_term' (comp_post cL) (Pulse.Typing.mk_fst u u aL aR x_tm) 0) x 0; - open_term_ln_inv' (comp_post cR) (Pulse.Typing.mk_snd u u aL aR x_tm) 0; - close_term_ln' (open_term' (comp_post cR) (Pulse.Typing.mk_snd u u aL aR x_tm) 0) x 0; - assert (ln_st t); - assert (ln_c cL); - assert (ln_c cR); - comp_par_ln cL cR x; - assert (ln_c c); - () - // Note the use of break_vc in every case below. #push-options "--z3rlimit_factor 15 --fuel 4 --ifuel 1 --split_queries no --z3cliopt 'smt.qi.eager_threshold=100'" @@ -1312,9 +1203,6 @@ let rec st_typing_ln (#g:_) (#t:_) (#c:_) st_typing_ln body_typing; open_term_ln_inv' post tm_false 0 - | T_Par _ _ cL _ cR x _ _ eL_typing eR_typing -> - st_typing_ln_par d st_typing_ln - | T_Rewrite _ _ _ p_typing equiv_p_q -> FStar.Pure.BreakVC.break_vc (); tot_or_ghost_typing_ln p_typing; @@ -1355,6 +1243,4 @@ let rec st_typing_ln (#g:_) (#t:_) (#c:_) st_typing_ln d; st_sub_ln d_sub - | T_WithInv .. -> - admit() // IOU #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index 943c0f754..5699b85f3 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -994,22 +994,6 @@ type st_typing : env -> st_term -> comp -> Type = body })) (comp_nuwhile inv post_cond) - | T_Par: - g:env -> - eL:st_term -> - cL:comp { C_ST? cL } -> - eR:st_term -> - cR:comp { C_ST? cR /\ comp_u cL == comp_u cR } -> - x:var { None? (lookup g x) } -> - // TODO: can comp_typing come from inversion of eL : cL and eR : cR? - comp_typing_u g cL -> - comp_typing_u g cR -> - st_typing g eL cL -> - st_typing g eR cR -> - st_typing g (wrst cL (Tm_Par { pre1=tm_unknown; body1=eL; post1=tm_unknown; - pre2=tm_unknown; body2=eR; post2=tm_unknown })) - (comp_par cL cR x) - | T_WithLocal: g:env -> binder_ppname:ppname -> @@ -1077,19 +1061,6 @@ type st_typing : env -> st_term -> comp -> Type = prop_validity g (S.wr (`False) FStar.Range.range_0) -> st_typing g (wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable {c})) c - | T_WithInv: - g:env -> - i:term -> - p:term -> - body:st_term -> - c:comp_st { C_STAtomic? c || C_STGhost? c } -> - tot_typing g i tm_iname -> - tot_typing g p tm_slprop -> - body_typing : st_typing g body (add_frame_later_l c p) -> - inv_disjointness_token:prop_validity g (inv_disjointness (comp_inames c) i) -> - st_typing g (wtag (Some (ctag_of_comp_st c)) (Tm_WithInv {name=i; body; returns_inv=None})) - (comp_with_inv c i p) - and pats_complete : env -> term -> typ -> list R.pattern -> Type0 = // just check the elaborated term with the core tc | PC_Elab : diff --git a/src/extraction/ExtractPulse.fst b/src/extraction/ExtractPulse.fst index 96c4d32bf..1eafa403f 100644 --- a/src/extraction/ExtractPulse.fst +++ b/src/extraction/ExtractPulse.fst @@ -117,9 +117,8 @@ let pulse_translate_expr : translate_expr_t = fun env e -> EBufWrite (cb e1, zero_for_deref, cb e2) (* Pulse arrays *) - | MLE_App ({ expr = MLE_Name p }, [ x; n]) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [_; x; n]) - when string_of_mlpath p = "Pulse.Lib.Array.Core.mask_alloc" -> + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [_; x; n; _; _]) + when string_of_mlpath p = "Pulse.Lib.Array.Core.mask_alloc_with_vis" -> EBufCreate (Stack, cb x, cb n) | MLE_App ({ expr = MLE_Name p }, [ x; n]) diff --git a/src/extraction/ExtractPulseOCaml.fst b/src/extraction/ExtractPulseOCaml.fst index d8ad2cf21..6d73919e2 100644 --- a/src/extraction/ExtractPulseOCaml.fst +++ b/src/extraction/ExtractPulseOCaml.fst @@ -145,8 +145,8 @@ let tr_expr (g:uenv) (t:term) : mlexpr & e_tag & mlty = let e = with_ty mlty <| MLE_App (bang, [(cb g r)._1; (cb g x)._1]) in e, E_PURE, mlty - | _, _, [(t, _); _; (x, None); (sz, None)] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Array.Core.mask_alloc") -> + | _, _, [(t, _); _; (x, None); (sz, None); _; _] + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Array.Core.mask_alloc_with_vis") -> let mlty = term_as_mlty g t in let bang = with_ty ml_unit_ty <| MLE_Var "Array.make" in let e = with_ty mlty <| MLE_App (bang, [(cb g sz)._1; (cb g x)._1]) in diff --git a/src/ml/PulseSyntaxExtension_Parser.ml b/src/ml/PulseSyntaxExtension_Parser.ml index 20503d068..6bf21f465 100644 --- a/src/ml/PulseSyntaxExtension_Parser.ml +++ b/src/ml/PulseSyntaxExtension_Parser.ml @@ -15,14 +15,12 @@ let rewrite_token (tok:FP.token) | IDENT "invariant" -> PP.INVARIANT | IDENT "while" -> PP.WHILE | IDENT "fn" -> PP.FN - | IDENT "parallel" -> PP.PARALLEL | IDENT "each" -> PP.EACH | IDENT "rewrite" -> PP.REWRITE | IDENT "fold" -> PP.FOLD | IDENT "atomic" -> PP.ATOMIC | IDENT "ghost" -> PP.GHOST | IDENT "unobservable" -> PP.UNOBSERVABLE - | IDENT "with_invariants" -> PP.WITH_INVS | IDENT "opens" -> PP.OPENS | IDENT "show_proof_state" -> PP.SHOW_PROOF_STATE | IDENT "norewrite" -> PP.NOREWRITE diff --git a/src/ml/PulseSyntaxExtension_SyntaxWrapper.ml b/src/ml/PulseSyntaxExtension_SyntaxWrapper.ml index b4c368bee..cf057fe3c 100644 --- a/src/ml/PulseSyntaxExtension_SyntaxWrapper.ml +++ b/src/ml/PulseSyntaxExtension_SyntaxWrapper.ml @@ -185,12 +185,6 @@ let tm_proof_hint_with_binders (ht:_) (binders: binder list) (s:st_term) r : st binders; t3=s }) r) -let tm_with_inv (name:term) (body:st_term) returns_inv r : st_term = - PSB.(with_range (tm_with_inv name body returns_inv) r) - -let tm_par p1 p2 q1 q2 b1 b2 r : st_term = - PSB.(with_range (tm_par p1 b1 q1 p2 b2 q2) r) - let tm_admit r : st_term = PSB.(with_range (tm_admit STT u_zero (tm_unknown r) None) r) let tm_unreachable r : st_term = diff --git a/src/ml/pulseparser.mly b/src/ml/pulseparser.mly index 47dfa3a58..c5a8d1e3b 100644 --- a/src/ml/pulseparser.mly +++ b/src/ml/pulseparser.mly @@ -68,9 +68,9 @@ let add_decorations decors ds = %} /* pulse specific tokens; rest are inherited from F* */ -%token MUT FN INVARIANT WHILE REF PARALLEL REWRITE FOLD EACH NOREWRITE +%token MUT FN INVARIANT WHILE REF REWRITE FOLD EACH NOREWRITE %token GHOST ATOMIC UNOBSERVABLE -%token WITH_INVS OPENS SHOW_PROOF_STATE +%token OPENS SHOW_PROOF_STATE %token PRESERVES %start pulseDeclEOF @@ -258,11 +258,6 @@ pulseStmtNoSeq: { PulseSyntaxExtension_Sugar.mk_while tm inv body } | INTRO p=pulseSLProp WITH ws=nonempty_list(indexingTerm) { PulseSyntaxExtension_Sugar.mk_intro p ws } - | PARALLEL REQUIRES p1=pulseSLProp AND p2=pulseSLProp - ENSURES q1=pulseSLProp AND q2=pulseSLProp - LBRACE b1=pulseStmt RBRACE - LBRACE b2=pulseStmt RBRACE - { PulseSyntaxExtension_Sugar.mk_par p1 p2 q1 q2 b1 b2 } | bs=withBindersOpt REWRITE body=rewriteBody { PulseSyntaxExtension_Sugar.mk_proof_hint_with_binders body bs @@ -301,8 +296,6 @@ bindableTerm: | LBRACK_BAR v=noSeqTerm SEMICOLON n=noSeqTerm BAR_RBRACK { Array_initializer { init=v; len=n } } pulseBindableTerm: - | WITH_INVS names=nonempty_list(atomicTerm) r=option(ensuresSLProp) LBRACE body=pulseStmt RBRACE - { PulseSyntaxExtension_Sugar.mk_with_invs names body r } | p=ifStmt { p } pulseLambda: diff --git a/src/syntax_extension/PulseSyntaxExtension.Desugar.fst b/src/syntax_extension/PulseSyntaxExtension.Desugar.fst index 3e8862048..653875d31 100644 --- a/src/syntax_extension/PulseSyntaxExtension.Desugar.fst +++ b/src/syntax_extension/PulseSyntaxExtension.Desugar.fst @@ -601,52 +601,9 @@ let rec desugar_stmt' (env:env_t) (s:Sugar.stmt) return (SW.tm_intro_exists vp witnesses s.range) ) - | Parallel { p1; p2; q1; q2; b1; b2 } -> - let! p1 = desugar_slprop env p1 in - let! p2 = desugar_slprop env p2 in - let! q1 = desugar_slprop env q1 in - let! q2 = desugar_slprop env q2 in - let! b1 = desugar_stmt env b1 in - let! b2 = desugar_stmt env b2 in - return (SW.tm_par p1 p2 q1 q2 b1 b2 s.range) - | LetBinding _ -> fail "Terminal let binding" s.range - | WithInvariants { names=n1::names; body; returns_ } -> - let! n1 = tosyntax env n1 in - let! names = names |> mapM (tosyntax env) in - let! body = desugar_stmt env body in - let! returns_ = - let opens_tm opens_opt : err SW.term = - match opens_opt with - | Some opens -> desugar_term env opens - | None -> - let all_names = n1::names in - let opens_tm = L.fold_left (fun names n -> - SW.tm_add_inv names (tm_expr n s.range) s.range) SW.tm_emp_inames all_names in - return opens_tm in - match returns_ with - | None -> return None - | Some (None, v, opens_opt) -> - let! v = desugar_slprop env v in - let b = SW.mk_binder (Ident.id_of_text "_") (SW.tm_unknown s.range) in - let! opens = opens_tm opens_opt in - return (Some (b, v, opens)) - | Some (Some (x, t), v, opens_opt) -> - let! t = desugar_term env t in - let env, bv = push_bv env x in - let! v = desugar_slprop env v in - let v = SW.close_term v bv.index in - let b = SW.mk_binder x t in - let! opens = opens_tm opens_opt in - return (Some (b, v, opens)) - in - (* the returns_ goes only to the outermost with_inv *) - let tt = L.fold_right (fun nm body -> let nm : term = tm_expr nm s.range in SW.tm_with_inv nm body None s.range) names body in - let n1 : term = tm_expr n1 s.range in - return (SW.tm_with_inv n1 tt returns_ s.range) - | PragmaSetOptions { options; body } -> FStarC.Syntax.Util.process_pragma (S.PushOptions <| Some options) s.range; let! body = desugar_stmt env body in diff --git a/src/syntax_extension/PulseSyntaxExtension.Sugar.fst b/src/syntax_extension/PulseSyntaxExtension.Sugar.fst index 34a0f16f7..19fb305b0 100644 --- a/src/syntax_extension/PulseSyntaxExtension.Sugar.fst +++ b/src/syntax_extension/PulseSyntaxExtension.Sugar.fst @@ -169,26 +169,11 @@ type stmt' = s2:stmt; } - | Parallel { - p1:slprop; - p2:slprop; - q1:slprop; - q2:slprop; - b1:stmt; - b2:stmt; - } - | ProofHintWithBinders { hint_type:hint_type; binders:binders; } - | WithInvariants { - names : list A.term; - body : stmt; - returns_ : option ensures_slprop; - } - | PragmaSetOptions { options:string; body:stmt @@ -256,9 +241,7 @@ let tag_of_stmt (s:stmt) : string = | While {} -> "While" | Introduce {} -> "Introduce" | Sequence {} -> "Sequence" - | Parallel {} -> "Parallel" | ProofHintWithBinders {} -> "ProofHintWithBinders" - | WithInvariants {} -> "WithInvariants" instance tagged_stmt : Class.Tagged.tagged stmt = { tag_of = tag_of_stmt @@ -334,26 +317,11 @@ let rec stmt_to_string (s:stmt) : string = "s1", stmt_to_string s1; "s2", stmt_to_string s2; ] - | Parallel { p1; p2; q1; q2; b1; b2 } -> - "Parallel " ^ record_string [ - "p1", show p1; - "p2", show p2; - "q1", show q1; - "q2", show q2; - "b1", stmt_to_string b1; - "b2", stmt_to_string b2; - ] | ProofHintWithBinders { hint_type; binders } -> "ProofHintWithBinders " ^ record_string [ "hint_type", show hint_type; "binders", show binders; ] - | WithInvariants { names; body; returns_ } -> - "WithInvariants " ^ record_string [ - "names", FStarC.Common.string_of_list show names; - "body", stmt_to_string body; - "returns_", FStarC.Common.string_of_option show returns_; - ] and branch_to_string (b:bool & A.pattern & stmt) : string = let (norw, p, s) = b in @@ -461,20 +429,9 @@ and eq_stmt' (s1 s2:stmt') = forall2 AD.eq_term w1 w2 | Sequence { s1=s1; s2=s2 }, Sequence { s1=s1'; s2=s2' } -> eq_stmt s1 s1' && eq_stmt s2 s2' - | Parallel { p1=p1; p2=p2; q1=q1; q2=q2; b1=b1; b2=b2 }, Parallel { p1=p1'; p2=p2'; q1=q1'; q2=q2'; b1=b1'; b2=b2' } -> - eq_slprop p1 p1' && - eq_slprop p2 p2' && - eq_slprop q1 q1' && - eq_slprop q2 q2' && - eq_stmt b1 b1' && - eq_stmt b2 b2' | ProofHintWithBinders { hint_type=ht1; binders=bs1 }, ProofHintWithBinders { hint_type=ht2; binders=bs2 } -> eq_hint_type ht1 ht2 && forall2 AD.eq_binder bs1 bs2 - | WithInvariants { names=n1; body=b1; returns_=r1 }, WithInvariants { names=n2; body=b2; returns_=r2 } -> - forall2 AD.eq_term n1 n2 && - eq_stmt b1 b2 && - eq_opt eq_ensures_slprop r1 r2 | PragmaSetOptions { options=o1; body=b1 }, PragmaSetOptions { options=o2; body=b2 } -> o1=o2 && eq_stmt b1 b2 @@ -599,20 +556,9 @@ and scan_stmt (cbs:A.dep_scan_callbacks) (s:stmt) = scan_slprop cbs s; iter cbs.scan_term w | Sequence { s1=s1; s2=s2 } -> scan_stmt cbs s1; scan_stmt cbs s2 - | Parallel { p1=p1; p2=p2; q1=q1; q2=q2; b1=b1; b2=b2 } -> - scan_slprop cbs p1; - scan_slprop cbs p2; - scan_slprop cbs q1; - scan_slprop cbs q2; - scan_stmt cbs b1; - scan_stmt cbs b2 | ProofHintWithBinders { hint_type=ht; binders=bs } -> scan_hint_type cbs ht; iter (scan_binder cbs) bs - | WithInvariants { names=n; body=b; returns_=r } -> - iter cbs.scan_term n; - scan_stmt cbs b; - iopt (scan_ensures_slprop cbs) r | PragmaSetOptions { body } -> scan_stmt cbs body and scan_let_init (cbs:A.dep_scan_callbacks) (i:let_init) = @@ -673,8 +619,6 @@ let mk_fn_decl id us binders ascription decorations range : fn_decl = { id; us; binders; ascription; decorations; range } let mk_open lid = Open lid -let mk_par p1 p2 q1 q2 b1 b2 = Parallel { p1; p2; q1; q2; b1; b2 } let mk_proof_hint_with_binders ht bs = ProofHintWithBinders { hint_type=ht; binders=bs } let mk_lambda bs ascription body range : lambda = { binders=bs; ascription; body; range } -let mk_with_invs names body returns_ = WithInvariants { names; body; returns_ } let mk_pragma_set_options options body = PragmaSetOptions { options; body } \ No newline at end of file diff --git a/src/syntax_extension/PulseSyntaxExtension.SyntaxWrapper.fsti b/src/syntax_extension/PulseSyntaxExtension.SyntaxWrapper.fsti index e596aaeb8..dc4bcf99b 100644 --- a/src/syntax_extension/PulseSyntaxExtension.SyntaxWrapper.fsti +++ b/src/syntax_extension/PulseSyntaxExtension.SyntaxWrapper.fsti @@ -104,7 +104,6 @@ val tm_match (head:term) (returns_:option slprop) (brs:list branch) (_:range) : val tm_intro_exists (vp:slprop) (witnesses:list term) (_:range) : st_term val is_tm_intro_exists (x:st_term) : bool val tm_protect (s:st_term) : st_term -val tm_par (p1:term) (p2:term) (q1:term) (q2:term) (b1:st_term) (b2:st_term) (_:range) : st_term val tm_admit (_:range) : st_term val tm_unreachable (_:range) : st_term val tm_proof_hint_with_binders (_:hint_type) (_:list binder) (body:st_term) (_:range) : st_term diff --git a/test/ExtractionTest.fst b/test/ExtractionTest.fst index d2fbedb56..ae98a6b3f 100644 --- a/test/ExtractionTest.fst +++ b/test/ExtractionTest.fst @@ -27,12 +27,8 @@ fn test_invariants_and_later () ensures emp { let i = new_invariant emp; - later_credit_buy 1; - with_invariants i - returns _: unit - ensures later emp { - later_elim emp; - later_intro emp; + with_invariants unit emp_inames i emp emp (fun _ -> emp) fn _ { + () }; drop_ (inv i emp); } diff --git a/test/ExtractionTest.ml.expected b/test/ExtractionTest.ml.expected index 05b749ebe..2890a0695 100644 --- a/test/ExtractionTest.ml.expected +++ b/test/ExtractionTest.ml.expected @@ -1,6 +1,7 @@ open Prims let zero (uu___ : unit) : FStar_UInt32.t= Stdint.Uint32.zero -let rec test_invariants_and_later (uu___ : unit) : unit= () +let rec test_invariants_and_later (uu___ : unit) : unit= + let k uu___1 uu___2 = () in let f uu___3 uu___4 = k () () in f () () let rec test_read_write (x : FStar_UInt32.t Pulse_Lib_Reference.ref) (_'n : unit) : unit= let n = Pulse_Lib_Reference.read x () () in diff --git a/test/InlineArrayLen.ml.expected b/test/InlineArrayLen.ml.expected index e6c2f933c..142c763f5 100644 --- a/test/InlineArrayLen.ml.expected +++ b/test/InlineArrayLen.ml.expected @@ -1,33 +1,35 @@ open Prims let rec basic (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) - (Stdint.Uint64.of_int (2)) in + Pulse_Lib_Array_Core.mask_alloc_with_vis () (Stdint.Int32.of_int (123)) + (Stdint.Uint64.of_int (2)) () () in Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) - (Stdint.Uint64.of_int (2)) in + Pulse_Lib_Array_Core.mask_alloc_with_vis () (Stdint.Int32.of_int (123)) + (Stdint.Uint64.of_int (2)) () () in Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use_gen_init (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) - (Stdint.Uint64.of_int (2)) in + Pulse_Lib_Array_Core.mask_alloc_with_vis () (Stdint.Int32.of_int (123)) + (Stdint.Uint64.of_int (2)) () () in Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use_gen_init_st (uu___ : unit) : FStar_Int32.t= let init uu___1 uu___2 = (Stdint.Int32.of_int (123)) in let __anf0 = init () () in let arr = - Pulse_Lib_Array_Core.mask_alloc () __anf0 (Stdint.Uint64.of_int (2)) in + Pulse_Lib_Array_Core.mask_alloc_with_vis () __anf0 + (Stdint.Uint64.of_int (2)) () () in Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use_gen_len (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) - (Stdint.Uint64.of_int (2)) in + Pulse_Lib_Array_Core.mask_alloc_with_vis () (Stdint.Int32.of_int (123)) + (Stdint.Uint64.of_int (2)) () () in Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use_gen_len_st (uu___ : unit) : FStar_Int32.t= let len uu___1 uu___2 = (Stdint.Uint64.of_int (42)) in let __anf0 = len () () in let arr = - Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) __anf0 in + Pulse_Lib_Array_Core.mask_alloc_with_vis () (Stdint.Int32.of_int (123)) + __anf0 () () in Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () diff --git a/test/bug-reports/Bug.Invariants.fst b/test/bug-reports/Bug.Invariants.fst index 2777f1320..22d3c617f 100644 --- a/test/bug-reports/Bug.Invariants.fst +++ b/test/bug-reports/Bug.Invariants.fst @@ -101,7 +101,7 @@ requires inv i p returns x:bool ensures inv i p { - with_invariants i { + with_invariants bool emp_inames i p emp (fun _ -> emp) fn _ { atomic_step_res(); } } @@ -115,11 +115,8 @@ requires inv i (pts_to x 1ul) returns _:U32.t ensures inv i (pts_to x 1ul) { - with_invariants i { - later_elim_timeless _; - let r = read_atomic x; - later_intro (pts_to x 1ul); - r + with_invariants U32.t emp_inames i (pts_to x 1ul) emp (fun _ -> emp) fn _ { + read_atomic x } } @@ -130,14 +127,10 @@ requires inv i (pts_to x 0ul) ** pts_to y 'w ensures inv i (pts_to x 0ul) ** pts_to y 0ul { let n = - with_invariants i - returns r:U32.t - ensures later (pts_to x 0ul) ** pure (r == 0ul) ** pts_to y 'w - opens [i] { - later_elim_timeless _; - let r = read_atomic x; - later_intro (pts_to x 0ul); - r + with_invariants U32.t emp_inames i (pts_to x 0ul) + (pts_to y 'w) + (fun r -> pure (r == 0ul) ** pts_to y 'w) fn _ { + read_atomic x }; y := n; } diff --git a/test/pool/domainslib/Makefile b/test/pool/domainslib/Makefile index d8a10feea..d3870e587 100644 --- a/test/pool/domainslib/Makefile +++ b/test/pool/domainslib/Makefile @@ -35,6 +35,9 @@ dune: all_ml .PHONY: test test: run +.PHONY: accept +accept: + .PHONY: run run: dune ./dune/_build/default/driver.exe diff --git a/test/pool/domainslib/dune/Pulse_Lib_Task.ml b/test/pool/domainslib/dune/Pulse_Lib_Task.ml index fafa10d79..e22fe4baf 100644 --- a/test/pool/domainslib/dune/Pulse_Lib_Task.ml +++ b/test/pool/domainslib/dune/Pulse_Lib_Task.ml @@ -74,6 +74,6 @@ let teardown_pool p = wait_for_empty p; T.teardown_pool p.p -let spawn_ p () () () f = +let spawn_ p () () () () () f = let _ = async p f in () diff --git a/test/pool/pulse_task/Makefile b/test/pool/pulse_task/Makefile index edf986bf2..cbb6b1a1a 100644 --- a/test/pool/pulse_task/Makefile +++ b/test/pool/pulse_task/Makefile @@ -37,6 +37,9 @@ dune: all_ml .PHONY: test test: run +.PHONY: accept +accept: + .PHONY: run run: dune ./dune/_build/default/driver.exe diff --git a/test/pool/pulse_task/dune/Pulse_Lib_Core.ml b/test/pool/pulse_task/dune/Pulse_Lib_Core.ml index cbb7a485e..5b3188bb3 100644 --- a/test/pool/pulse_task/dune/Pulse_Lib_Core.ml +++ b/test/pool/pulse_task/dune/Pulse_Lib_Core.ml @@ -1 +1 @@ -let fork () f = ignore (Domain.spawn f) +let fork_core () () f = ignore (Domain.spawn f) From 1c90a011d46150291f07951efbc08da27674ef55 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Wed, 12 Nov 2025 13:34:24 -0800 Subject: [PATCH 2/4] Add impersonate combinators. --- lib/common/Pulse.Lib.Core.fsti | 17 +++++++ lib/core/Pulse.Lib.Core.fst | 2 + lib/pulse/lib/Pulse.Lib.Send.fst | 73 +++++++++++++++++++++++++++++++ lib/pulse/lib/Pulse.Lib.Send.fsti | 38 ++++++++++++++++ 4 files changed, 130 insertions(+) diff --git a/lib/common/Pulse.Lib.Core.fsti b/lib/common/Pulse.Lib.Core.fsti index e3ed7e708..df976cc00 100644 --- a/lib/common/Pulse.Lib.Core.fsti +++ b/lib/common/Pulse.Lib.Core.fsti @@ -459,6 +459,23 @@ val on_star_eq l a b : squash (on l (a ** b) == on l a ** on l b) val on_on_eq l1 l2 a : squash (on l1 (on l2 a) == on l2 a) val on_loc_eq l1 l2 : squash (on l1 (loc l2) == pure (l1 == l2)) +inline_for_extraction +[@@deprecated "impersonate_core is unsound; only use for model implementations"; + extract_as (`(fun (#a:Type0) () () () (f: unit -> Dv a) -> f ()))] +val impersonate_core #a + (l: loc_id) (pre: slprop) (post: a -> slprop) + (f: unit -> stt a pre (fun x -> post x)) + : stt a (on l pre) (fun x -> on l (post x)) + +inline_for_extraction +[@@deprecated "atomic impersonate_core is unsound; only use for model implementations"; + extract_as (`(fun (#a:Type0) () () () () () (f: unit -> Dv a) -> f ()))] +val atomic_impersonate_core #a + (#[T.exact (`emp_inames)] is: inames) #obs + (l: loc_id) (pre: slprop) (post: a -> slprop) + (f: unit -> stt_atomic a #obs is pre (fun x -> post x)) + : stt_atomic a #obs is (on l pre) (fun x -> on l (post x)) + val ghost_impersonate_core (#[T.exact (`emp_inames)] is: inames) (l: loc_id) (pre post: slprop) diff --git a/lib/core/Pulse.Lib.Core.fst b/lib/core/Pulse.Lib.Core.fst index 9974610bc..310caa972 100644 --- a/lib/core/Pulse.Lib.Core.fst +++ b/lib/core/Pulse.Lib.Core.fst @@ -202,6 +202,8 @@ let on_star_eq = Sep.on_star_eq let on_on_eq = Sep.on_on_eq let on_loc_eq = Sep.on_loc_eq +let impersonate_core l pre post f = PulseCore.Action.impersonate_stt l (f ()) +let atomic_impersonate_core l pre post f = A.impersonate_atomic l (f ()) let ghost_impersonate_core l pre post f = A.impersonate_ghost l (f ()) ////////////////////////////////////////////////////////////////////////// diff --git a/lib/pulse/lib/Pulse.Lib.Send.fst b/lib/pulse/lib/Pulse.Lib.Send.fst index 493fd340e..ecd590f4f 100644 --- a/lib/pulse/lib/Pulse.Lib.Send.fst +++ b/lib/pulse/lib/Pulse.Lib.Send.fst @@ -52,6 +52,79 @@ ghost fn placeless_on (l: loc_id) (p: slprop) : placeless (on l p) = l1 l2 { on_on_eq l2 l p; rewrite on l p as on l2 (on l p); } +[@@deprecated "impersonate is unsound; only use for model implementations"] +noextract inline_for_extraction +fn impersonate + u#a (a: Type u#a) + (l: loc_id) (pre: slprop) (post: a -> slprop) + {| placeless pre, ((x:a) -> placeless (post x)) |} + (f: unit -> stt a (loc l ** pre) (fun x -> loc l ** post x)) + requires pre + returns x: a + ensures post x +{ + on_loc_eq l l; rewrite pure (l == l) as on l (loc l); + placeless_on_intro pre l; + on_star_eq l (loc l) pre; rewrite on l (loc l) ** on l pre as on l (loc l ** pre); + let x = impersonate_core l (loc l ** pre) post fn _ { + let x = f (); + drop_ (loc l); + x + }; + placeless_on_elim (post x) l; + x +} + +[@@deprecated "atomic_impersonate is unsound; only use for model implementations"] +noextract inline_for_extraction +atomic fn atomic_impersonate + u#a (a: Type u#a) + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre: slprop) (post: a -> slprop) + {| placeless pre, ((x:a) -> placeless (post x)) |} + (f: unit -> stt_atomic a is (loc l ** pre) (fun x -> loc l ** post x)) + opens is + requires pre + returns x: a + ensures post x +{ + on_loc_eq l l; rewrite pure (l == l) as on l (loc l); + placeless_on_intro pre l; + on_star_eq l (loc l) pre; rewrite on l (loc l) ** on l pre as on l (loc l ** pre); + let x = atomic_impersonate_core #a #is #Observable l (loc l ** pre) post fn _ { + let x = f (); + drop_ (loc l); + x + }; + placeless_on_elim (post x) l; + x +} + +[@@deprecated "unobservable_impersonate is unsound; only use for model implementations"] +noextract inline_for_extraction +unobservable fn unobservable_impersonate + u#a (a: Type u#a) + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre: slprop) (post: a -> slprop) + {| placeless pre, ((x:a) -> placeless (post x)) |} + (f: unit -> stt_atomic a #Neutral is (loc l ** pre) (fun x -> loc l ** post x)) + opens is + requires pre + returns x: a + ensures post x +{ + on_loc_eq l l; rewrite pure (l == l) as on l (loc l); + placeless_on_intro pre l; + on_star_eq l (loc l) pre; rewrite on l (loc l) ** on l pre as on l (loc l ** pre); + let x = atomic_impersonate_core #a #is #Neutral l (loc l ** pre) post fn _ { + let x = f (); + drop_ (loc l); + x + }; + placeless_on_elim (post x) l; + x +} + ghost fn ghost_impersonate (#[T.exact (`emp_inames)] is: inames) (l: loc_id) (pre post: slprop) {| placeless pre, placeless post |} diff --git a/lib/pulse/lib/Pulse.Lib.Send.fsti b/lib/pulse/lib/Pulse.Lib.Send.fsti index 47dc7d438..9f80937bd 100644 --- a/lib/pulse/lib/Pulse.Lib.Send.fsti +++ b/lib/pulse/lib/Pulse.Lib.Send.fsti @@ -17,6 +17,7 @@ module Pulse.Lib.Send open Pulse.Lib.Core open Pulse.Class.Duplicable +open PulseCore.Observability open Pulse.Main module T = FStar.Tactics.V2 #lang-pulse @@ -31,6 +32,43 @@ irreducible let anywhere (l: loc_id) = () type placeless (p: slprop) = is_send_across anywhere p +[@@deprecated "impersonate is unsound; only use for model implementations"] +noextract inline_for_extraction +fn impersonate + u#a (a: Type u#a) + (l: loc_id) (pre: slprop) (post: a -> slprop) + {| placeless pre, ((x:a) -> placeless (post x)) |} + (f: unit -> stt a (loc l ** pre) (fun x -> loc l ** post x)) + requires pre + returns x: a + ensures post x + +[@@deprecated "atomic_impersonate is unsound; only use for model implementations"] +noextract inline_for_extraction +atomic fn atomic_impersonate + u#a (a: Type u#a) + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre: slprop) (post: a -> slprop) + {| placeless pre, ((x:a) -> placeless (post x)) |} + (f: unit -> stt_atomic a is (loc l ** pre) (fun x -> loc l ** post x)) + opens is + requires pre + returns x: a + ensures post x + +[@@deprecated "unobservable_impersonate is unsound; only use for model implementations"] +noextract inline_for_extraction +unobservable fn unobservable_impersonate + u#a (a: Type u#a) + (#[T.exact (`emp_inames)] is: inames) + (l: loc_id) (pre: slprop) (post: a -> slprop) + {| placeless pre, ((x:a) -> placeless (post x)) |} + (f: unit -> stt_atomic a #Neutral is (loc l ** pre) (fun x -> loc l ** post x)) + opens is + requires pre + returns x: a + ensures post x + ghost fn ghost_impersonate (#[T.exact (`emp_inames)] is: inames) (l: loc_id) (pre post: slprop) {| placeless pre, placeless post |} From 2b08ae00059d29033b0efdc101de97c341f5b07c Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Sun, 9 Nov 2025 15:41:58 -0800 Subject: [PATCH 3/4] expose some utils --- lib/pulse/lib/Pulse.Lib.Send.fst | 68 +++++++++++++++---------------- lib/pulse/lib/Pulse.Lib.Send.fsti | 18 ++++++++ 2 files changed, 52 insertions(+), 34 deletions(-) diff --git a/lib/pulse/lib/Pulse.Lib.Send.fst b/lib/pulse/lib/Pulse.Lib.Send.fst index ecd590f4f..f7c4554a6 100644 --- a/lib/pulse/lib/Pulse.Lib.Send.fst +++ b/lib/pulse/lib/Pulse.Lib.Send.fst @@ -174,6 +174,30 @@ ghost fn on_pure_elim l p placeless_on_elim (pure p) l; } +ghost fn on_star_elim #l (p q: slprop) + requires on l (p ** q) + ensures on l p + ensures on l q +{ + ghost_impersonate l (on l (p ** q)) (on l p ** on l q) fn _ { + on_elim (p ** q); + on_intro p; + on_intro q; + } +} + +ghost fn on_star_intro #l (p q: slprop) + requires on l p + requires on l q + ensures on l (p ** q) +{ + ghost_impersonate l (on l p ** on l q) (on l (p ** q)) fn _ { + on_elim p; + on_elim q; + on_intro (p ** q); + } +} + ghost fn placeless_later_credit amt : placeless (later_credit amt) = l1 l2 { on_later_credit_eq l1 amt; on_later_credit_eq l2 amt; @@ -203,6 +227,16 @@ ghost fn placeless_exists' u#a (#a: Type u#a) (p: a -> slprop) {| ((x:a) -> plac } let placeless_exists = placeless_exists' +ghost fn on_exists_elim u#a #l (#a: Type u#a) (p: a -> slprop) + requires on l (exists* x. p x) + ensures exists* x. on l (p x) +{ + ghost_impersonate l (on l (exists* x. p x)) (exists* x. on l (p x)) fn _ { + on_elim (exists* x. p x); + on_intro (p _); + } +} + let timeless_in_same_process p = assert_norm (in_same_process p == (exists* l. loc l ** pure (process_of l == process_of p))) @@ -216,40 +250,6 @@ ghost fn dup_in_same_process p () : duplicable_f (in_same_process p) = { instance duplicable_in_same_process p : duplicable (in_same_process p) = { dup_f = dup_in_same_process p } -ghost fn on_star_elim #l (p q: slprop) - requires on l (p ** q) - ensures on l p - ensures on l q -{ - ghost_impersonate l (on l (p ** q)) (on l p ** on l q) fn _ { - on_elim (p ** q); - on_intro p; - on_intro q; - } -} - -ghost fn on_star_intro #l (p q: slprop) - requires on l p - requires on l q - ensures on l (p ** q) -{ - ghost_impersonate l (on l p ** on l q) (on l (p ** q)) fn _ { - on_elim p; - on_elim q; - on_intro (p ** q); - } -} - -ghost fn on_exists_elim u#a #l (#a: Type u#a) (p: a -> slprop) - requires on l (exists* x. p x) - ensures exists* x. on l (p x) -{ - ghost_impersonate l (on l (exists* x. p x)) (exists* x. on l (p x)) fn _ { - on_elim (exists* x. p x); - on_intro (p _); - } -} - ghost fn is_send_across_elim #b (g: loc_id -> b) p {| inst: is_send_across g p |} #l l' requires on l p requires pure (g l == g l') diff --git a/lib/pulse/lib/Pulse.Lib.Send.fsti b/lib/pulse/lib/Pulse.Lib.Send.fsti index 9f80937bd..4cf35741e 100644 --- a/lib/pulse/lib/Pulse.Lib.Send.fsti +++ b/lib/pulse/lib/Pulse.Lib.Send.fsti @@ -89,6 +89,20 @@ ghost fn placeless_on_elim (p: slprop) {| placeless p |} l requires on l p ensures p +ghost fn on_pure_elim l p + requires on l (pure p) + ensures pure p + +ghost fn on_star_elim #l (p q: slprop) + requires on l (p ** q) + ensures on l p + ensures on l q + +ghost fn on_star_intro #l (p q: slprop) + requires on l p + requires on l q + ensures on l (p ** q) + instance val placeless_on (l: loc_id) (p: slprop) : placeless (on l p) instance val placeless_emp : placeless emp instance val placeless_star (a b: slprop) {| placeless a, placeless b |} : placeless (a ** b) @@ -99,6 +113,10 @@ instance val placeless_slprop_ref_pts_to x y : placeless (slprop_ref_pts_to x y) instance val placeless_exists #a (p: a -> slprop) {| ((x:a) -> placeless (p x)) |} : placeless (exists* x. p x) +ghost fn on_exists_elim u#a #l (#a: Type u#a) (p: a -> slprop) + requires on l (exists* x. p x) + ensures exists* x. on l (p x) + let in_same_process p = exists* l. loc l ** pure (process_of l == process_of p) val timeless_in_same_process p : Lemma (timeless (in_same_process p)) [SMTPat (timeless (in_same_process p))] instance val duplicable_in_same_process p : duplicable (in_same_process p) From ec9c0dfb228d14a97d38255a39a7ddc0ae3c43c8 Mon Sep 17 00:00:00 2001 From: Nikhil Swamy Date: Sun, 9 Nov 2025 23:47:29 -0800 Subject: [PATCH 4/4] Automate elimination of `on l _`; treat `on` specially in matching, inheriting the match keys of its second argument --- lib/pulse/lib/Pulse.Lib.Inv.fst | 2 + src/checker/Pulse.Checker.Prover.fst | 407 +++++++++++++++++++++++++-- test/Example.TestOnAutomation.fst | 106 +++++++ 3 files changed, 499 insertions(+), 16 deletions(-) create mode 100644 test/Example.TestOnAutomation.fst diff --git a/lib/pulse/lib/Pulse.Lib.Inv.fst b/lib/pulse/lib/Pulse.Lib.Inv.fst index e3d23518a..849f8d323 100644 --- a/lib/pulse/lib/Pulse.Lib.Inv.fst +++ b/lib/pulse/lib/Pulse.Lib.Inv.fst @@ -60,6 +60,7 @@ ghost fn move i p l1 l2 ensures on l' p { bwd (); + rewrite on l1 p as on l_ p; let f = f; f () }; ghost fn g' () @@ -67,6 +68,7 @@ ghost fn move i p l1 l2 ensures on l2 p { let g = g; g (); + rewrite on l_ p as on l1 p; fwd (); }; fold move_tag l2 l' p f' g'; diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 43364056a..fb39a9c66 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -278,7 +278,9 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp (fun frame -> let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [goal])) = RU.magic () in - k_elab_equiv (intro_pure g'' (elab_slprops frame) p p_typing pv) h1 h2) + k_elab_equiv + (intro_pure g'' (elab_slprops frame) p p_typing pv) + h1 h2) <: T.Tac _ |) end | _ -> None @@ -540,6 +542,10 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) | Some token -> VE_Ext g p q (RT.Rel_eq_token _ _ _ ()) + +let on_name = R.inspect_fv (R.pack_fv <| Pulse.Reflection.Util.mk_pulse_lib_core_lid "on") +let on_head_id : head_id = FVarHead on_name + let teq_nosmt_force_args (g: R.env) (x y: term) (fail_fast: bool) : Dv bool = let rec go (xs ys: list R.argv) : Dv bool = match xs, ys with @@ -551,10 +557,28 @@ let teq_nosmt_force_args (g: R.env) (x y: term) (fail_fast: bool) : Dv bool = if not fail_fast then ignore (go xs ys); false ) - | _ -> false in + | _ -> false + in let xh, xa = R.collect_app_ln x in let yh, ya = R.collect_app_ln y in - go ((xh, R.Q_Explicit) :: xa) ((yh, R.Q_Explicit) :: ya) + let fallback () = + go ((xh, R.Q_Explicit) :: xa) ((yh, R.Q_Explicit) :: ya) + in + match (T.inspect_ln xh, xa), (T.inspect_ln yh, ya) with + | (R.Tv_FVar x, [lx; (px, _)]), (R.Tv_FVar y, [ly;(py, _)]) -> ( + if R.inspect_fv x = on_name && R.inspect_fv y = on_name + then let xx_h, xx_as = R.collect_app_ln px in + let yy_h, yy_as = R.collect_app_ln py in + if T.term_eq xx_h yy_h && List.length xx_as = List.length yy_as + then ( + go ((xh, R.Q_Explicit) :: lx :: (xx_h, R.Q_Explicit) :: xx_as) + ((yh, R.Q_Explicit) :: ly :: (yy_h, R.Q_Explicit) :: yy_as) + ) + else fallback() + else fallback () + ) + | _ -> + fallback () let is_unamb g (cands: list (int & slprop_view)) : T.Tac bool = match cands with @@ -584,9 +608,12 @@ let prove_atom_unamb (g: env) (ctxt: list slprop_view) (goal: slprop_view) : debug_prover g (fun _ -> Printf.sprintf "Tried matching ctxt %s against goal %s, result %b" (show ctxt) (show goal) r); r ) - | _ -> false in + | _ -> false + in + debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: searching for match for goal %s in ctxt %s\n" (show goal) (show ctxt)); let ictxt = List.Tot.mapi (fun i ctxt -> i, ctxt) ctxt in let cands = T.filter (fun (i, ctxt) -> matches_mkeys ctxt) ictxt in + debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: found candidates %s\n" (show cands)); if Nil? cands then ( debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: no matches for %s in context %s\n" (show goal) (show ctxt)); None @@ -599,7 +626,8 @@ let prove_atom_unamb (g: env) (ctxt: list slprop_view) (goal: slprop_view) : else let (i, cand) :: _ = cands in debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: commiting to unify %s and %s\n" (show (elab_slprop cand)) (show goal)); - ignore (teq_nosmt_force_args (elab_env g) (elab_slprop cand) goal false); + let ok = teq_nosmt_force_args (elab_env g) (elab_slprop cand) goal false in + debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: result of unify %s and %s is %s\n" (show (elab_slprop cand)) (show goal) (show ok)); let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> let h2: slprop_equiv g' (elab_slprop cand) goal = check_slprop_equiv_ext (RU.range_of_term goal) _ _ _ in @@ -614,25 +642,44 @@ let prove_atom (g: env) (ctxt: list slprop_view) (allow_amb: bool) (goal: slprop T.Tac (option (prover_result g ctxt [goal])) = match goal with | Atom hd mkeys goal -> + let do_match_mkeys goal mkeys_goal ctxt mkeys_ctxt = + with_uf_transaction (fun _ -> + match mkeys_goal, mkeys_ctxt with + | Some mkeys, Some mkeys' -> + T.zip mkeys mkeys' |> forallb (fun (a, b) -> RU.teq_nosmt_force_phase1 (elab_env g) a b) + | _, _ -> + teq_nosmt_force_args (elab_env g) ctxt goal true + ) + in let matches_mkeys (ctxt: slprop_view) : T.Tac bool = match ctxt with | Atom hd' mkeys' ctxt -> - if hd <> hd' then false else - with_uf_transaction (fun _ -> - match mkeys, mkeys' with - | Some mkeys, Some mkeys' -> - T.zip mkeys mkeys' |> forallb (fun (a, b) -> RU.teq_nosmt_force_phase1 (elab_env g) a b) - | _, _ -> - teq_nosmt_force_args (elab_env g) ctxt goal true + if hd <> hd' then false + else if (hd = on_head_id) //`on l p` inherits the match keys of p + then ( + match T.hua goal, T.hua ctxt with + | Some (_, _, [(l1, _); (p1, _)]), Some (_, _, [(l2, _); (p2, _)]) -> ( + let p1_view = inspect_slprop g p1 in + let p2_view = inspect_slprop g p2 in + match p1_view, p2_view with + | [Atom hd1 mkeys1 p1], [Atom hd2 mkeys2 p2] -> + if hd1 <> hd2 then false + else do_match_mkeys goal mkeys1 ctxt mkeys2 + | _ -> do_match_mkeys goal mkeys ctxt mkeys' + ) + | _ -> do_match_mkeys goal mkeys ctxt mkeys' ) - | _ -> false in + else do_match_mkeys goal mkeys ctxt mkeys' + | _ -> false + in let ictxt = List.Tot.mapi (fun i ctxt -> i, ctxt) ctxt in let cands = T.filter (fun (i, ctxt) -> matches_mkeys ctxt) ictxt in if Nil? cands then None else if (if allow_amb then false else not (is_unamb g cands)) then None else let (i, cand)::_ = cands in - debug_prover g (fun _ -> Printf.sprintf "commiting to unify %s and %s\n" (show (elab_slprop cand)) (show goal)); - ignore (teq_nosmt_force_args (elab_env g) (elab_slprop cand) goal false); + debug_prover g (fun _ -> Printf.sprintf "prove_atom: committed to unifying %s and %s\n" (show (elab_slprop cand)) (show goal)); + let ok = teq_nosmt_force_args (elab_env g) (elab_slprop cand) goal false in + debug_prover g (fun _ -> Printf.sprintf "prove_atom: unified %s and %s, result is %s\n" (show (elab_slprop cand)) (show goal) (show ok)); let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> let h2: slprop_equiv g' (elab_slprop cand) goal = check_slprop_equiv_ext (RU.range_of_term goal) _ _ _ in @@ -644,6 +691,330 @@ let prove_atom (g: env) (ctxt: list slprop_view) (allow_amb: bool) (goal: slprop |) | _ -> None +let loc_id = tm_fvar (as_fv <| Pulse.Reflection.Util.mk_pulse_lib_core_lid "loc_id") +let on_l_p l p = + let on_l = tm_pureapp (tm_fvar (as_fv <| Pulse.Reflection.Util.mk_pulse_lib_core_lid "on")) None l in + tm_pureapp on_l None p +let comp_intro_emp_l (l:term) = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=tm_emp; + post=on_l_p l tm_emp + } +let comp_intro_pure_l (l:term) (p:term) = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=tm_pure p; + post=on_l_p l (tm_pure p) + } +let comp_intro_star_l (l:term) (p1 p2:term) = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=tm_star (on_l_p l p1) (on_l_p l p2); + post=on_l_p l (tm_star p1 p2) + } +let comp_intro_exists_l (l:term) u b p = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=tm_exists_sl u b (on_l_p l p); + post=on_l_p l (tm_exists_sl u b p) + } +let comp_elim_on_l_emp (l:term) = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=on_l_p l tm_emp; + post=tm_emp + } +let comp_elim_on_l_pure (l p:term) = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=on_l_p l (tm_pure p); + post=tm_pure p + } +let comp_elim_on_l_star (l p1 p2:term) = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=on_l_p l (tm_star p1 p2); + post=tm_star (on_l_p l p1) (on_l_p l p2) + } +let comp_elim_on_l_exists l u b body = + C_STGhost tm_emp_inames + { + u=u_zero; + res=tm_unit; + pre=on_l_p l (tm_exists_sl u b body); + post=tm_exists_sl u b (on_l_p l body) + } +let tm_intro_on_l_emp l : st_term' = Tm_ST { t=(`()); args=[] } +let tm_intro_on_l_pure l p : st_term' = Tm_ST { t=(`()); args=[] } +let tm_intro_on_l_star l p1 p2 : st_term' = Tm_ST { t=(`()); args=[] } +let tm_intro_on_l_exists l u b p : st_term' = Tm_ST { t=(`()); args=[] } +let tm_elim_on_l_emp l : st_term' = Tm_ST { t=(`()); args=[] } +let tm_elim_on_l_pure l p : st_term' = Tm_ST { t=(`()); args=[] } +let tm_elim_on_l_star l p1 p2 : st_term' = Tm_ST { t=(`()); args=[] } +let tm_elim_on_l_exists l u b body : st_term' = Tm_ST { t=(`()); args=[] } + +let intro_on_l_emp_rule (g:env) (l:term) (_:tot_typing g l loc_id) +: st_typing g (wtag (Some STT_Ghost) (tm_intro_on_l_emp l)) (comp_intro_emp_l l) += magic() +let intro_on_l_pure_rule (g:env) (l:term) (_:tot_typing g l loc_id) (p:term) (_:tot_typing g p tm_prop) +: st_typing g (wtag (Some STT_Ghost) (tm_intro_on_l_pure l p)) (comp_intro_pure_l l p) += magic() +let intro_on_l_star_rule (g:env) (l:term) (_:tot_typing g l loc_id) + (p1:term) (_:tot_typing g p1 tm_slprop) + (p2:term) (_:tot_typing g p2 tm_slprop) +: st_typing g (wtag (Some STT_Ghost) (tm_intro_on_l_star l p1 p2)) (comp_intro_star_l l p1 p2) += magic() +let intro_on_l_exists_rule (g:env) (l:term) (_:tot_typing g l loc_id) u b p +: st_typing g + (wtag (Some STT_Ghost) (tm_intro_on_l_exists l u b p)) + (comp_intro_exists_l l u b p) += magic() + +let elim_on_l_emp_rule (g:env) (l:term) (_:tot_typing g l loc_id) +: st_typing g + (wtag (Some STT_Ghost) (tm_elim_on_l_emp l)) + (comp_elim_on_l_emp l) += magic() +let elim_on_l_pure_rule (#g:env) (#l:term) (ltyping:tot_typing g l loc_id) (#p:term) (ptyping:tot_typing g p tm_prop) +: st_typing g + (wtag (Some STT_Ghost) (tm_elim_on_l_pure l p)) + (comp_elim_on_l_pure l p) += magic() +let elim_on_l_star_rule (#g:env) (#l:term) (ltyping:tot_typing g l loc_id) + (#p1:term) (p1typing:tot_typing g p1 tm_slprop) + (#p2:term) (p2typing:tot_typing g p2 tm_slprop) +: st_typing g + (wtag (Some STT_Ghost) (tm_elim_on_l_star l p1 p2)) + (comp_elim_on_l_star l p1 p2) += magic() +let elim_on_l_exists_rule (#g:env) (#l:term) (ltyping:tot_typing g l loc_id) + u b body +: st_typing g + (wtag (Some STT_Ghost) (tm_elim_on_l_exists l u b body)) + (comp_elim_on_l_exists l u b body) += magic() + +let mk_simple_elim g frame #tm (#c:comp_st) (step_ty:st_typing g tm c) : + (continuation_elaborator g (frame `tm_star` comp_pre c) g (frame `tm_star` comp_post c)) + = + fun post t -> + let frame_typ : tot_typing g frame tm_slprop = RU.magic () in + let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in + let eq_refl : slprop_equiv g (frame `tm_star` comp_pre c) (frame `tm_star` comp_pre c) = RU.magic() in + let eq : slprop_equiv g (comp_post c `tm_star` frame) (frame `tm_star` comp_post c) = RU.magic() in + k_elab_equiv + (continuation_elaborator_with_bind_nondep frame step_ty h) + eq_refl + eq + post t + +let mk_simple_elim_step (g:env) ctxt (#tm:_) (#c:comp_st) (step_ty:st_typing g tm c) : + T.Tac (prover_result_nogoals g [ctxt]) = + (| g, [Unknown <| comp_post c], [], [], fun g'' -> + (fun frame -> + let h1: slprop_equiv g (tm_star (elab_slprops frame) (comp_pre c)) (elab_slprops (frame @ [ctxt])) = RU.magic () in + let h2: slprop_equiv g (elab_slprops frame `tm_star` comp_post c) (elab_slprops (frame @ [] @ [Unknown <| comp_post c])) = RU.magic () in + k_elab_equiv (mk_simple_elim g (elab_slprops frame) step_ty) h1 h2), + cont_elab_refl _ _ _ (VE_Refl _ _) <: T.Tac _ + |) + +let elim_on_l_step (g:env) (ctxt: slprop_view) : + T.Tac (option (prover_result_nogoals g [ctxt])) = + match ctxt with + | Atom hd mkeys ictxt -> + if hd <> on_head_id then None + else ( + match T.hua ictxt with + | Some (h, _, [(l, _); (p, _)]) -> ( + let l_typing : tot_typing g l loc_id = RU.magic() in + let p_typing : tot_typing g p tm_slprop = RU.magic() in + match inspect_slprop g p with + | [] -> ( //on l emp ~> emp + Some (mk_simple_elim_step g ctxt (elim_on_l_emp_rule g l l_typing)) + ) + | [Pure p] -> (//on l (pure p) ~> pure p + let p_typing : tot_typing g p tm_prop = RU.magic() in + Some (mk_simple_elim_step g ctxt (elim_on_l_pure_rule l_typing p_typing)) + ) + | p1::p2::ps -> (//on l (p1 ** p2 ** ps) ~> on l p1 ** on l (p2::ps) + let p1 = elab_slprop p1 in + let p1_typing : tot_typing g p1 tm_slprop = RU.magic () in + let p2 = (elab_slprops (p2::ps)) in + let p2_typing : tot_typing g p2 tm_slprop = RU.magic () in + Some (mk_simple_elim_step g ctxt (elim_on_l_star_rule l_typing p1_typing p2_typing)) + ) + | [Exists u b body] -> ( //on l (exists* x. p) ~> exists* x. on l p + Some (mk_simple_elim_step g ctxt (elim_on_l_exists_rule l_typing u b body)) + ) + | _ -> None + ) + | _ -> None + ) + | _ -> None + + +let intro_on_l_emp (g: env) (frame: slprop) (l: term) (l_typing:tot_typing g l loc_id) +: continuation_elaborator g frame g (frame `tm_star` (on_l_p l tm_emp)) = + fun post t -> + let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing + let h: tot_typing g (tm_star frame tm_emp) tm_slprop = RU.magic () in + k_elab_equiv + (continuation_elaborator_with_bind_nondep frame (intro_on_l_emp_rule g l l_typing) h) (RU.magic ()) (RU.magic ()) + post t + +let intro_on_l_pure (g: env) (frame: slprop) (l: term) (l_typing:tot_typing g l loc_id) + (p:term) (p_typing:tot_typing g p tm_prop) +: continuation_elaborator g (frame `tm_star` (tm_pure p)) g (frame `tm_star` (on_l_p l (tm_pure p))) = + fun post t -> + let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing + let h: tot_typing g (tm_star frame (tm_pure p)) tm_slprop = RU.magic () in + k_elab_equiv + (continuation_elaborator_with_bind_nondep frame + (intro_on_l_pure_rule g l l_typing _ p_typing) + h) (RU.magic ()) (RU.magic ()) + post t + +let intro_on_l_star (g: env) (frame: slprop) (l: term) (l_typing:tot_typing g l loc_id) + (p1:term) (p1_typing:tot_typing g p1 tm_slprop) + (p2:term) (p2_typing:tot_typing g p2 tm_slprop) +: continuation_elaborator g (frame `tm_star` (on_l_p l p1 `tm_star` on_l_p l p2)) + g (frame `tm_star` (on_l_p l (tm_star p1 p2))) = + fun post t -> + let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing + let h: tot_typing g (tm_star frame (on_l_p l p1 `tm_star` on_l_p l p2)) tm_slprop = RU.magic () in + k_elab_equiv + (continuation_elaborator_with_bind_nondep frame + (intro_on_l_star_rule g l l_typing _ p1_typing _ p2_typing) + h) (RU.magic ()) (RU.magic ()) + post t + +let intro_on_l_exists + (g: env) (frame: slprop) (l: term) (l_typing:tot_typing g l loc_id) + u b p +: continuation_elaborator + g (frame `tm_star` (tm_exists_sl u b (on_l_p l p))) + g (frame `tm_star` (on_l_p l (tm_exists_sl u b p))) = + fun post t -> + let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing + let h: tot_typing g (tm_star frame (tm_exists_sl u b (on_l_p l p))) tm_slprop = RU.magic () in + k_elab_equiv + (continuation_elaborator_with_bind_nondep frame + (intro_on_l_exists_rule g l l_typing u b p) + h) (RU.magic ()) (RU.magic ()) + post t + +#push-options "--z3rlimit_factor 2" +let prove_on_l_emp (g: env) (ctxt: list slprop_view) (goal: slprop_view) l +: T.Tac (prover_result g ctxt [goal]) += let k1 (g'':env{env_extends g g}) + : T.Tac (cont_elab g ctxt g ctxt) + = cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _) + in + let k2 (g'':env{env_extends g g}) + : T.Tac (cont_elab g'' [] g'' [goal]) + = fun frame -> + let l_typing : tot_typing g'' l loc_id = RU.magic () in + let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in + let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (on_l_p l tm_emp)) + (elab_slprops (frame @ [goal])) = RU.magic () in + k_elab_equiv + (intro_on_l_emp g'' (elab_slprops frame) l l_typing) + h1 h2 + in + let p : prover_result g ctxt [goal] = + (| g, ctxt, [], [], fun g'' -> k1 g'', k2 g'' |) + in + p + +let prove_on_l_pure (g: env) (ctxt: list slprop_view) (goal: slprop_view) l p +: T.Tac (prover_result g ctxt [goal]) += (| g, ctxt, [Pure p], [], fun g'' -> + cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + (fun frame -> + let l_typing : tot_typing g'' l loc_id = RU.magic () in + let p_typing : tot_typing g'' p tm_prop = RU.magic () in + let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [Pure p] @ [])) = RU.magic () in + let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (on_l_p l (tm_pure p))) (elab_slprops (frame @ [goal])) = RU.magic () in + k_elab_equiv (intro_on_l_pure g'' (elab_slprops frame) l l_typing p p_typing) h1 h2) + <: T.Tac _ |) + +let prove_on_l_star (g: env) (ctxt: list slprop_view) (goal: slprop_view) l p1 p2 ps +: T.Tac (prover_result g ctxt [goal]) += let p1 = (elab_slprop p1) in + let p2 = (elab_slprops (p2::ps)) in + (| g, ctxt, [Unknown (on_l_p l p1); Unknown (on_l_p l p2)], [], fun g'' -> + cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + (fun frame -> + let l_typing : tot_typing g'' l loc_id = RU.magic () in + let p1_typing : tot_typing g'' p1 tm_slprop = RU.magic () in + let p2_typing : tot_typing g'' p2 tm_slprop = RU.magic () in + let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_star (on_l_p l p1) (on_l_p l p2))) + (elab_slprops (frame @ [Unknown (on_l_p l p1); Unknown (on_l_p l p2)] @ [])) = RU.magic () in + let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (on_l_p l (tm_star p1 p2))) + (elab_slprops (frame @ [goal])) = RU.magic () in + k_elab_equiv (intro_on_l_star g'' (elab_slprops frame) l l_typing p1 p1_typing p2 p2_typing) h1 h2) + <: T.Tac _ |) + + +let prove_on_l_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) l u b p +: T.Tac (prover_result g ctxt [goal]) += (| g, ctxt, [Unknown (tm_exists_sl u b (on_l_p l p))], [], fun g'' -> + cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + (fun frame -> + let l_typing : tot_typing g'' l loc_id = RU.magic () in + let h1: slprop_equiv g'' + (tm_star (elab_slprops frame) (tm_exists_sl u b (on_l_p l p))) + (elab_slprops (frame @ [Unknown (tm_exists_sl u b (on_l_p l p))] @ [])) = RU.magic () in + let h2: slprop_equiv g'' + (tm_star (elab_slprops frame) (on_l_p l (tm_exists_sl u b p))) + (elab_slprops (frame @ [goal])) = RU.magic () in + k_elab_equiv (intro_on_l_exists g'' (elab_slprops frame) l l_typing u b p) h1 h2) + <: T.Tac _ |) + +let prove_on_l (g: env) (ctxt: list slprop_view) (goal: slprop_view) +: T.Tac (option (prover_result g ctxt [goal])) += match goal with + | Atom hd mkeys igoal -> + if hd <> on_head_id then None + else ( + match T.hua igoal with + | Some (h, _, [(l, _); (p, _)]) -> ( + let goal_view = inspect_slprop g p in + match goal_view with + | [] -> ( //on l emp ~> emp + Some (prove_on_l_emp g ctxt goal l) + ) + | [Pure p] -> (//on l (pure p) ~> pure p + Some (prove_on_l_pure g ctxt goal l p) + ) + | p1::p2::ps -> (//on l (p1 ** p2 ** ps) ~> on l p1 ** on l (p2::ps) + Some (prove_on_l_star g ctxt goal l p1 p2 ps) + ) + | [Exists u b body] -> ( + Some (prove_on_l_exists g ctxt goal l u b body) + ) + | _ -> None + ) + | _ -> None + ) + | _ -> None +#pop-options + let rec first_some #a (ks: list (unit -> T.Tac (option a))) : T.Tac (option a) = match ks with | [] -> None @@ -668,6 +1039,7 @@ let rec try_prove_core (g: env) (ctxt goals: list slprop_view) allow_amb : T.Tac let step : option (prover_result g ctxt goals) = first_some [ (fun _ -> elim_first g ctxt goals (unpack_and_norm_ctxt g)); + (fun _ -> elim_first g ctxt goals (elim_on_l_step g)); (fun _ -> elim_first g ctxt goals (elim_pure_step g)); (fun _ -> elim_first g ctxt goals (elim_with_pure_step g)); (fun _ -> elim_first g ctxt goals (elim_exists_step g)); @@ -679,6 +1051,8 @@ let rec try_prove_core (g: env) (ctxt goals: list slprop_view) allow_amb : T.Tac (fun _ -> prove_first g ctxt goals (prove_atom g ctxt allow_amb)); (fun _ -> prove_first g ctxt goals (prove_pure g ctxt false)); (fun _ -> prove_first g ctxt goals (prove_with_pure g ctxt false)); + (fun _ -> prove_first g ctxt goals (prove_on_l g ctxt)); + ] in match step with | Some step -> @@ -799,6 +1173,7 @@ let rec try_elim_core (g: env) (ctxt: list slprop_view) : let step : option (prover_result_nogoals g ctxt) = first_some [ (fun _ -> elim_first' g ctxt [] (unpack_and_norm_ctxt g)); + (fun _ -> elim_first' g ctxt [] (elim_on_l_step g)); (fun _ -> elim_first' g ctxt [] (elim_pure_step g)); (fun _ -> elim_first' g ctxt [] (elim_with_pure_step g)); (fun _ -> elim_first' g ctxt [] (elim_exists_step g)); @@ -826,4 +1201,4 @@ let elim_exists_and_pure (#g:env) (#ctxt:slprop) let before, after = k g' in (| g', elab_slprops ctxt'', h, k_elab_trans (k_elab_equiv (before []) h1 (VE_Refl _ _)) - (k_elab_equiv (after ctxt'') h2 h3) |) + (k_elab_equiv (after ctxt'') h2 h3) |) \ No newline at end of file diff --git a/test/Example.TestOnAutomation.fst b/test/Example.TestOnAutomation.fst new file mode 100644 index 000000000..79489a7bd --- /dev/null +++ b/test/Example.TestOnAutomation.fst @@ -0,0 +1,106 @@ +module Example.TestOnAutomation +#lang-pulse +open Pulse.Lib.Pervasives + +ghost +fn test_on_l_prover_emp (l:loc_id) +requires emp +ensures on l emp +{} + +ghost +fn test_on_l_prover_pure (l:loc_id) (p:prop) +requires pure p +ensures on l (pure p) +{} + +ghost +fn test_on_l_prover_star (l:loc_id) (p1 p2:slprop) +requires on l p1 ** on l p2 +ensures on l (p1 ** p2) +{} + +ghost +fn test_on_l_prover_exists (#a:Type0) (l:loc_id) (p1: a -> slprop) +requires exists* (x:a). on l (p1 x) +ensures on l (exists* (x:a). p1 x) +{} + +ghost +fn test_on_l_prover_exists3 (#a:Type0) (l:loc_id) (p1: a -> a -> a -> slprop) +requires exists* (x y z:a). on l (p1 x y z) +ensures on l (exists* (x y z:a). p1 x y z) +{} + +ghost +fn test_on_l_elim_emp (l:loc_id) +requires on l emp +ensures emp +{} + +ghost +fn test_on_l_elim_pure (l:loc_id) (p:prop) +requires on l (pure p) +ensures pure p +{} + +ghost +fn test_on_l_elim_star (l:loc_id) (p1 p2:slprop) +requires on l (p1 ** p2) +ensures on l p1 ** on l p2 +{} + +ghost +fn test_on_l_elim_star2 (l:loc_id) (p1 p2:slprop) +requires on l (p1 ** p2) +ensures on l (p2 ** p1) +{} + +ghost +fn test_on_l_elim_exists (#a:Type0) (l:loc_id) (p1: a -> slprop) +requires on l (exists* (x:a). p1 x) +ensures exists* (x:a). on l (p1 x) +{} + +ghost +fn test_on_l_elim_exists3 (#a:Type0) (l:loc_id) (p1: a -> a -> a -> slprop) +requires on l (exists* (x y z:a). p1 x y z) +ensures exists* (x y z:a). on l (p1 x y z) +{} + +ghost +fn test_on_l_elim_exists3_star (#a:Type0) (l:loc_id) (p1 p2: a -> a -> a -> slprop) +requires on l (exists* (x y z:a). p1 x y z ** p2 x y z) +ensures exists* (x y z:a). on l (p1 x y z) ** on l (p2 x y z) +{} + +assume +val pred ([@@@mkey]x:int) (y:int) : slprop + +ghost +fn test_pred_ext (l:loc_id) (r:int) (x y:int) +requires pred r (x + y) +ensures pred r (y + x) +{ + #set-options "--debug prover --print_implicits" { () } +} + +ghost +fn test_pred_on_l_ext (l:loc_id) (r s:int) (x y:int) +requires on l (pred r (x + y)) +ensures on l (pred r (y + x)) +{} + +[@@expect_failure] +ghost +fn test_pred_ext_key_failure (l:loc_id) (r s:int) (x y:int) +requires pred r (x + y) ** pure (r == s) +ensures pred s (y + x) +{} + +[@@expect_failure] +ghost +fn test_pred_on_l_ext_key_failure (l:loc_id) (r s:int) (x y:int) +requires on l (pred r (x + y)) ** pure (r == s) +ensures on l (pred s (y + x)) +{} \ No newline at end of file